git.haldean.org grandmaster / 8436d59
set-active different from set-pgn Haldean Brown 8 months ago
2 changed file(s) with 53 addition(s) and 13 deletion(s). Raw diff Collapse all Expand all
55 (map (compose string-split string-trim)
66 (string-split pgn #rx"[0-9]+\\.")))
77
8 (define base-style-delta (new style-delta%))
9 (send base-style-delta set-family 'modern)
10 (send base-style-delta set-size-add 2)
11 (define onclick-style (send (new style-delta%) set-delta-foreground "blue"))
12 (define ply-style (send (new style-delta%) set-delta-background
13 (make-object color% 255 255 255)))
14 (define active-ply-style (make-object style-delta% 'change-weight 'bold))
815
9 (define (pgn-build-text pgn-bits)
16 (define (pgn-build-text pgn-bits click-cb)
17 (define t (new text%))
18 (define base-style (send (send t get-style-list) find-named-style (send t default-style-name)))
19 (send base-style set-delta base-style-delta)
20
1021 (define (pgn-build-ply txt ply-i ply-txt)
1122 (define start (send txt last-position))
1223 (send txt insert (format "~a" ply-txt))
13 (send txt set-clickback start (send txt last-position)
14 (λ (t s e) (println ply-i) (println ply-txt))
15 (send (new style-delta%) set-delta-background
16 (make-object color% 200 200 200))))
24 (define end (send txt last-position))
25 (send txt set-clickback start end (λ (t s e) (click-cb ply-i)) onclick-style)
26 (send txt change-style ply-style start end)
27 (send txt change-style #f end end)
28 (list start end)
29 )
1730
18 (define (pgn-build-line line i txt)
31 (define (pgn-build-line line i txt-accum)
32 (define txt (first txt-accum))
1933 (send txt insert (format "~a." i))
20 (pgn-build-ply txt (- (* 2 i) 1) (first line))
34 (define lst (cons (pgn-build-ply txt (- (* 2 i) 1) (first line)) (second txt-accum)))
2135 (send txt insert " ")
2236 (when (> (length line) 1)
23 (pgn-build-ply txt (* 2 i) (second line)))
37 (set! lst (cons (pgn-build-ply txt (* 2 i) (second line)) lst)))
2438 (send txt insert "\n")
25 txt)
26 (foldl pgn-build-line (new text%) pgn-bits (range 1 (+ 1 (length pgn-bits)))))
39 (list txt lst))
40
41 (let ([txt-accum
42 (foldl pgn-build-line (list t '()) pgn-bits (range 1 (+ 1 (length pgn-bits))))])
43 (values (first txt-accum) (reverse (second txt-accum)))))
2744
2845 (define pgn-view%
2946 (class editor-canvas%
47 (init-field click-cb [ply-directory '()] [last-active '()])
48 (inherit get-editor set-editor)
3049 (super-new [style '(no-border no-hscroll auto-vscroll no-focus transparent)]
3150 [horizontal-inset 10]
3251 [stretchable-height #t] [stretchable-width #t])
3352
3453 (define/public (set-pgn pgn)
35 (send this set-editor (pgn-build-text (pgn-parse-bits pgn))))
54 (let* ([b (pgn-parse-bits pgn)])
55 (let-values ([(txt directory) (pgn-build-text b click-cb)])
56 (set-editor txt)
57 (set-field! ply-directory this directory))))
58
59 (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))])))
3669 ))
3770
3871 (define (main)
3972 (define f (new frame% [label "pgnview test"] [width 250] [height 600]))
40 (define pgn (new pgn-view% [parent f]))
73 (define pgn (new pgn-view% [parent f] [click-cb (λ (ply-idx) (send pgn set-active ply-idx))]))
4174 (send pgn set-pgn "1. e4 d6 2. d4 Nf6 3. Nc3 g6 4. Be3 Bg7 5. Qd2 c6 6. f3 b5
4275 7. Nge2 Nbd7 8. Bh6 Bxh6 9. Qxh6 Bb7 10. a3 e5 11. O-O-O Qe7
4376 12. Kb1 a6 13. Nc1 O-O-O 14. Nb3 exd4 15. Rxd4 c5 16. Rd1 Nb6
4780 Qc4 31. Qxf6 Kxa3 32. Qxa6+ Kxb4 33. c3+ Kxc3 34. Qa1+ Kd2
4881 35. Qb2+ Kd1 36. Bf1 Rd2 37. Rd7 Rxd7 38. Bxc4 bxc4 39. Qxh8
4982 Rd3 40. Qa8 c3 41. Qa4+ Ke1 42. f4 f5 43. Kc1 Rd2 44. Qa7")
83 (send pgn set-active #f)
5084 (send f show #t)
5185 pgn)
200200 (define/augment (on-close)
201201 (stop-monitor monitor))
202202
203 (define (rewind-to-ply ply-i)
204 (send pgn set-active ply-i)
205 (println ply-i))
206
203207 (define outer-layout (new vertical-pane% [parent this] [alignment '(center bottom)]))
204208 (define lr-layout (new square-side-pane%
205209 [parent outer-layout] [horiz-margin 10] [vert-margin 10]))
225229 (map-rf (λ (r f) (new chess-board-square% [rf (cons r f)] [parent cbc])))
226230
227231 (define right-layout (new vertical-panel% [parent lr-layout] [alignment '(right top)]))
228 (define pgn (new pgn-view% [parent right-layout]))
232 (define pgn (new pgn-view%
233 [parent right-layout] [click-cb (λ (ply-i) (rewind-to-ply ply-i))]))
229234 (send pgn set-pgn (g-pgn game-state-on-init))
230235
231236 (define (get-status-msg state)
243248 (define/public (set-game-state state)
244249 (send cbc update-game-state state)
245250 (send pgn set-pgn (g-pgn state))
251 (send pgn set-active #f)
246252 (send status-msg set-msg (get-status-msg state)))
247253
248254 (define/public (send-move alg-move)