4 | 4 |
(require "gmlens.rkt")
|
5 | 5 |
(require "guiutil.rkt")
|
6 | 6 |
(require "icons.rkt")
|
|
7 |
(require "info.rkt")
|
|
8 |
(require "invite.rkt")
|
7 | 9 |
(require "monitor.rkt")
|
8 | 10 |
(require "pgnview.rkt")
|
9 | 11 |
(require lens)
|
|
24 | 26 |
(send dc draw-rectangle offset offset (- w (* 2 offset)) (- h (* 2 offset))))))
|
25 | 27 |
(define (fill-canvas+border dc bg border border-thickness)
|
26 | 28 |
(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)))))
|
27 | 36 |
|
28 | 37 |
(define chess-board-container%
|
29 | 38 |
(class panel%
|
|
60 | 69 |
(set-field! proposed-move this (cons selected-rf move-to))
|
61 | 70 |
(unselect)
|
62 | 71 |
(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))
|
67 | 73 |
|
68 | 74 |
(define/public (selected? rf)
|
69 | 75 |
(and (not (null? selected-rf)) (equal? selected-rf rf)))
|
|
158 | 164 |
(send dc set-text-mode 'transparent)
|
159 | 165 |
(send dc draw-text msg 5 5)))))
|
160 | 166 |
|
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 | |
|
190 | 167 |
(define game-frame%
|
191 | 168 |
(class frame%
|
192 | 169 |
(init-field id game-id)
|
193 | |
(super-new [label "Grandmaster"] [width 800] [height 600])
|
194 | |
|
|
170 |
|
195 | 171 |
(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 |
|
211 | 175 |
; it takes a while to load the game state, so we load it once while we're
|
212 | 176 |
; initializing the frame. This should never be used after the frame is
|
213 | 177 |
; initialized.
|
|
218 | 182 |
[(equal? (second id) (g-player-white game-state-on-init)) 'w]
|
219 | 183 |
[(equal? (second id) (g-player-black game-state-on-init)) 'b]
|
220 | 184 |
[#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 |
|
222 | 205 |
(define cbc
|
223 | 206 |
(let ([gs (load-game-state)])
|
224 | 207 |
(new chess-board-container%
|
|
232 | 215 |
(define pgn (new pgn-view%
|
233 | 216 |
[parent right-layout] [click-cb (λ (ply-i) (rewind-to-ply ply-i))]))
|
234 | 217 |
(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))])
|
235 | 240 |
|
236 | 241 |
(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 |
))
|
242 | 258 |
|
243 | 259 |
(define status-msg
|
244 | 260 |
(new status-pane%
|
|
249 | 265 |
(send cbc update-game-state state)
|
250 | 266 |
(send pgn set-pgn (g-pgn state))
|
251 | 267 |
(send pgn set-active #f)
|
|
268 |
(send resign-button enable (equal? 'available-move (g-termination state)))
|
252 | 269 |
(send status-msg set-msg (get-status-msg state)))
|
253 | 270 |
|
254 | 271 |
(define/public (send-move alg-move)
|