git.haldean.org grandmaster / 9681587
refactoring, getting ready for pgnview Haldean Brown 8 months ago
8 changed file(s) with 274 addition(s) and 237 deletion(s). Raw diff Collapse all Expand all
22 (require "gamewizard.rkt")
33 (require "gmlib.rkt")
44 (require "guiutil.rkt")
5 (require "info.rkt")
56 (require "invite.rkt")
67 (require "render.rkt")
7 (require "store.rkt")
88 (require lens)
99
1010 (define identity-browser%
+0
-28
frontend/gamemgr.rkt less more
0 #lang racket
1
2 (require racket/async-channel)
3 (require "gmlib.rkt")
4
5 (provide create-monitor stop-monitor)
6
7 (define (poll-rate-sec importance)
8 (case importance
9 [(high) 15] [(low) 300] [else (error "bad importance value")]))
10
11 ; importance should be 'high or 'low, and determines the polling rate
12 (define (create-monitor id game-id importance cb)
13 (let ([exit-chan (make-async-channel)]
14 [fetch (λ () (gm/get-game (first id) game-id))])
15 (thread
16 (λ ()
17 (let loop ([old-gs (fetch)])
18 (let ([exit? (sync/timeout (poll-rate-sec importance) exit-chan)])
19 (unless exit?
20 (let ([new-gs (fetch)])
21 (unless (equal? old-gs new-gs)
22 (cb new-gs))
23 (loop new-gs)))))))
24 exit-chan))
25
26 (define (stop-monitor mon)
27 (async-channel-put mon #t))
00 #lang racket/gui
11
22 (require "guiutil.rkt")
3 (require "store.rkt")
3 (require "info.rkt")
44
55 (provide show-game-wizard request-new-user-name)
66
0 #lang racket
1
2 (require basedir)
3 (require lens)
4 (require racket/block)
5 (require racket/random)
6
7 (require "lensutil.rkt")
8 (require "gmlib.rkt")
9
10 (define version-no 2)
11
12 (provide
13 info/add-existing-player
14 info/add-game
15 info/add-identity
16 info/archive-game
17 info/load
18 info/store
19 info/invite-new-player
20 info/new-game
21
22 game-info-lens
23 player-info-lens
24 )
25
26 (current-basedir-program-name "grandmaster")
27 (unless (directory-exists? (writable-data-dir))
28 (make-directory (writable-data-dir)))
29 (define prefs-file (writable-data-file "prefs.lisp"))
30
31 (define host? string?)
32 (define player-id? positive-integer?)
33 (define game-id? positive-integer?)
34
35 ; identity tuples are pairs of host addr and player ID
36 (define identity? (list/c host? player-id?))
37
38 ; player-info tuples are pairs of player-id and nickname
39 (define player-info? (list/c player-id? string?))
40
41 ; game-info tuples are triples of game-id, white-player-id and black-player-id.
42 (define game-info? (list/c game-id? player-id? player-id?))
43
44 ; server-info tuples are triples of identity, known-games and known-players
45 (define server-info? (list/c (hash/c game-id? game-info?) (hash/c player-id? player-info?)))
46
47 ; the info hash is the root structure that holds all the information we're
48 ; interested in
49 (define info-hash? (and/c (hash/c identity? server-info?) immutable?))
50
51 (define (upgrade-info version info-hash)
52 (if (equal? version version-no) info-hash
53 (case version
54 [else (error "no version handler for version" version)]
55 )))
56
57 (define (info/load-raw)
58 (let-values
59 ([(err r)
60 (call-with-input-file prefs-file
61 (λ (f) (with-handlers
62 ([exn:fail? (λ (v) (values "data file is corrupt" null))])
63 (values null (read f)))))])
64 ; we can't throw the error inside the call-with-input-file lambda, because
65 ; call-with-input-file doesn't close the file if an exception is raised
66 (if (null? err) r (error err))))
67
68 (define/contract (info/load)
69 (-> info-hash?)
70 (let ([r (info/load-raw)])
71 (upgrade-info (cdar r) (cdr r))))
72
73 (define/contract (info/new)
74 (-> info-hash?)
75 (make-immutable-hash))
76
77 (define/contract (info/store p)
78 (-> info-hash? void)
79 (block
80 (call-with-output-file prefs-file
81 (λ (f) (write (cons (cons 'version version-no) p) f))
82 #:exists 'replace)
83 p))
84
85 (define (bind-info-hash func)
86 (λ args (apply func (info/load) args)))
87
88 (define/contract (add-identity info-hash new-identity)
89 (-> info-hash? identity? info-hash?)
90 (info/store
91 (if (hash-has-key? info-hash new-identity)
92 info-hash
93 (hash-set info-hash
94 new-identity
95 (list (make-immutable-hash) (make-immutable-hash))))))
96 (define info/add-identity (bind-info-hash add-identity))
97
98 (define (game-info-lens id)
99 (lens-compose first-lens (hash-ref-lens id)))
100 (define (player-info-lens id)
101 (lens-compose second-lens (hash-ref-lens id)))
102
103 ; adds an existing player to the identity's known users map. no remote changes.
104 (define/contract (add-existing-player info-hash id player)
105 (-> info-hash? identity? player-info? info-hash?)
106 (info/store
107 (lens-set (lens-compose (hash-ref-lens (first player))
108 (player-info-lens id))
109 info-hash
110 player)))
111 (define info/add-existing-player (bind-info-hash add-existing-player))
112
113 ; creates a new player and adds them to thte known users map. creates an
114 ; invitation on the remote.
115 (define/contract (invite-new-player info-hash id nickname)
116 (-> info-hash? identity? string? (values info-hash? player-id?))
117 (let ([new-id (arithmetic-shift
118 (integer-bytes->integer (crypto-random-bytes 8) #f) -1)])
119 (block
120 (gm/new-user (first id) (second id) new-id)
121 (values (add-existing-player info-hash id (list new-id nickname))
122 new-id))))
123 (define info/invite-new-player (bind-info-hash invite-new-player))
124
125 ; creates a new game. calls gm/new-game and gm/get-game.
126 (define/contract (new-game info-hash id other-player self-color)
127 (->i
128 ([info-hash (id other-player)
129 (and/c info-hash?
130 (flat-named-contract
131 "info-hash that contains the provided identity"
132 (λ (h) (hash-has-key? h id)))
133 (flat-named-contract
134 "info-hash that contains the other player"
135 (λ (h) (hash-has-key?
136 (lens-view (player-info-lens id) h)
137 other-player))))]
138 [id identity?]
139 [other-player player-id?]
140 [self-color (one-of/c 'w 'b)])
141 (values [new-hash info-hash?] [new-game-id game-id?] [game-state g?]))
142 (let* ([w (if (equal? self-color 'w) (second id) other-player)]
143 [b (if (equal? self-color 'b) (second id) other-player)]
144 [new-game (gm/new-game (first id) #:white w #:black b)])
145 (let-values ([(new-hash game-state) (add-game info-hash id (g-id new-game))])
146 (values
147 new-hash
148 (g-id new-game)
149 game-state))))
150 (define info/new-game (bind-info-hash new-game))
151
152 ; Adds an existing game to the game map. Calls gm/get-game to figure out
153 ; the ID of the other player in the game.
154 (define/contract (add-game info-hash id game-id)
155 (->i
156 ([info-hash (id game-id)
157 (and/c info-hash?
158 (flat-named-contract
159 "info-hash that contains the provided identity"
160 (λ (h) (hash-has-key? h id)))
161 (flat-named-contract
162 "game does not already exist in info hash"
163 (λ (h) (not (hash-has-key? (lens-view (game-info-lens id) h) game-id)))))]
164 [id identity?]
165 [game-id game-id?])
166 (values [new-hash info-hash?] [game-state g?]))
167 (let ([g (gm/get-game (first id) game-id)])
168 (values
169 (info/store
170 (lens-set (lens-compose (hash-ref-lens game-id) (game-info-lens id))
171 info-hash
172 (list game-id (g-player-white g) (g-player-black g))))
173 g)))
174 (define info/add-game (bind-info-hash add-game))
175
176 ; Removes a game from the info hash. Makes no remote changes; if the
177 ; user were to add the game using add-game after archiving it, nothing
178 ; would have changed.
179 (define/contract (archive-game info-hash id game-id)
180 (->i
181 ([info-hash (id game-id)
182 (and/c info-hash?
183 (flat-named-contract
184 "info-hash that contains the provided identity"
185 (λ (h) (hash-has-key? h id)))
186 (flat-named-contract
187 "info-hash that contains the provided game"
188 (λ (h) (hash-has-key? (lens-view (game-info-lens id) h) game-id))))]
189 [id identity?]
190 [game-id game-id?])
191 [new-hash info-hash?])
192 (info/store
193 (lens-transform (game-info-lens id) info-hash
194 (λ (game-hash) (hash-remove game-hash game-id)))))
195 (define info/archive-game (bind-info-hash archive-game))
00 #lang racket
11
2 (require "store.rkt")
2 (require "info.rkt")
33 (require lens)
44 (require net/url-string)
55 (require racket/block)
0 #lang racket
1
2 (require racket/async-channel)
3 (require "gmlib.rkt")
4
5 (provide create-monitor stop-monitor)
6
7 (define (poll-rate-sec importance)
8 (case importance
9 [(high) 15] [(low) 300] [else (error "bad importance value")]))
10
11 ; importance should be 'high or 'low, and determines the polling rate
12 (define (create-monitor id game-id importance cb)
13 (let ([exit-chan (make-async-channel)]
14 [fetch (λ () (gm/get-game (first id) game-id))])
15 (thread
16 (λ ()
17 (let loop ([old-gs (fetch)])
18 (let ([exit? (sync/timeout (poll-rate-sec importance) exit-chan)])
19 (unless exit?
20 (let ([new-gs (fetch)])
21 (unless (equal? old-gs new-gs)
22 (cb new-gs))
23 (loop new-gs)))))))
24 exit-chan))
25
26 (define (stop-monitor mon)
27 (async-channel-put mon #t))
00 #lang racket/gui
11
22 (require "chesstools.rkt")
3 (require "gamemgr.rkt")
43 (require "gmlib.rkt")
54 (require "gmlens.rkt")
65 (require "guiutil.rkt")
76 (require "icons.rkt")
7 (require "monitor.rkt")
8 (require "pgnview.rkt")
89 (require lens)
910 (require racket/block)
1011
3839 (define outer-border 10)
3940 (define/override (place-children info w h)
4041 (let* ([s (min w h)]
41 [bs (floor ((- s (* 2 outer-border)) . / . 8))])
42 (map-rf (λ (r f) (list (+ outer-border (* f bs)) (+ outer-border (* (- 7 r) bs)) bs bs)))
42 [bs (floor (s . / . 8))])
43 (map-rf (λ (r f) (list (* f bs) (* (- 7 r) bs) bs bs)))
4344 ))
4445
4546 (define/public (update-game-state gs)
138139 )))
139140 ))
140141
142 (define status-pane%
143 (class canvas%
144 (init-field msg)
145 (inherit get-dc get-height get-width refresh)
146 (super-new [min-height 32])
147 (define/public (set-msg m)
148 (set-field! msg this m) (refresh))
149 (define/override (get-graphical-min-size) (values 200 30))
150 (define/override (on-paint)
151 (let ([dc (get-dc)])
152 (send dc set-font (make-object font% 12 'default))
153 (send dc set-smoothing 'aligned)
154 (send dc set-brush "black" 'solid)
155 (send dc set-pen "black" 1 'transparent)
156 (send dc draw-rectangle 0 0 (get-width) (+ 5 (get-height)))
157 (send dc set-text-foreground "white")
158 (send dc set-text-mode 'transparent)
159 (send dc draw-text msg 5 5)))))
160
141161 (define confirm-move-dialog%
142162 (class dialog%
143163 (init-field cbc from to root)
180200 (define/augment (on-close)
181201 (stop-monitor monitor))
182202
183 (define outer-layout (new square-side-pane% [parent this]))
203 (define outer-layout (new vertical-pane% [parent this] [alignment '(center bottom)]))
204 (define lr-layout (new square-side-pane%
205 [parent outer-layout] [horiz-margin 10] [vert-margin 10]))
184206
185207 ; it takes a while to load the game state, so we load it once while we're
186208 ; initializing the frame. This should never be used after the frame is
189211
190212 (define player-color
191213 (cond
192 [(equal? (second id) (lens-view g-player-white-lens game-state-on-init)) 'w]
193 [(equal? (second id) (lens-view g-player-black-lens game-state-on-init)) 'b]
214 [(equal? (second id) (g-player-white game-state-on-init)) 'w]
215 [(equal? (second id) (g-player-black game-state-on-init)) 'b]
194216 [#t (error "given ID is neither white nor black player")]))
195217
196218 (define cbc
199221 [game-state game-state-on-init]
200222 [player-color player-color]
201223 [game-frame this]
202 [parent outer-layout])))
224 [parent lr-layout])))
203225 (map-rf (λ (r f) (new chess-board-square% [rf (cons r f)] [parent cbc])))
204226
205 (define right-layout (new vertical-panel% [parent outer-layout] [alignment '(right top)]))
206 (new button% [parent right-layout] [label "Hello"] [callback (λ (a b) (println b))])
227 (define right-layout (new vertical-panel% [parent lr-layout] [alignment '(right top)]))
228 (define pgn (new pgn-view% [parent right-layout]))
229 (send pgn set-pgn (g-pgn game-state-on-init))
230
231 (define (get-status-msg state)
232 (format "You are ~a, ~a"
233 (if (equal? player-color 'w) "white" "black")
234 (if (equal? player-color (g-to-move state))
235 "your move"
236 (if (equal? player-color 'w) "black to move" "white to move"))))
237
238 (define status-msg
239 (new status-pane%
240 [parent outer-layout] [stretchable-height #f] [stretchable-width #t]
241 [msg (get-status-msg game-state-on-init)]))
207242
208243 (define/public (set-game-state state)
209 (send cbc update-game-state state))
244 (send cbc update-game-state state)
245 (send pgn set-pgn (g-pgn state))
246 (send status-msg set-msg (get-status-msg state)))
210247
211248 (define/public (send-move alg-move)
212249 (gm/make-move (first id) game-id (second id) alg-move)
+0
-196
frontend/store.rkt less more
0 #lang racket
1
2 (require basedir)
3 (require lens)
4 (require racket/block)
5 (require racket/random)
6
7 (require "lensutil.rkt")
8 (require "gmlib.rkt")
9
10 (define version-no 2)
11
12 (provide
13 info/add-existing-player
14 info/add-game
15 info/add-identity
16 info/archive-game
17 info/load
18 info/store
19 info/invite-new-player
20 info/new-game
21
22 game-info-lens
23 player-info-lens
24 )
25
26 (current-basedir-program-name "grandmaster")
27 (unless (directory-exists? (writable-data-dir))
28 (make-directory (writable-data-dir)))
29 (define prefs-file (writable-data-file "prefs.lisp"))
30
31 (define host? string?)
32 (define player-id? positive-integer?)
33 (define game-id? positive-integer?)
34
35 ; identity tuples are pairs of host addr and player ID
36 (define identity? (list/c host? player-id?))
37
38 ; player-info tuples are pairs of player-id and nickname
39 (define player-info? (list/c player-id? string?))
40
41 ; game-info tuples are triples of game-id, white-player-id and black-player-id.
42 (define game-info? (list/c game-id? player-id? player-id?))
43
44 ; server-info tuples are triples of identity, known-games and known-players
45 (define server-info? (list/c (hash/c game-id? game-info?) (hash/c player-id? player-info?)))
46
47 ; the info hash is the root structure that holds all the information we're
48 ; interested in
49 (define info-hash? (and/c (hash/c identity? server-info?) immutable?))
50
51 (define (upgrade-info version info-hash)
52 (if (equal? version version-no) info-hash
53 (case version
54 [else (error "no version handler for version" version)]
55 )))
56
57 (define (info/load-raw)
58 (let-values
59 ([(err r)
60 (call-with-input-file prefs-file
61 (λ (f) (with-handlers
62 ([exn:fail? (λ (v) (values "data file is corrupt" null))])
63 (values null (read f)))))])
64 ; we can't throw the error inside the call-with-input-file lambda, because
65 ; call-with-input-file doesn't close the file if an exception is raised
66 (if (null? err) r (error err))))
67
68 (define/contract (info/load)
69 (-> info-hash?)
70 (let ([r (info/load-raw)])
71 (upgrade-info (cdar r) (cdr r))))
72
73 (define/contract (info/new)
74 (-> info-hash?)
75 (make-immutable-hash))
76
77 (define/contract (info/store p)
78 (-> info-hash? void)
79 (block
80 (call-with-output-file prefs-file
81 (λ (f) (write (cons (cons 'version version-no) p) f))
82 #:exists 'replace)
83 p))
84
85 (define (bind-info-hash func)
86 (λ args (apply func (info/load) args)))
87
88 (define/contract (add-identity info-hash new-identity)
89 (-> info-hash? identity? info-hash?)
90 (info/store
91 (if (hash-has-key? info-hash new-identity)
92 info-hash
93 (hash-set info-hash
94 new-identity
95 (list (make-immutable-hash) (make-immutable-hash))))))
96 (define info/add-identity (bind-info-hash add-identity))
97
98 (define (game-info-lens id)
99 (lens-compose first-lens (hash-ref-lens id)))
100 (define (player-info-lens id)
101 (lens-compose second-lens (hash-ref-lens id)))
102
103 ; adds an existing player to the identity's known users map. no remote changes.
104 (define/contract (add-existing-player info-hash id player)
105 (-> info-hash? identity? player-info? info-hash?)
106 (info/store
107 (lens-set (lens-compose (hash-ref-lens (first player))
108 (player-info-lens id))
109 info-hash
110 player)))
111 (define info/add-existing-player (bind-info-hash add-existing-player))
112
113 ; creates a new player and adds them to thte known users map. creates an
114 ; invitation on the remote.
115 (define/contract (invite-new-player info-hash id nickname)
116 (-> info-hash? identity? string? (values info-hash? player-id?))
117 (let ([new-id (arithmetic-shift
118 (integer-bytes->integer (crypto-random-bytes 8) #f) -1)])
119 (block
120 (gm/new-user (first id) (second id) new-id)
121 (values (add-existing-player info-hash id (list new-id nickname))
122 new-id))))
123 (define info/invite-new-player (bind-info-hash invite-new-player))
124
125 ; creates a new game. calls gm/new-game and gm/get-game.
126 (define/contract (new-game info-hash id other-player self-color)
127 (->i
128 ([info-hash (id other-player)
129 (and/c info-hash?
130 (flat-named-contract
131 "info-hash that contains the provided identity"
132 (λ (h) (hash-has-key? h id)))
133 (flat-named-contract
134 "info-hash that contains the other player"
135 (λ (h) (hash-has-key?
136 (lens-view (player-info-lens id) h)
137 other-player))))]
138 [id identity?]
139 [other-player player-id?]
140 [self-color (one-of/c 'w 'b)])
141 (values [new-hash info-hash?] [new-game-id game-id?] [game-state g?]))
142 (let* ([w (if (equal? self-color 'w) (second id) other-player)]
143 [b (if (equal? self-color 'b) (second id) other-player)]
144 [new-game (gm/new-game (first id) #:white w #:black b)])
145 (let-values ([(new-hash game-state) (add-game info-hash id (g-id new-game))])
146 (values
147 new-hash
148 (g-id new-game)
149 game-state))))
150 (define info/new-game (bind-info-hash new-game))
151
152 ; Adds an existing game to the game map. Calls gm/get-game to figure out
153 ; the ID of the other player in the game.
154 (define/contract (add-game info-hash id game-id)
155 (->i
156 ([info-hash (id game-id)
157 (and/c info-hash?
158 (flat-named-contract
159 "info-hash that contains the provided identity"
160 (λ (h) (hash-has-key? h id)))
161 (flat-named-contract
162 "game does not already exist in info hash"
163 (λ (h) (not (hash-has-key? (lens-view (game-info-lens id) h) game-id)))))]
164 [id identity?]
165 [game-id game-id?])
166 (values [new-hash info-hash?] [game-state g?]))
167 (let ([g (gm/get-game (first id) game-id)])
168 (values
169 (info/store
170 (lens-set (lens-compose (hash-ref-lens game-id) (game-info-lens id))
171 info-hash
172 (list game-id (g-player-white g) (g-player-black g))))
173 g)))
174 (define info/add-game (bind-info-hash add-game))
175
176 ; Removes a game from the info hash. Makes no remote changes; if the
177 ; user were to add the game using add-game after archiving it, nothing
178 ; would have changed.
179 (define/contract (archive-game info-hash id game-id)
180 (->i
181 ([info-hash (id game-id)
182 (and/c info-hash?
183 (flat-named-contract
184 "info-hash that contains the provided identity"
185 (λ (h) (hash-has-key? h id)))
186 (flat-named-contract
187 "info-hash that contains the provided game"
188 (λ (h) (hash-has-key? (lens-view (game-info-lens id) h) game-id))))]
189 [id identity?]
190 [game-id game-id?])
191 [new-hash info-hash?])
192 (info/store
193 (lens-transform (game-info-lens id) info-hash
194 (λ (game-hash) (hash-remove game-hash game-id)))))
195 (define info/archive-game (bind-info-hash archive-game))