auto updating for board
Haldean Brown
3 years ago
52 | 52 | (map (compose (player-name-func players id) second) games) |
53 | 53 | (map (compose (player-name-func players id) third) games)) |
54 | 54 | ; data stored on each element is a list of (identity game-id) |
55 | (map (λ (i game) (send this set-data i (list id (first game)))) (range (length games)) games) | |
55 | (map (λ (i game) (send this set-data i (list id (first game)))) | |
56 | (range (length games)) games) | |
56 | 57 | ))) |
57 | 58 | |
58 | 59 | (send this attach-doubleclick-listener (λ (id-gid) (open-game))) |
65 | 66 | (define/public (archive-game) |
66 | 67 | (let ([id-gid (get-current)]) |
67 | 68 | (unless (null? id-gid) |
68 | (apply info/archive-game (info/load) id-gid) | |
69 | (apply info/archive-game id-gid) | |
69 | 70 | (load-identity (first id-gid))))) |
70 | 71 | )) |
71 | 72 | |
98 | 99 | (define f (new frame% [label "Grandmaster"] [width 800] [height 800])) |
99 | 100 | (define hp (new horizontal-pane% [parent f])) |
100 | 101 | |
101 | (define left (new vertical-pane% [parent hp] [alignment '(left top)] [horiz-margin 4] [vert-margin 4])) | |
102 | (define left (new vertical-pane% [parent hp] | |
103 | [alignment '(left top)] [horiz-margin 4] [vert-margin 4])) | |
102 | 104 | (new message% [parent left] [label "Servers"]) |
103 | 105 | (define idb (new identity-browser% [parent left])) |
104 | 106 | |
105 | (define right (new vertical-pane% [parent hp] [alignment '(left top)] [horiz-margin 4] [vert-margin 4])) | |
107 | (define right (new vertical-pane% [parent hp] | |
108 | [alignment '(left top)] [horiz-margin 4] [vert-margin 4])) | |
106 | 109 | |
107 | 110 | (new message% [parent right] [label "Games"]) |
108 | 111 | (define gb (new game-browser% [parent right])) |
0 | #lang racket | |
1 | ||
2 | (require racket/async-channel) | |
3 | (require "gmlib.rkt") | |
4 | ||
5 | (provide create-monitor stop-monitor) | |
6 | ||
7 | (define (poll-rate-sec importance) | |
8 | (case importance | |
9 | [(high) 15] [(low) 300] [else (error "bad importance value")])) | |
10 | ||
11 | ; importance should be 'high or 'low, and determines the polling rate | |
12 | (define (create-monitor id game-id importance cb) | |
13 | (let ([exit-chan (make-async-channel)] | |
14 | [fetch (λ () (gm/get-game (first id) game-id))]) | |
15 | (thread | |
16 | (λ () | |
17 | (let loop ([old-gs (fetch)]) | |
18 | (let ([exit? (sync/timeout (poll-rate-sec importance) exit-chan)]) | |
19 | (unless exit? | |
20 | (let ([new-gs (fetch)]) | |
21 | (unless (equal? old-gs new-gs) | |
22 | (cb new-gs)) | |
23 | (loop new-gs))))))) | |
24 | exit-chan)) | |
25 | ||
26 | (define (stop-monitor mon) | |
27 | (async-channel-put mon #t))⏎ |
14 | 14 | #:prompt "Opponent's name" |
15 | 15 | #:action-name "Add" |
16 | 16 | #:callback (λ (name) |
17 | (info/add-existing-player (info/load) id (list new-uid name)) | |
17 | (info/add-existing-player id (list new-uid name)) | |
18 | 18 | (action-after)))) |
5 | 5 | |
6 | 6 | (provide gm/new-user gm/new-game gm/make-move gm/end-game gm/get-game |
7 | 7 | g g-access g-board g-castles g-check g-draws g-fen g-id g-passant-file |
8 | g-pgn g-player-black g-player-white g-ply g-termination g?) | |
8 | g-pgn g-player-black g-player-white g-ply g-termination g-to-move g?) | |
9 | 9 | |
10 | 10 | (define (load-bit-set c fields) |
11 | 11 | (list->set |
50 | 50 | (define d (new dialog% [label "Error"])) |
51 | 51 | (define vp (new vertical-pane% |
52 | 52 | [parent d] [horiz-margin 8] [vert-margin 3] [alignment '(right top)])) |
53 | (new message% [parent vp] [vert-margin 4] [label err-msg]) | |
53 | (new message% [parent vp] [vert-margin 4] [label err-msg] [min-height 16]) | |
54 | 54 | (new button% [label "OK"] [parent vp] [vert-margin 2] |
55 | 55 | [callback (λ (x ev) (send d show #f))]) |
56 | 56 | (send d show #t)) |
59 | 59 | (define d (new dialog% [label "Success"])) |
60 | 60 | (define vp (new vertical-pane% |
61 | 61 | [parent d] [horiz-margin 8] [vert-margin 3] [alignment '(right top)])) |
62 | (new message% [parent vp] [vert-margin 4] [label msg]) | |
62 | (new message% [parent vp] [vert-margin 4] [label msg] [min-height 16]) | |
63 | 63 | (new button% [label "OK"] [parent vp] [vert-margin 2] |
64 | 64 | [callback (λ (x ev) (send d show #f))]) |
65 | 65 | (send d show #t)) |
66 | 66 | |
67 | (define (prompt #:title title #:prompt prompt #:action-name action #:callback callback #:explain [explain #f]) | |
67 | (define (prompt #:title title #:prompt prompt #:action-name action | |
68 | #:callback callback #:explain [explain #f]) | |
68 | 69 | (define d (new dialog% [label title])) |
69 | 70 | (define vp (new vertical-pane% |
70 | 71 | [parent d] [horiz-margin 4] [vert-margin 3] [alignment '(right top)])) |
71 | 72 | (when explain |
72 | (new message% [label explain] [parent vp] [vert-margin 2])) | |
73 | (new message% [label explain] [parent vp] [vert-margin 2] [min-height 16])) | |
73 | 74 | (define tf |
74 | 75 | (new text-field% [label (format "~a: " prompt)] [min-width 300] [parent vp] [vert-margin 2])) |
75 | 76 | (new button% [label action] [parent vp] [vert-margin 2] |
0 | 0 | #lang racket |
1 | 1 | |
2 | 2 | (require "store.rkt") |
3 | (require lens) | |
3 | 4 | (require net/url-string) |
4 | 5 | (require racket/block) |
5 | 6 | |
22 | 23 | |
23 | 24 | [(equal? (length p) 0) |
24 | 25 | (block |
25 | (info/add-identity (info/load) id) | |
26 | (info/add-identity id) | |
26 | 27 | `(new-id ,id))] |
27 | 28 | |
28 | 29 | [(equal? (path/param-path (first p)) "game") |
29 | 30 | (let ([gid (string->number (first (path/param-param (first p))))]) |
30 | (info/add-identity (info/load) id) | |
31 | (let-values ([(new-hash game-state) (info/add-game (info/load) id gid)]) | |
31 | (when (hash-has-key? (lens-view (game-info-lens id) (info/add-identity id)) gid) | |
32 | (error "game already exists")) | |
33 | (let-values ([(new-hash game-state) (info/add-game id gid)]) | |
32 | 34 | `(new-game ,id ,gid ,game-state)))] |
33 | 35 | |
34 | 36 | [#t (error "invalid URL path")])))) |
39 | 41 | |
40 | 42 | (define (invite-game host user-id game-id) |
41 | 43 | (url->string |
42 | (url "grandmaster" (number->string user-id) host #f #t (list (path/param "game" (list (number->string game-id)))) '() #f)))⏎ | |
44 | (url "grandmaster" (number->string user-id) host #f #t | |
45 | (list (path/param "game" (list (number->string game-id)))) '() #f)))⏎ |
0 | 0 | #lang racket/gui |
1 | 1 | |
2 | 2 | (require "chesstools.rkt") |
3 | (require "gamemgr.rkt") | |
3 | 4 | (require "gmlib.rkt") |
4 | 5 | (require "gmlens.rkt") |
5 | 6 | (require "guiutil.rkt") |
174 | 175 | (define (load-game-state) |
175 | 176 | (gm/get-game (first id) game-id)) |
176 | 177 | |
178 | (define monitor | |
179 | (create-monitor id game-id 'high (λ (gs) (send this set-game-state gs)))) | |
180 | (define/augment (on-close) | |
181 | (stop-monitor monitor)) | |
182 | ||
177 | 183 | (define outer-layout (new square-side-pane% [parent this])) |
178 | 184 | |
179 | 185 | ; it takes a while to load the game state, so we load it once while we're |
199 | 205 | (define right-layout (new vertical-panel% [parent outer-layout] [alignment '(right top)])) |
200 | 206 | (new button% [parent right-layout] [label "Hello"] [callback (λ (a b) (println b))]) |
201 | 207 | |
208 | (define/public (set-game-state state) | |
209 | (send cbc update-game-state state)) | |
210 | ||
202 | 211 | (define/public (send-move alg-move) |
203 | 212 | (gm/make-move (first id) game-id (second id) alg-move) |
204 | (send cbc update-game-state (load-game-state))) | |
213 | (set-game-state (load-game-state))) | |
205 | 214 | )) |
206 | 215 | |
207 | 216 | (define (display-game id game-id) |
82 | 82 | #:exists 'replace) |
83 | 83 | p)) |
84 | 84 | |
85 | (define/contract (info/add-identity info-hash new-identity) | |
85 | (define (bind-info-hash func) | |
86 | (λ args (apply func (info/load) args))) | |
87 | ||
88 | (define/contract (add-identity info-hash new-identity) | |
86 | 89 | (-> info-hash? identity? info-hash?) |
87 | 90 | (info/store |
88 | 91 | (if (hash-has-key? info-hash new-identity) |
90 | 93 | (hash-set info-hash |
91 | 94 | new-identity |
92 | 95 | (list (make-immutable-hash) (make-immutable-hash)))))) |
96 | (define info/add-identity (bind-info-hash add-identity)) | |
93 | 97 | |
94 | 98 | (define (game-info-lens id) |
95 | 99 | (lens-compose first-lens (hash-ref-lens id))) |
96 | 100 | (define (player-info-lens id) |
97 | 101 | (lens-compose second-lens (hash-ref-lens id))) |
98 | ||
99 | (define/contract (info/add-existing-player info-hash id player) | |
102 | ||
103 | ; adds an existing player to the identity's known users map. no remote changes. | |
104 | (define/contract (add-existing-player info-hash id player) | |
100 | 105 | (-> info-hash? identity? player-info? info-hash?) |
101 | 106 | (info/store |
102 | 107 | (lens-set (lens-compose (hash-ref-lens (first player)) |
103 | 108 | (player-info-lens id)) |
104 | 109 | info-hash |
105 | 110 | player))) |
111 | (define info/add-existing-player (bind-info-hash add-existing-player)) | |
106 | 112 | |
107 | (define/contract (info/invite-new-player info-hash id nickname) | |
113 | ; creates a new player and adds them to thte known users map. creates an | |
114 | ; invitation on the remote. | |
115 | (define/contract (invite-new-player info-hash id nickname) | |
108 | 116 | (-> info-hash? identity? string? (values info-hash? player-id?)) |
109 | 117 | (let ([new-id (arithmetic-shift |
110 | 118 | (integer-bytes->integer (crypto-random-bytes 8) #f) -1)]) |
111 | 119 | (block |
112 | 120 | (gm/new-user (first id) (second id) new-id) |
113 | (values (info/add-existing-player info-hash id (list new-id nickname)) | |
121 | (values (add-existing-player info-hash id (list new-id nickname)) | |
114 | 122 | new-id)))) |
123 | (define info/invite-new-player (bind-info-hash invite-new-player)) | |
115 | 124 | |
116 | (define/contract (info/new-game info-hash id other-player self-color) | |
125 | ; creates a new game. calls gm/new-game and gm/get-game. | |
126 | (define/contract (new-game info-hash id other-player self-color) | |
117 | 127 | (->i |
118 | 128 | ([info-hash (id other-player) |
119 | 129 | (and/c info-hash? |
129 | 139 | [other-player player-id?] |
130 | 140 | [self-color (one-of/c 'w 'b)]) |
131 | 141 | (values [new-hash info-hash?] [new-game-id game-id?] [game-state g?])) |
132 | (let ([new-game (apply gm/new-game | |
133 | (first id) | |
134 | (if (equal? self-color 'w) | |
135 | (list (second id) other-player) | |
136 | (list other-player (second id))))]) | |
137 | (let-values ([(new-hash game-state) (info/add-game info-hash id (g-id new-game))]) | |
142 | (let* ([w (if (equal? self-color 'w) (second id) other-player)] | |
143 | [b (if (equal? self-color 'b) (second id) other-player)] | |
144 | [new-game (gm/new-game (first id) #:white w #:black b)]) | |
145 | (let-values ([(new-hash game-state) (add-game info-hash id (g-id new-game))]) | |
138 | 146 | (values |
139 | 147 | new-hash |
140 | 148 | (g-id new-game) |
141 | 149 | game-state)))) |
150 | (define info/new-game (bind-info-hash new-game)) | |
142 | 151 | |
143 | (define/contract (info/add-game info-hash id game-id) | |
152 | ; Adds an existing game to the game map. Calls gm/get-game to figure out | |
153 | ; the ID of the other player in the game. | |
154 | (define/contract (add-game info-hash id game-id) | |
144 | 155 | (->i |
145 | 156 | ([info-hash (id game-id) |
146 | 157 | (and/c info-hash? |
160 | 171 | info-hash |
161 | 172 | (list game-id (g-player-white g) (g-player-black g)))) |
162 | 173 | g))) |
174 | (define info/add-game (bind-info-hash add-game)) | |
163 | 175 | |
164 | (define/contract (info/archive-game info-hash id game-id) | |
176 | ; Removes a game from the info hash. Makes no remote changes; if the | |
177 | ; user were to add the game using add-game after archiving it, nothing | |
178 | ; would have changed. | |
179 | (define/contract (archive-game info-hash id game-id) | |
165 | 180 | (->i |
166 | 181 | ([info-hash (id game-id) |
167 | 182 | (and/c info-hash? |
177 | 192 | (info/store |
178 | 193 | (lens-transform (game-info-lens id) info-hash |
179 | 194 | (λ (game-hash) (hash-remove game-hash game-id))))) |
180 | ⏎ | |
195 | (define info/archive-game (bind-info-hash archive-game))⏎ |