git.haldean.org grandmaster / master
add popup for move send Haldean Brown 11 hours ago
1 changed file(s) with 33 addition(s) and 10 deletion(s). Raw diff Collapse all Expand all
5858 (define cbc-set-selected (class-field-mutator chess-board-container% selected-rf))
5959 (define cbc-get-selected (class-field-accessor chess-board-container% selected-rf))
6060 (define (cbc-select cbc r f)
61 (cbc-set-selected cbc (list r f)))
61 (cbc-set-selected cbc (cons r f)))
6262 (define (cbc-unselect cbc)
6363 (cbc-set-selected cbc '()))
6464
6565 (define (cbc-selected? cbc r f)
6666 (let ([s (cbc-get-selected cbc)])
6767 (if (null? s) #f
68 (and (equal? (first s) r) (equal? (second s) f)))))
68 (and (equal? (car s) r) (equal? (cdr s) f)))))
6969 (define (cbc-accessible? cbc r f)
7070 (let ([s (cbc-get-selected cbc)] [g (cbc-get-game cbc)])
7171 (if (null? s) #f
72 (member (cons (first s) (second s))
73 (lens-view (access-lens r f) g)))))
72 (member s (lens-view (access-lens r f) g)))))
7473
7574 (define chess-board-square%
7675 (class canvas%
8685
8786 (define (selected?) (cbc-selected? (get-parent) rank file))
8887 (define (accessible?) (cbc-accessible? (get-parent) rank file))
88 (define (get-piece) (lens-view (piece-lens rank file) (cbc-get-game (get-parent))))
8989
9090 (define/override (on-event event)
9191 (when (send event button-down? 'left)
92 (if (selected?)
93 (cbc-unselect (get-parent))
94 (cbc-select (get-parent) rank file))
95 (send (get-parent) refresh)))
92 (let ([cbc (get-parent)])
93 (cond
94 ((accessible?) (ask-make-move cbc (cbc-get-selected cbc) (cons rank file)))
95 ((or (selected?) (null? (get-piece))) (cbc-unselect cbc))
96 (#t (cbc-select cbc rank file)))
97 (send cbc refresh))))
9698
9799 (define (piece-margin) (* 0.13 (get-width)))
98100 (define (border-width) (- (piece-margin) 2))
107109
108110 (define/override (on-paint)
109111 (let* ([dc (get-dc)]
110 [game-state (cbc-get-game (get-parent))]
111 [piece (lens-view (piece-lens rank file) game-state)])
112 [piece (get-piece)])
112113 (draw-bg dc piece)
113114 (unless (null? piece)
114115 (let* ([bm (icon/get piece)]
129130 )])
130131 (map-rf (λ (r f) (new chess-board-square% [rank r] [file f] [parent c])))))
131132
133 (define (piece-name p)
134 (case (cdr p)
135 [(p) "pawn"] [(R) "rook"] [(N) "knight"] [(B) "bishop"] [(Q) "queen"] [(K) "king"]))
136 (define (loc-name l)
137 (format "~a~a" (list-ref '(a b c d e f g h) (car l)) (+ 1 (cdr l))))
138 (define (ask-make-move cbc from to)
139 (let* ([d (instantiate dialog% ("Send move"))]
140 [gs (cbc-get-game cbc)]
141 [p (lens-view (piece-lens (car from) (cdr from)) gs)]
142 [vp (new vertical-pane% [parent d])]
143 )
144 (new message%
145 [parent vp]
146 [label (format "Move ~a on ~a to ~a??" (piece-name p) (loc-name from) (loc-name to))]
147 [min-height 16] [horiz-margin 10] [vert-margin 4])
148 (let ([hp (new horizontal-pane% [parent vp] [alignment '(center center)])])
149 (new button% [parent hp] [label "Cancel"] [horiz-margin 4] [vert-margin 4])
150 (new button% [parent hp] [label "Send"] [horiz-margin 4] [vert-margin 4])
151 (when (system-position-ok-before-cancel?)
152 (send hp change-children reverse)))
153 (send d show #t)))
154
132155 (define (main)
133156 (define fr (new frame%
134157 [label "Grandmaster"]