git.haldean.org grandmaster / 3dc7c23
auto updating for board Haldean Brown 1 year, 5 months ago
8 changed file(s) with 89 addition(s) and 30 deletion(s). Raw diff Collapse all Expand all
5252 (map (compose (player-name-func players id) second) games)
5353 (map (compose (player-name-func players id) third) games))
5454 ; 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)
5657 )))
5758
5859 (send this attach-doubleclick-listener (λ (id-gid) (open-game)))
6566 (define/public (archive-game)
6667 (let ([id-gid (get-current)])
6768 (unless (null? id-gid)
68 (apply info/archive-game (info/load) id-gid)
69 (apply info/archive-game id-gid)
6970 (load-identity (first id-gid)))))
7071 ))
7172
9899 (define f (new frame% [label "Grandmaster"] [width 800] [height 800]))
99100 (define hp (new horizontal-pane% [parent f]))
100101
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]))
102104 (new message% [parent left] [label "Servers"])
103105 (define idb (new identity-browser% [parent left]))
104106
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]))
106109
107110 (new message% [parent right] [label "Games"])
108111 (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))
1414 #:prompt "Opponent's name"
1515 #:action-name "Add"
1616 #:callback (λ (name)
17 (info/add-existing-player (info/load) id (list new-uid name))
17 (info/add-existing-player id (list new-uid name))
1818 (action-after))))
55
66 (provide gm/new-user gm/new-game gm/make-move gm/end-game gm/get-game
77 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?)
99
1010 (define (load-bit-set c fields)
1111 (list->set
5050 (define d (new dialog% [label "Error"]))
5151 (define vp (new vertical-pane%
5252 [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])
5454 (new button% [label "OK"] [parent vp] [vert-margin 2]
5555 [callback (λ (x ev) (send d show #f))])
5656 (send d show #t))
5959 (define d (new dialog% [label "Success"]))
6060 (define vp (new vertical-pane%
6161 [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])
6363 (new button% [label "OK"] [parent vp] [vert-margin 2]
6464 [callback (λ (x ev) (send d show #f))])
6565 (send d show #t))
6666
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])
6869 (define d (new dialog% [label title]))
6970 (define vp (new vertical-pane%
7071 [parent d] [horiz-margin 4] [vert-margin 3] [alignment '(right top)]))
7172 (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]))
7374 (define tf
7475 (new text-field% [label (format "~a: " prompt)] [min-width 300] [parent vp] [vert-margin 2]))
7576 (new button% [label action] [parent vp] [vert-margin 2]
00 #lang racket
11
22 (require "store.rkt")
3 (require lens)
34 (require net/url-string)
45 (require racket/block)
56
2223
2324 [(equal? (length p) 0)
2425 (block
25 (info/add-identity (info/load) id)
26 (info/add-identity id)
2627 `(new-id ,id))]
2728
2829 [(equal? (path/param-path (first p)) "game")
2930 (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)])
3234 `(new-game ,id ,gid ,game-state)))]
3335
3436 [#t (error "invalid URL path")]))))
3941
4042 (define (invite-game host user-id game-id)
4143 (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)))
00 #lang racket/gui
11
22 (require "chesstools.rkt")
3 (require "gamemgr.rkt")
34 (require "gmlib.rkt")
45 (require "gmlens.rkt")
56 (require "guiutil.rkt")
174175 (define (load-game-state)
175176 (gm/get-game (first id) game-id))
176177
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
177183 (define outer-layout (new square-side-pane% [parent this]))
178184
179185 ; it takes a while to load the game state, so we load it once while we're
199205 (define right-layout (new vertical-panel% [parent outer-layout] [alignment '(right top)]))
200206 (new button% [parent right-layout] [label "Hello"] [callback (λ (a b) (println b))])
201207
208 (define/public (set-game-state state)
209 (send cbc update-game-state state))
210
202211 (define/public (send-move alg-move)
203212 (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)))
205214 ))
206215
207216 (define (display-game id game-id)
8282 #:exists 'replace)
8383 p))
8484
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)
8689 (-> info-hash? identity? info-hash?)
8790 (info/store
8891 (if (hash-has-key? info-hash new-identity)
9093 (hash-set info-hash
9194 new-identity
9295 (list (make-immutable-hash) (make-immutable-hash))))))
96 (define info/add-identity (bind-info-hash add-identity))
9397
9498 (define (game-info-lens id)
9599 (lens-compose first-lens (hash-ref-lens id)))
96100 (define (player-info-lens id)
97101 (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)
100105 (-> info-hash? identity? player-info? info-hash?)
101106 (info/store
102107 (lens-set (lens-compose (hash-ref-lens (first player))
103108 (player-info-lens id))
104109 info-hash
105110 player)))
111 (define info/add-existing-player (bind-info-hash add-existing-player))
106112
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)
108116 (-> info-hash? identity? string? (values info-hash? player-id?))
109117 (let ([new-id (arithmetic-shift
110118 (integer-bytes->integer (crypto-random-bytes 8) #f) -1)])
111119 (block
112120 (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))
114122 new-id))))
123 (define info/invite-new-player (bind-info-hash invite-new-player))
115124
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)
117127 (->i
118128 ([info-hash (id other-player)
119129 (and/c info-hash?
129139 [other-player player-id?]
130140 [self-color (one-of/c 'w 'b)])
131141 (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))])
138146 (values
139147 new-hash
140148 (g-id new-game)
141149 game-state))))
150 (define info/new-game (bind-info-hash new-game))
142151
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)
144155 (->i
145156 ([info-hash (id game-id)
146157 (and/c info-hash?
160171 info-hash
161172 (list game-id (g-player-white g) (g-player-black g))))
162173 g)))
174 (define info/add-game (bind-info-hash add-game))
163175
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)
165180 (->i
166181 ([info-hash (id game-id)
167182 (and/c info-hash?
177192 (info/store
178193 (lens-transform (game-info-lens id) info-hash
179194 (λ (game-hash) (hash-remove game-hash game-id)))))
180
195 (define info/archive-game (bind-info-hash archive-game))