-
Notifications
You must be signed in to change notification settings - Fork 0
/
gwhist.rkt
406 lines (373 loc) · 15.6 KB
/
gwhist.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
#lang rackjure
(require games/cards
racket/gui/base
racket/class)
(require "util.rkt")
(current-curly-dict hasheq)
(define game-name "German Whist")
(define game-version "1.0")
(define version-message
(format #<<version
~a ~a
https://github.com/erkin/german-whist
Copyright (C) 2021 Lulu Cathrinus Grimalkin
Each file of this project's source code is subject
to the terms of the Mozilla Public Licence v2.0
https://mozilla.org/MPL/2.0/
version
game-name game-version))
;;;; Windowing definitions
;;; Dimensions in terms of cards (71x96)
(define table-w 10)
(define table-h 5)
(define table
(make-table game-name
table-w
table-h))
(define (quit!)
(send table show #f)
(custodian-shutdown-all (current-custodian))
(queue-callback exit #t))
(define (about)
(message-box
(format "About ~A v~A" game-name game-version)
version-message table '(ok no-icon)))
(define status-pane (send table create-status-pane))
(void
(new button% (parent status-pane)
(label "About")
(callback (thunk* (about))))
(new button% (parent status-pane)
(label "Exit")
(callback (thunk* (quit!)))))
;;;; Card definitions
(define pack
(map (λ (card)
(send* card
(user-can-flip #f)
(user-can-move #f))
card)
(shuffle-list (make-deck) 7)))
(define (card>? a b)
(let ((a-suit (send a get-suit-id))
(a-value (send a get-value))
(b-suit (send b get-suit-id))
(b-value (send b get-value)))
;; Higher suit (for the sake of sorting)
(or (> a-suit b-suit)
(and (= a-suit b-suit)
;; Aces rank above others.
(or (= a-value 1)
;; Higher rank otherwise
(and (> b-value 1)
(> a-value b-value)))))))
;; Can the card led beat the followed card?
(define (beats? lead follow trump-suit)
(let ((lead-suit (send lead get-suit))
(lead-value (send lead get-value))
(follow-suit (send follow get-suit))
(follow-value (send follow get-value)))
(if (eq? lead-suit follow-suit)
(or (= lead-value 1)
(and (> follow-value 1)
(> lead-value follow-value)))
(not (eq? follow-suit trump-suit)))))
(define (pick-a-card state)
(let* ((turn (dict-ref state 'turn))
(card-led (dict-ref state 'card-led))
(hand (dict-ref-in state `(,turn cards))))
;; Cards that can be legally played
(define playables
(if (not card-led)
hand
(let ((followers
(filter
(λ (card)
(= (send card get-suit-id)
(send card-led get-suit-id)))
hand)))
(if (null? followers)
hand
followers))))
(case turn
((player)
(define selection (box #f))
(define sema (make-semaphore))
;; Dim unplayable cards.
(for-each (λ (c) (send c dim #f)) playables)
;; Register a click action.
(send table set-single-click-action
(λ (c)
(send table pause 0.1)
;; Only works for playable cards.
(when (member c playables)
;; Unregister the click action.
(send table set-single-click-action void)
(set-box! selection c)
(semaphore-post sema))))
;; Wait until the player clicks on a card.
(yield sema)
(unbox selection))
(else
(define trump-suit (dict-ref state 'trump))
(sleep/yield 0.1)
(cond
(card-led
;; Try to head the trick if you can.
(define beaters (filter (λ (card) (beats? card-led card trump-suit)) playables))
;; Play the lowest card you can play.
(car (sort (if (null? beaters) playables beaters) (negate card>?))))
(else
;; Lead a random card. (TODO)
(list-random-ref playables)))))))
;;;; Region and hand definitions
(define w (send table table-width))
(define h (send table table-height))
(define cw (send (car pack) card-width))
(define ch (send (car pack) card-height))
(define-values (player-region opponent-region talon-region player-field opponent-field player-pile opponent-pile)
(let* ((mid-h (quotient (- h ch) 2))
(mid-w (quotient (- w cw) 2))
;; X coord Y coord width height label
(talon-region (region 0 mid-h cw ch #f #f))
(player-region (region (/ cw 2) (- h ch) (- w cw) ch #f #f))
(opponent-region (region (/ cw 2) 0 (- w cw) ch #f #f))
(player-field (region (- mid-w cw) mid-h cw ch #f #f))
(opponent-field (region (+ mid-w cw) mid-h cw ch #f #f))
(player-pile (region (- w cw) (* 3 ch) cw ch #f #f))
(opponent-pile (region (- w cw) ch cw ch #f #f)))
(values
player-region
opponent-region
talon-region
player-field
opponent-field
player-pile
opponent-pile)))
;;;; Gameplay definitions
(define (next-player player)
(if (eq? player 'player)
'opponent
'player))
(define (prepare-table! state)
(define-values (talon-cards player-cards opponent-cards)
(apply values (map (curryr dict-ref 'cards) (dict-refs state '(talon player opponent)))))
(send* table
(set-single-click-action void)
(set-double-click-action void)
(set-button-action 'left 'drag-raise/one)
;; Trump suit indicator text
(add-region (region 0 (* ch 3) cw 20 (symbol->string (dict-ref state 'trump)) #f))
;; The talon on the side
(add-region talon-region)
(add-cards-to-region talon-cards talon-region)
;; Player's visible cards
(add-region player-region)
(add-cards-to-region player-cards player-region)
(cards-face-up player-cards)
;; Bot's hidden cards
(add-region opponent-region)
(add-cards-to-region opponent-cards opponent-region)
;; Trick and pile regions
(add-region player-field)
(add-region player-pile)
(add-region opponent-field)
(add-region opponent-pile)
(center)
(show #t))
(sort-cards! state))
(define (sort-cards! state)
(define player-hand (sort (dict-ref-in state '(player cards)) (negate card>?)))
(define opponent-hand (dict-ref-in state '(opponent cards)))
;; Undim all cards.
(for-each (λ (c) (send c dim #f)) (send table all-cards))
;; Now dim all the cards in the player's hand.
(for-each (λ (c) (send c dim #t)) player-hand)
(send table move-cards-to-region player-hand (dict-ref-in state '(player region)))
(send table stack-cards player-hand)
(send table move-cards-to-region opponent-hand (dict-ref-in state '(opponent region)))
(send table stack-cards opponent-hand))
(define (lead state)
(define player (dict-ref state 'turn))
(cond
;; Talon depleted, we move to the second stage of the game.
((null? (dict-ref-in state '(talon cards)))
(game-loop (dict-set state 'phase 'lead*)))
;; Talon not depleted, still in the first stage of the game.
(else
;; Flip the top card of the talon.
(send table card-face-up (car (dict-ref-in state '(talon cards))))
;; What should the player lead?
(define lead (pick-a-card state))
;; Flip the card up.
(send table card-face-up lead)
;; Move the card to the player's trick region on the table.
(send table move-cards-to-region (list lead) (dict-ref-in state `(,player trick-region)))
(game-loop (~> state
;; Remove the card led from the player's hand.
(dict-update-in `(,player cards) #λ(remove lead %))
;; Put the card on the table.
(dict-set 'card-led lead)
;; It's the next player's turn to follow to the trick.
(dict-update 'turn next-player)
(dict-set 'phase 'follow))))))
(define (follow state)
(define player (dict-ref state 'turn))
(define lead (dict-ref state 'card-led))
(define follow (pick-a-card state))
;; Who wins the trick?
(define winner (if (beats? lead follow (dict-ref state 'trump))
(next-player player)
player))
;; Turned up card on the talon.
(define winners-card (car (dict-ref-in state '(talon cards))))
;; The next card on the talon.
(define losers-card (cadr (dict-ref-in state '(talon cards))))
(send table card-face-up winners-card)
;; Flip the played card up.
(send table card-face-up follow)
;; Move the card to the player's trick region on the table.
(send table move-cards-to-region (list follow) (dict-ref-in state `(,player trick-region)))
(send table card-face-up (car (dict-ref-in state '(talon cards))))
;; Collect the trick.
(sleep/yield 0.1)
(send table move-cards-to-region (list lead follow) (dict-ref-in state `(,winner pile-region)))
;; Flip the cards over.
(send table cards-face-down (list lead follow))
;; Move the top card of the talon to the winner's hand.
(send table move-cards-to-region (list winners-card) (dict-ref-in state `(,winner region)))
;; Move the next card to the loser's hand.
(send table move-cards-to-region (list losers-card) (dict-ref-in state `(,(next-player winner) region)))
;; Player's cards must remain visible and the opponent's cards must remain invisible.
(if (eq? winner 'player)
(send* table
(card-face-up winners-card)
(card-face-down losers-card))
(send* table
(card-face-up losers-card)
(card-face-down winners-card)))
(game-loop (~> state
;; Remove the played card from the player's hand.
(dict-update-in `(,player cards) (curry remove follow))
;; Pick the card off the table.
(dict-set 'card-led #f)
;; The winner picks up the top card of the talon.
(dict-update-in `(,winner cards) (curry cons winners-card))
;; The loser picks up the next card.
(dict-update-in `(,(next-player winner) cards) (curry cons losers-card))
;; The winner places the cards on their trick pile.
(dict-update-in `(,winner tricks) (curry append (list lead follow)))
;; Drop two cards from the talon.
(dict-update-in '(talon cards) cddr)
;; Winner of the trick leads again.
(dict-set* 'turn winner
'phase 'lead))))
(define (lead* state)
(define player (dict-ref state 'turn))
(cond
;; The player's hand is depleted. The game has come to an end.
((null? (dict-ref-in state `(,player cards)))
(end state))
;; The player leads the trick.
(else
;; What should the player lead?
(define lead (pick-a-card state))
;; Flip the card up.
(send table card-face-up lead)
;; Move the card to the player's trick region on the table.
(send table move-cards-to-region (list lead) (dict-ref-in state `(,player trick-region)))
(game-loop (~> state
;; Remove the card led from the player's hand.
(dict-update-in `(,player cards) #λ(remove lead %))
;; Put the card on the table.
(dict-set 'card-led lead)
;; It's next player's turn to follow to the trick.
(dict-update 'turn next-player)
(dict-set 'phase 'follow*))))))
(define (follow* state)
(define player (dict-ref state 'turn))
(define lead (dict-ref state 'card-led))
(define follow (pick-a-card state))
;; Who wins the trick?
(define winner (if (beats? lead follow (dict-ref state 'trump))
(next-player player)
player))
;; Flip the played card up.
(send table card-face-up follow)
;; Move the card to the player's trick region on the table.
(send table move-cards-to-region (list follow) (dict-ref-in state `(,player trick-region)))
(send table card-face-up follow)
;; Collect the trick.
(sleep/yield 0.1)
(send table move-cards-to-region (list lead follow) (dict-ref-in state `(,winner pile-region)))
;; Flip the cards over.
(send table cards-face-down (list lead follow))
(game-loop (~> state
(dict-set* 'phase 'lead*
'card-led #f)
;; Remove the played card from hand.
(dict-update-in `(,player cards) #λ(remove follow %))
;; The winner places the cards on their trick pile.
(dict-update-in `(,winner tricks) #λ(append (list lead follow) %))
;; Winner of the trick leads again.
(dict-set 'turn winner))))
(define (end state)
(send table set-status "Game over!")
(message-box
"Game Over!"
(apply format "Player score: ~A\nOpponent score: ~A"
(map (λ (player)
(/ (length (dict-ref-in state `(,player tricks))) 2))
'(player opponent)))
table '(ok no-icon))
(quit!))
(define (game-loop state)
(define talon-count (length (dict-ref-in state '(talon cards))))
(define talon-string (if (zero? talon-count)
"Talon depleted."
(format "~A cards in the talon." talon-count)))
(send table set-status
(format "It's ~A's turn. | ~A"
(dict-ref state 'turn)
talon-string))
(sort-cards! state)
(case (dict-ref state 'phase)
;; First stage
((lead)
(lead state))
((follow)
(follow state))
;; Second stage
((lead*)
(lead* state))
((follow*)
(follow* state))))
(module+ main
(application-quit-handler quit!)
(application-about-handler about)
(error-display-handler
(λ (str ex)
(displayln str)
(when (exn:fail? ex)
(message-box "Error" str table '(stop ok)))))
(let*-values (((player-cards opponent-cards talon-cards talon-cards*)
(apply values (split-into pack 13)))
((game-state)
{'phase 'lead
'turn (if (toss-coin?) 'player 'opponent)
'player {'cards player-cards ; List of cards in player's hand
'tricks null ; List of cards taken by the player
'region player-region ; Region that contains the player's hand
'trick-region player-field ; Region that contains the card played by the player
'pile-region player-pile} ; Region that contains the cards taken by the player
'opponent {'cards opponent-cards ; List of cards in the opponent's hand
'tricks null ; List of cards taken by the opponent
'region opponent-region ; Region that contains the opponent's hand
'trick-region opponent-field ; Region that contains the card played by the opponent
'pile-region opponent-pile} ; Region that contains the cards taken by the opponent
'card-led #f ; The card that was led to the trick
'talon {'cards (append talon-cards talon-cards*) ; Cards in the talon
'region talon-region} ; The region that contains the talon
'trump (send (car talon-cards) get-suit)})) ; The trump suit
(prepare-table! game-state)
(game-loop game-state)))