Commit 3dc7c23c81ebdf181bef8aaa773561c703599b07 - grandmaster

+7

-4

frontend/gamelist.rkt less more

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]))

+28

-0

frontend/gamemgr.rkt less more

	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))⏎

+1

-1

frontend/gamewizard.rkt less more

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))))

+1

-1

frontend/gmlib.rkt less more

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

+5

-4

frontend/guiutil.rkt less more

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]

+7

-4

frontend/invite.rkt less more

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)))⏎

+10

-1

frontend/render.rkt less more

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)

+30

-15

frontend/store.rkt less more

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))⏎