git.haldean.org grandmaster / c3e8535
resignation logic in frontend, invite code copy Haldean Brown 1 year, 5 months ago
5 changed file(s) with 128 addition(s) and 75 deletion(s). Raw diff Collapse all Expand all
+1
-7
frontend/gamelist.rkt less more
2424 (load-from-info)
2525 ))
2626
27 (define (player-name player-hash my-identity pid)
28 (if (equal? pid (second my-identity))
29 "You"
30 (if (hash-has-key? player-hash pid)
31 (second (hash-ref player-hash pid))
32 "Unknown player")))
3327 (define (player-name-func player-hash my-identity)
34 (λ (pid) (player-name player-hash my-identity pid)))
28 (λ (pid) (info/player-name player-hash (second my-identity) pid)))
3529
3630 (define game-browser%
3731 (class listener-list-box%
+26
-2
frontend/guiutil.rkt less more
00 #lang racket/gui
11
22 (provide
3 confirm
34 listener-list-box%
45 prompt
56 show-error-dialog
5051 (define d (new dialog% [label "Error"]))
5152 (define vp (new vertical-pane%
5253 [parent d] [horiz-margin 8] [vert-margin 3] [alignment '(right top)]))
53 (new message% [parent vp] [vert-margin 4] [label err-msg] [min-height 16])
54 (new message% [parent vp] [vert-margin 4] [label err-msg] [min-height 16] [min-width 250])
5455 (new button% [label "OK"] [parent vp] [vert-margin 2]
5556 [callback (λ (x ev) (send d show #f))])
5657 (send d show #t))
5960 (define d (new dialog% [label "Success"]))
6061 (define vp (new vertical-pane%
6162 [parent d] [horiz-margin 8] [vert-margin 3] [alignment '(right top)]))
62 (new message% [parent vp] [vert-margin 4] [label msg] [min-height 16])
63 (new message% [parent vp] [vert-margin 4] [label msg] [min-height 16] [min-width 250])
6364 (new button% [label "OK"] [parent vp] [vert-margin 2]
6465 [callback (λ (x ev) (send d show #f))])
6566 (send d show #t))
7778 [callback (λ (x ev)
7879 (send d show #f)
7980 (callback (send tf get-value)))])
81 (send d show #t))
82
83 (define cancel-callback-dialog%
84 (class dialog%
85 (init-field close-cb)
86 (super-new)
87 (define/augment (on-close) (close-cb))))
88
89 (define (confirm #:title title #:prompt prompt #:action-name action-name #:callback callback)
90 (define d (new cancel-callback-dialog% [label title] [close-cb (λ () (callback #f))]))
91 (let* ([vp (new vertical-pane% [parent d] [alignment '(left top)])])
92 (new message%
93 [parent vp]
94 [label prompt]
95 [min-width 250] [min-height 16] [horiz-margin 6] [vert-margin 4])
96 (let ([hp (new horizontal-pane% [parent vp] [alignment '(right center)])]
97 [hm 4] [vm 6])
98 (new button% [parent hp] [label "Cancel"] [horiz-margin hm] [vert-margin vm]
99 [callback (λ (x ev) (send d show #f) (callback #f))])
100 (new button% [parent hp] [label action-name] [horiz-margin hm] [vert-margin vm]
101 [callback (λ (x ev) (send d show #f) (callback #t))])
102 (when (system-position-ok-before-cancel?)
103 (send hp change-children reverse))))
80104 (send d show #t))⏎
+18
-1
frontend/info.rkt less more
1818 info/store
1919 info/invite-new-player
2020 info/new-game
21 info/player-name
2122
2223 game-info-lens
2324 player-info-lens
192193 (info/store
193194 (lens-transform (game-info-lens id) info-hash
194195 (λ (game-hash) (hash-remove game-hash game-id)))))
195 (define info/archive-game (bind-info-hash archive-game))⏎
196 (define info/archive-game (bind-info-hash archive-game))
197
198 ; Takes either:
199 ; - an identity and a player ID and finds the name of that player
200 ; - a player info hash, the player ID of the "me" player, and the
201 ; player ID to look up
202 ; If the player ID is not in the given identity's user map, returns
203 ; the string "Unknown player". If the player ID is the same as the
204 ; player ID in the identity, returns the string "You"
205 (define info/player-name
206 (case-lambda
207 [(id pid) (info/player-name (lens-view (player-info-lens id) (info/load)) (second id) pid)]
208 [(player-info my-pid pid)
209 (cond
210 [(equal? my-pid pid) "You"]
211 [(hash-has-key? player-info pid) (second (hash-ref player-info pid))]
212 [#t "Unknown player"])]))⏎
+10
-9
frontend/pgnview.rkt less more
5757 (set-field! ply-directory this directory))))
5858
5959 (define/public (set-active active-ply-index)
60 (let ([ed (get-editor)]
61 [idx (if active-ply-index active-ply-index (length ply-directory))])
62 (unless (null? last-active)
63 (send ed change-style #f (first last-active) (second last-active))
64 (send ed change-style ply-style (first last-active) (second last-active)))
65 (match (list-ref ply-directory (- idx 1))
66 [(list start end)
67 (send ed change-style active-ply-style start end)
68 (set-field! last-active this (list start end))])))
60 (unless (null? ply-directory)
61 (let ([ed (get-editor)]
62 [idx (if active-ply-index active-ply-index (length ply-directory))])
63 (unless (null? last-active)
64 (send ed change-style #f (first last-active) (second last-active))
65 (send ed change-style ply-style (first last-active) (second last-active)))
66 (match (list-ref ply-directory (- idx 1))
67 [(list start end)
68 (send ed change-style active-ply-style start end)
69 (set-field! last-active this (list start end))]))))
6970 ))
7071
7172 (define (main)
+73
-56
frontend/render.rkt less more
44 (require "gmlens.rkt")
55 (require "guiutil.rkt")
66 (require "icons.rkt")
7 (require "info.rkt")
8 (require "invite.rkt")
79 (require "monitor.rkt")
810 (require "pgnview.rkt")
911 (require lens)
2426 (send dc draw-rectangle offset offset (- w (* 2 offset)) (- h (* 2 offset))))))
2527 (define (fill-canvas+border dc bg border border-thickness)
2628 (fill-canvas dc border 0) (fill-canvas dc bg border-thickness))
29
30 (define (confirm-move cbc from to root)
31 (define gs (get-field game-state cbc))
32 (define move (algebraic gs from to))
33 (confirm #:title "Send move" #:prompt (format "Send ~a?" move) #:action-name "Send"
34 #:callback (λ (go) (if go (send root send-move move)
35 (send cbc unpropose)))))
2736
2837 (define chess-board-container%
2938 (class panel%
6069 (set-field! proposed-move this (cons selected-rf move-to))
6170 (unselect)
6271 (refresh)
63 (let ([d (new confirm-move-dialog%
64 [root game-frame] [cbc this]
65 [from (car proposed-move)] [to (cdr proposed-move)])])
66 (send d show #t)))
72 (confirm-move this (car proposed-move) (cdr proposed-move) game-frame))
6773
6874 (define/public (selected? rf)
6975 (and (not (null? selected-rf)) (equal? selected-rf rf)))
158164 (send dc set-text-mode 'transparent)
159165 (send dc draw-text msg 5 5)))))
160166
161 (define confirm-move-dialog%
162 (class dialog%
163 (init-field cbc from to root)
164 (define gs (get-field game-state cbc))
165 (define move (algebraic gs from to))
166
167 (inherit show)
168 (super-new [label "Send move"])
169
170 (let* ([vp (new vertical-pane% [parent this] [alignment '(left top)])])
171 (new message%
172 [parent vp]
173 [label (format "Send ~a?" move)]
174 [min-width 200] [min-height 16] [horiz-margin 6] [vert-margin 4])
175 (let ([hp (new horizontal-pane% [parent vp] [alignment '(right center)])]
176 [hm 4] [vm 6])
177 (new button% [parent hp] [label "Cancel"] [horiz-margin hm] [vert-margin vm]
178 [callback (λ (x ev) (abort) (show #f))])
179 (new button% [parent hp] [label "Send"] [horiz-margin hm] [vert-margin vm]
180 [callback (λ (x ev) (show #f) (send-move))])
181 (when (system-position-ok-before-cancel?)
182 (send hp change-children reverse))))
183
184 (define (send-move)
185 (send root send-move move))
186 (define (abort) (send cbc unpropose))
187 (define/augment (on-close) (abort))
188 ))
189
190167 (define game-frame%
191168 (class frame%
192169 (init-field id game-id)
193 (super-new [label "Grandmaster"] [width 800] [height 600])
194
170
195171 (define (load-game-state)
196 (gm/get-game (first id) game-id))
197
198 (define monitor
199 (create-monitor id game-id 'high (λ (gs) (send this set-game-state gs))))
200 (define/augment (on-close)
201 (stop-monitor monitor))
202
203 (define (rewind-to-ply ply-i)
204 (send pgn set-active ply-i)
205 (println ply-i))
206
207 (define outer-layout (new vertical-pane% [parent this] [alignment '(center bottom)]))
208 (define lr-layout (new square-side-pane%
209 [parent outer-layout] [horiz-margin 10] [vert-margin 10]))
210
172 (with-handlers ([exn:fail? (λ (e) (show-error-dialog "Couldn't load game from server"))])
173 (gm/get-game (first id) game-id)))
174
211175 ; it takes a while to load the game state, so we load it once while we're
212176 ; initializing the frame. This should never be used after the frame is
213177 ; initialized.
218182 [(equal? (second id) (g-player-white game-state-on-init)) 'w]
219183 [(equal? (second id) (g-player-black game-state-on-init)) 'b]
220184 [#t (error "given ID is neither white nor black player")]))
221
185 (define other-player
186 ((if (equal? player-color 'w) g-player-black g-player-white) game-state-on-init))
187 (define other-player-name (info/player-name id other-player))
188
189 (super-new [label (format "Game against ~a : Grandmaster" other-player-name)]
190 [width 800] [height 600])
191
192 (define monitor
193 (create-monitor id game-id 'high (λ (gs) (send this set-game-state gs))))
194 (define/augment (on-close)
195 (stop-monitor monitor))
196
197 (define (rewind-to-ply ply-i)
198 (send pgn set-active ply-i)
199 (println ply-i))
200
201 (define outer-layout (new vertical-pane% [parent this] [alignment '(center bottom)]))
202 (define lr-layout (new square-side-pane%
203 [parent outer-layout] [horiz-margin 10] [vert-margin 10]))
204
222205 (define cbc
223206 (let ([gs (load-game-state)])
224207 (new chess-board-container%
232215 (define pgn (new pgn-view%
233216 [parent right-layout] [click-cb (λ (ply-i) (rewind-to-ply ply-i))]))
234217 (send pgn set-pgn (g-pgn game-state-on-init))
218 (send pgn set-active #f)
219
220 (define resign-button
221 (new button% [parent right-layout] [label "Resign"]
222 [enabled (equal? 'available-move (g-termination game-state-on-init))]
223 [callback
224 (λ (x ev)
225 (confirm #:title "Resign"
226 #:prompt "Do you want to resign from this game?"
227 #:action-name "Resign"
228 #:callback (λ (go)
229 (when go
230 (gm/end-game
231 (first id) game-id (second id)
232 (if (equal? player-color 'w)
233 'resignation-white
234 'resignation-black))))))]))
235
236 (new button% [parent right-layout] [label "Copy invite code"]
237 [callback (λ (x ev)
238 (send the-clipboard set-clipboard-string
239 (invite-game (first id) other-player game-id) 0))])
235240
236241 (define (get-status-msg state)
237 (format "You are ~a, ~a"
238 (if (equal? player-color 'w) "white" "black")
239 (if (equal? player-color (g-to-move state))
240 "your move"
241 (if (equal? player-color 'w) "black to move" "white to move"))))
242 (define (win-msg winner)
243 (if (equal? winner (second id)) "You win!"
244 (format "~a wins." (info/player-name id winner))))
245 (case (g-termination state)
246 [(available-move)
247 (format "You are ~a, ~a"
248 (if (equal? player-color 'w) "white" "black")
249 (if (equal? player-color (g-to-move state))
250 "your move"
251 (if (equal? player-color 'w) "black to move" "white to move")))]
252 [(victory-white resignation-black) (win-msg (g-player-white state))]
253 [(victory-black resignation-white) (win-msg (g-player-black state))]
254 [(stalemate) "Stalemate."]
255 [(taken-draw-white) "White takes the draw."]
256 [(taken-draw-black) "Black takes the draw."]
257 ))
242258
243259 (define status-msg
244260 (new status-pane%
249265 (send cbc update-game-state state)
250266 (send pgn set-pgn (g-pgn state))
251267 (send pgn set-active #f)
268 (send resign-button enable (equal? 'available-move (g-termination state)))
252269 (send status-msg set-msg (get-status-msg state)))
253270
254271 (define/public (send-move alg-move)