git.haldean.org grandmaster / master
UI work to display game history Haldean Brown a month ago
4 changed file(s) with 51 addition(s) and 19 deletion(s). Raw diff Collapse all Expand all
33 (require "gmlib.rkt")
44
55 (provide
6 access-lens piece-lens
6 access-lens piece-lens piece-blens
77 g-board-lens g-access-lens g-board-lens g-castles-lens g-check-lens g-draws-lens
88 g-fen-lens g-id-lens g-passant-file-lens g-pgn-lens g-player-black-lens
99 g-player-white-lens g-ply-lens g-termination-lens g-to-move-lens)
1010
1111 (define-struct-lenses g)
12
13 ; Accesses the rank and file in a board map
14 (define (piece-blens rf)
15 (lens-compose (list-ref-lens (cdr rf)) (list-ref-lens (car rf))))
16
17 ; Accesses the rank and file in the current state of a game
1218 (define (piece-lens rf)
13 (lens-compose (list-ref-lens (cdr rf)) (list-ref-lens (car rf)) g-board-lens))
19 (lens-compose (piece-blens rf) g-board-lens))
20
1421 (define (access-lens rf)
15 (lens-compose (list-ref-lens (cdr rf)) (list-ref-lens (car rf)) g-access-lens))
22 (lens-compose (list-ref-lens (cdr rf)) (list-ref-lens (car rf)) g-access-lens))
44 (require racket/tcp)
55
66 (provide gm/new-user gm/new-game gm/make-move gm/end-game gm/get-game
7 g g-access g-board g-castles g-check g-draws g-fen g-id g-passant-file
7 g g-access g-board g-castles g-check g-draws g-fen g-history g-id g-passant-file
88 g-pgn g-player-black g-player-white g-ply g-termination g-to-move g?)
99
1010 (define (load-bit-set c fields)
5757 (check (state board in_check) ,identity)
5858 (draws (state board draws) ,load-draws)
5959 (fen (state board fen) ,identity)
60 (history (state history) ,(λ (hs) (map load-board (reverse hs))))
6061 (id (game_id) ,identity)
6162 (passant-file (state board passant_file) ,(λ (pf) (if (pf . < . 0) #f pf)))
6263 (pgn (state board pgn) ,identity)
6869 ))
6970
7071 (struct g
71 (access board castles check draws fen id passant-file pgn
72 (access board castles check draws fen history id passant-file pgn
7273 player-black player-white ply termination to-move)
7374 #:transparent)
7475
3131 (define (pgn-build-line line i txt-accum)
3232 (define txt (first txt-accum))
3333 (send txt insert (format "~a." i))
34 (define lst (cons (pgn-build-ply txt (- (* 2 i) 1) (first line)) (second txt-accum)))
34 (define lst (cons (pgn-build-ply txt (* 2 i) (first line)) (second txt-accum)))
3535 (send txt insert " ")
3636 (when (> (length line) 1)
37 (set! lst (cons (pgn-build-ply txt (* 2 i) (second line)) lst)))
37 (set! lst (cons (pgn-build-ply txt (+ (* 2 i) 1) (second line)) lst)))
3838 (send txt insert "\n")
3939 (list txt lst))
4040
4141 (let ([txt-accum
42 (foldl pgn-build-line (list t '()) pgn-bits (range 1 (+ 1 (length pgn-bits))))])
42 (foldl pgn-build-line (list t '()) pgn-bits (range 0 (length pgn-bits)))])
4343 (values (first txt-accum) (reverse (second txt-accum)))))
4444
4545 (define pgn-view%
5959 (define/public (set-active active-ply-index)
6060 (unless (null? ply-directory)
6161 (let ([ed (get-editor)]
62 [idx (if active-ply-index active-ply-index (length ply-directory))])
62 [idx (if active-ply-index active-ply-index (- (length ply-directory) 1))])
6363 (unless (null? last-active)
6464 (send ed change-style #f (first last-active) (second last-active))
6565 (send ed change-style ply-style (first last-active) (second last-active)))
66 (match (list-ref ply-directory (- idx 1))
66 (match (list-ref ply-directory idx)
6767 [(list start end)
6868 (send ed change-style active-ply-style start end)
6969 (set-field! last-active this (list start end))]))))
3939 (init-field game-state
4040 player-color
4141 game-frame
42 [current-ply '()]
4243 [selected-rf '()]
4344 [proposed-move '()])
4445 (super-new [stretchable-width #t] [stretchable-height #t])
4546 (inherit get-parent refresh)
47
4648 (define/override (container-size info)
4749 (values (* min-sq-size 8) (* min-sq-size 8)))
4850 (define outer-border 10)
5456
5557 (define/public (update-game-state gs)
5658 (set-field! game-state this gs)
59 (set-field! current-ply this (length (g-history gs)))
5760 (unselect) (unpropose)
5861 (refresh))
5962
63 (define/public (n-plys)
64 (length (g-history game-state)))
65
66 (set-field! current-ply this (- (n-plys) 1))
67
68 (define/public (looking-at-history)
69 (not (equal? current-ply (- (n-plys) 1))))
70
6071 (define/public (select rf)
6172 (when (and (equal? (lens-view g-to-move-lens game-state) player-color)
62 (equal? (car (lens-view (piece-lens rf) game-state)) player-color))
73 (equal? (car (lens-view (piece-lens rf) game-state)) player-color)
74 (not (looking-at-history)))
6375 (set-field! selected-rf this rf)))
6476 (define/public (unselect)
6577 (set-field! selected-rf this '()))
6678 (define/public (unpropose)
6779 (set-field! proposed-move this '()))
6880 (define/public (propose move-to)
69 (set-field! proposed-move this (cons selected-rf move-to))
70 (unselect)
71 (refresh)
72 (confirm-move this (car proposed-move) (cdr proposed-move) game-frame))
81 (unless (looking-at-history)
82 (set-field! proposed-move this (cons selected-rf move-to))
83 (unselect)
84 (refresh)
85 (confirm-move this (car proposed-move) (cdr proposed-move) game-frame)))
86
87 (define/public (set-active ply-i)
88 (unless (equal? ply-i current-ply)
89 (display ply-i)
90 (set-field! current-ply this ply-i)
91 (unselect) (unpropose) (refresh)))
7392
7493 (define/public (selected? rf)
7594 (and (not (null? selected-rf)) (equal? selected-rf rf)))
7695 (define/public (accessible? rf)
7796 (and (not (null? selected-rf))
7897 (member selected-rf (lens-view (access-lens rf) game-state))))
98
99 (define/public (get-board)
100 (if (looking-at-history)
101 (list-ref (g-history game-state) (+ 1 current-ply))
102 (g-board game-state)))
79103 ))
80104
81105 (define chess-board-square%
100124 (define (get-piece)
101125 (let* ([cbc (get-parent)]
102126 [proposed (get-field proposed-move cbc)]
103 [gs (get-field game-state cbc)])
127 [b (send cbc get-board)])
104128 (cond
105129 [(or (null? proposed) (not (or (equal? (car proposed) rf) (equal? (cdr proposed) rf))))
106 (lens-view (piece-lens rf) gs)]
130 (lens-view (piece-blens rf) b)]
107131 [(equal? (car proposed) rf) '()]
108 [(equal? (cdr proposed) rf) (lens-view (piece-lens (car proposed)) gs)])))
132 [(equal? (cdr proposed) rf) (lens-view (piece-blens (car proposed)) b)])))
109133
110134 (define/override (on-event event)
111135 (when (send event button-down? 'left)
196220
197221 (define (rewind-to-ply ply-i)
198222 (send pgn set-active ply-i)
199 (println ply-i))
223 (send cbc set-active ply-i))
200224
201225 (define outer-layout (new vertical-pane% [parent this] [alignment '(center bottom)]))
202226 (define lr-layout (new square-side-pane%