suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

svn: r8625

Browse Source
This commit is contained in:
Eli Barzilay 2008-02-11 22:25:08 +00:00
parent 88290b46be
commit 6bcaca2f09
29 changed files with 4393 additions and 4732 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
collects/games/aces/aces.scm
View File

@ -5,29 +5,24 @@ possible to remap single click (instead of double click)?
|#
(module aces mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "class.ss")
(lib "unit.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "unit.ss")
(lib "string-constant.ss" "string-constants")
"../show-help.ss")
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
(define table (make-table "Aces" 6 5))
(make-object button% (string-constant help-menu-label) table
(let ([show-help (show-help (list "games" "aces") "Aces Help")])
(lambda x
(show-help))))
(lambda x (show-help))))
(define draw-pile null)
@ -44,8 +39,7 @@ possible to remap single click (instead of double click)?
(let* ([table-width (send table table-width)]
[stack-spacing 7]
[num-stacks 5]
[all-stacks-width
(+ (* num-stacks card-width)
[all-stacks-width (+ (* num-stacks card-width)
(* (- num-stacks 1) stack-spacing))])
(+ (- (/ table-width 2) (/ all-stacks-width 2))
(* n (+ card-width stack-spacing)))))
@ -60,31 +54,17 @@ possible to remap single click (instead of double click)?
#f))
(define stacks
(list
(make-stack
(get-x-offset 1)
0
null)
(make-stack
(get-x-offset 2)
0
null)
(make-stack
(get-x-offset 3)
0
null)
(make-stack
(get-x-offset 4)
0
null)))
(list (make-stack (get-x-offset 1) 0 null)
(make-stack (get-x-offset 2) 0 null)
(make-stack (get-x-offset 3) 0 null)
(make-stack (get-x-offset 4) 0 null)))
;; type state = (make-state (listof cards) (listof[4] (listof cards)))
(define-struct state (draw-pile stacks))
;; extract-current-state : -> state
(define (extract-current-state)
(make-state
(copy-list draw-pile)
(make-state (copy-list draw-pile)
(map (lambda (x) (copy-list (stack-cards x))) stacks)))
(define (copy-list l) (map (lambda (x) x) l))
@ -115,16 +95,14 @@ possible to remap single click (instead of double click)?
(send table card-to-front draw-pile-card))
(reverse draw-pile))
(for-each
(lambda (stack)
(for-each (lambda (stack)
(let ([num-cards (length (stack-cards stack))])
(send table add-cards (stack-cards stack) 0 0)
(send table move-cards (stack-cards stack)
(stack-x stack)
(stack-y stack)
(lambda (i)
(values 0
(* (- num-cards i 1) card-space)))))
(values 0 (* (- num-cards i 1) card-space)))))
(send table cards-face-up (stack-cards stack)))
stacks)
(send table end-card-sequence))
@ -160,15 +138,11 @@ possible to remap single click (instead of double click)?
(define (position-cards stack)
(let ([m (length (stack-cards stack))])
(lambda (i)
(values 0
(if (= m 0)
0
(* (- m i 1) card-space))))))
(values 0 (if (= m 0) 0 (* (- m i 1) card-space))))))
(define (reset-game)
(send table remove-cards draw-pile)
(for-each
(lambda (stack) (send table remove-cards (stack-cards stack)))
(for-each (lambda (stack) (send table remove-cards (stack-cards stack)))
stacks)
(set! undo-stack null)
@ -188,15 +162,13 @@ possible to remap single click (instead of double click)?
(set-stack caddr)
(set-stack cadddr))
(for-each
(lambda (stack)
(for-each (lambda (stack)
(send table add-cards
(stack-cards stack)
(stack-x stack)
(stack-y stack)
(position-cards stack))
(for-each
(lambda (card) (send card flip))
(for-each (lambda (card) (send card flip))
(stack-cards stack)))
stacks)
@ -209,8 +181,7 @@ possible to remap single click (instead of double click)?
(lambda (select)
(let ([stack (select stacks)]
[card (select draw-pile)])
(set-stack-cards! stack
(cons card (stack-cards stack)))
(set-stack-cards! stack (cons card (stack-cards stack)))
(send table card-to-front card)
(send table flip-card card)))])
@ -245,9 +216,7 @@ possible to remap single click (instead of double click)?
(stack-y stack)
(position-cards stack))
(remove-card-from-stacks card)
(set-stack-cards!
stack
(cons card (stack-cards stack))))
(set-stack-cards! stack (cons card (stack-cards stack))))
(define (remove-card card)
(save-undo)
@ -256,8 +225,7 @@ possible to remap single click (instead of double click)?
(define (remove-card-from-stacks card)
(let ([old-cards (map stack-cards stacks)])
(for-each
(lambda (stack)
(for-each (lambda (stack)
(set-stack-cards! stack (remq card (stack-cards stack))))
stacks)
(for-each (lambda (stack old-cards)
@ -272,38 +240,34 @@ possible to remap single click (instead of double click)?
(send table set-single-click-action
(lambda (card)
(cond
[(send card face-down?) (move-from-deck)]
[else
(if (send card face-down?)
(move-from-deck)
(let ([bottom-four
(let loop ([l stacks])
(cond
[(null? l) null]
[else (let ([stack (car l)])
(if (null? l)
null
(let ([stack (car l)])
(if (null? (stack-cards stack))
(loop (cdr l))
(cons (car (stack-cards stack))
(loop (cdr l)))))]))])
(cons (car (stack-cards stack)) (loop (cdr l)))))))])
(when (memq card bottom-four)
(cond
[(ormap (lambda (bottom-card)
(if (ormap (lambda (bottom-card)
(and (eq? (send card get-suit)
(send bottom-card get-suit))
(or
(and (not (= 1 (send card get-value)))
(or (and (not (= 1 (send card get-value)))
(= 1 (send bottom-card get-value)))
(and (not (= 1 (send card get-value)))
(< (send card get-value)
(send bottom-card get-value))))))
bottom-four)
(remove-card card)]
[else (let loop ([stacks stacks])
(cond
[(null? stacks) (void)]
[else (let ([stack (car stacks)])
(remove-card card)
(let loop ([stacks stacks])
(if (null? stacks)
(void)
(let ([stack (car stacks)])
(if (null? (stack-cards stack))
(move-to-empty-spot card stack)
(loop (cdr stacks))))]))])))])
(loop (cdr stacks))))))))))
(check-game-over)))
(define (game-over?)
@ -348,24 +312,22 @@ possible to remap single click (instead of double click)?
(define mb (or (send table get-menu-bar)
(make-object menu-bar% table)))
(define edit-menu (instantiate menu% ()
(parent mb)
(label (string-constant edit-menu))))
(instantiate menu-item% ()
(label (string-constant undo-menu-item))
(parent edit-menu)
(callback (lambda (x y) (do-undo)))
(shortcut #\z)
(demand-callback
(lambda (item)
(send item enable (not (null? undo-stack))))))
(instantiate menu-item% ()
(label (string-constant redo-menu-item))
(parent edit-menu)
(callback (lambda (x y) (do-redo)))
(shortcut #\y)
(demand-callback
(lambda (item)
(send item enable (not (null? redo-stack))))))
(define edit-menu (new menu% [parent mb] [label (string-constant edit-menu)]))
(new menu-item%
[label (string-constant undo-menu-item)]
[parent edit-menu]
[callback (lambda (x y) (do-undo))]
[shortcut #\z]
[demand-callback
(lambda (item) (send item enable (not (null? undo-stack))))])
(new menu-item%
[label (string-constant redo-menu-item)]
[parent edit-menu]
[callback (lambda (x y) (do-redo))]
[shortcut #\y]
[demand-callback
(lambda (item) (send item enable (not (null? redo-stack))))])
(send table show #t))))
(send table show #t)
))

10
collects/games/aces/doc.txt
View File

@ -1,7 +1,7 @@
** To play _Aces_, run the "Games" application. **
** To play Aces, run the "PLT Games" application.
Aces is a solitaire card game. The object is to remove all of the cards
from the board, except the four Aces.
Aces is a solitaire card game. The object is to remove all of the
cards from the board, except the four Aces.
Remove a card by clicking it. You may remove a card when two
conditions are true. First, it must be at the bottom of one of the
@ -10,8 +10,8 @@ higher card of the same suit must also be at the bottom of one of the
four stacks of cards.
You may also move any card from the bottom of one of the stacks to an
empty stack by clicking it. If there are still cards in the deck on the
right, you may click the deck to deal four new cards, one onto the
empty stack by clicking it. If there are still cards in the deck on
the right, you may click the deck to deal four new cards, one onto the
bottom of each stack.
Good Luck!

108
collects/games/blackjack/blackjack.ss
View File

@ -29,19 +29,16 @@
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module blackjack mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "unit.ss")
(lib "list.ss"))
(lib "list.ss")
(lib "unit.ss"))
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
;; Number of decks to use
(define DECK-COUNT 4)
@ -87,20 +84,15 @@
(define BUTTON-WIDTH cw)
;; Cards are not movable
(for-each
(lambda (card)
(send card user-can-move #f)
(send card user-can-flip #f))
(for-each (lambda (card) (send* card (user-can-move #f) (user-can-flip #f)))
deck)
;; Set up card regions
(define deck-region
(make-region MARGIN MARGIN
cw ch #f #f))
(make-region MARGIN MARGIN cw ch #f #f))
(define discard-region
(make-region (- w cw MARGIN) MARGIN
cw ch #f #f))
(make-region (- w cw MARGIN) MARGIN cw ch #f #f))
(define dealer-region
(make-region (+ cw (* 2 MARGIN)) MARGIN
@ -156,10 +148,7 @@
;; Function to compute the normal or minimum value of a card
(define (min-card-value c)
(let ([v (send c get-value)])
(if (> v 10)
10
v)))
(let ([v (send c get-value)]) (if (> v 10) 10 v)))
;; Function to compute the value of a hand, counting aces as 1 or 11
;; to get the highest total possible under 21
@ -169,8 +158,7 @@
[others (filter (ace? #f) l)]
[base (apply + (map min-card-value others))])
(let loop ([l aces][base base])
(cond
[(null? l) base]
(cond [(null? l) base]
[(<= (+ base (* (length aces) 11)) 21)
(+ base (* (length aces) 11))]
[else (loop (cdr l) (add1 base))]))))
@ -273,8 +261,9 @@
(let ([cont (make-semaphore)])
(done "Bust" cont)
(yield cont)))]
;; Callback for the hit button; the button's callback
;; is changed for diferent modes: normal, split part 1, or split part 2
;; Callback for the hit button; the button's callback is
;; changed for diferent modes: normal, split part 1, or split
;; part 2
[make-hit-callback
(lambda (get-p set-p! player-region bust)
(lambda ()
@ -285,8 +274,7 @@
(send t move-cards-to-region (get-p) player-region)
(send t cards-face-up (get-p))
;; Check for bust
(when (bust? (get-p))
(bust))))])
(when (bust? (get-p)) (bust))))])
;; Blackjack by player or dealer?
(if (or (= 21 (best-total p))
(= 21 (best-total d)))
@ -301,16 +289,17 @@
(send t add-region stand-button)
(send t add-region double-button)
;; Set the callbacks for normal (unsplit) hands
(set-region-callback! hit-button
(make-hit-callback
(lambda () p)
(set-region-callback!
hit-button
(make-hit-callback (lambda () p)
(lambda (v) (set! p v))
player-region
bust))
(set-region-callback! stand-button
(lambda ()
(semaphore-post continue)))
(set-region-callback! double-button
(set-region-callback!
stand-button
(lambda () (semaphore-post continue)))
(set-region-callback!
double-button
(lambda ()
;; Note the double for adjusting money on a win
(set! double? #t)
@ -318,30 +307,30 @@
(update-money! -2)
;; Deal one more card
((region-callback hit-button))
;; No more cards or actions, but if the player busted, the hit
;; callback has already continued
(unless (bust? p)
(semaphore-post continue))))
;; No more cards or actions, but if the player busted, the
;; hit callback has already continued
(unless (bust? p) (semaphore-post continue))))
;; Split allowed?
(when (= (min-card-value (car p)) (min-card-value (cadr p)))
;; Yes, we can split. If the player hits the split button,
;; we have to split the cards, deal one more to each split
;; half and adjust the callbacks for hit and stand.
;; (If aces are split, the round is over.)
;; Yes, we can split. If the player hits the split button, we
;; have to split the cards, deal one more to each split half
;; and adjust the callbacks for hit and stand. (If aces are
;; split, the round is over.)
(send t add-region split-button)
(set-region-callback! split-button
(set-region-callback!
split-button
(lambda ()
;; Double our bet...
(update-money! -2)
;; Split the hand
(set! p2 (list (cadr p)))
(set! p (list (car p)))
;; Move the split halves to the "waiting" area. The
;; active area is reserved for hands that are being
;; played
;; Move the split halves to the "waiting" area. The active
;; area is reserved for hands that are being played
(send t move-cards-to-region p player-1-wait-region)
(send t move-cards-to-region p2 player-2-wait-region)
;; Deal one more card to each half and move them into place
;; Deal one more card to each half and move them into
;; place
(set! p (append (deal 1) p))
(set! p2 (append (deal 1) p2))
(send t stack-cards p)
@ -361,7 +350,8 @@
(send t move-cards-to-region p2 player-2-wait-region)
;; Let the main loop finish up
(semaphore-post continue))]
;; Callback to swicth from the first split hand to the second
;; Callback to swicth from the first split hand to
;; the second
[switch
(lambda ()
;; Unhilite the first hand
@ -391,7 +381,8 @@
(send t move-cards-to-region p player-1-region)
;; Hilite the first hand
(send t add-region player-1-border)
;; Adjust callbacks to work on the first of a split hand
;; Adjust callbacks to work on the first of a split
;; hand
(set-region-callback!
hit-button
(make-hit-callback (lambda () p)
@ -402,9 +393,7 @@
(switch)
(send t add-region hit-button)
(send t add-region stand-button))))
(set-region-callback!
stand-button
switch)))))))
(set-region-callback! stand-button switch)))))))
;; Wait until the player is done
(yield continue)
;; No more player actions; get rid of the buttons
@ -412,10 +401,9 @@
(send t remove-region stand-button)
(send t remove-region double-button)
(send t remove-region split-button)
;; If all the player's hards are bust, the dealer doesn't do anything
(unless (and (bust? p)
(or (null? p2)
(bust? p2)))
;; If all the player's hards are bust, the dealer doesn't do
;; anything
(unless (and (bust? p) (or (null? p2) (bust? p2)))
;; Show the dealer's starting hand
(send t card-face-up (cadr d))
(let loop ()
@ -442,9 +430,11 @@
(set! discard (append p p2 d discard))
(send t cards-face-down discard)
(send t move-cards-to-region discard discard-region)
;; Go again. Check whether we should reshuffle the deck or keep going with this one
;; Go again. Check whether we should reshuffle the deck or keep
;; going with this one
(if (< (length deck) min-deck-size)
(begin
(send t move-cards-to-region deck discard-region)
(begin (send t move-cards-to-region deck discard-region)
(shuffle-loop))
(loop)))))))))))
(loop))))))))
))

13
collects/games/blackjack/doc.txt
View File

@ -1,4 +1,4 @@
** To play _Blackjack_, run the "Games" application. **
** To play Blackjack, run the "PLT Games" application.
Standard Blackjack rules, plus the following specifics:
@ -8,9 +8,9 @@ Standard Blackjack rules, plus the following specifics:
* Dealer stands on soft 17s
* Splitting is allowed only on the first two cards, and only if
they are equal; 10 and the face cards are all considered equal
for splitting
* Splitting is allowed only on the first two cards, and only if they
are equal; 10 and the face cards are all considered equal for
splitting
* Doubling is allowed on all unsplit hands, not on split hands
@ -22,6 +22,5 @@ Standard Blackjack rules, plus the following specifics:
* No maximum under-21 hand size
* Dealer's second card is not revealed if the player busts (or
both halves of a split hand bust)
* Dealer's second card is not revealed if the player busts (or both
halves of a split hand bust)

196
collects/games/checkers/checkers.ss
View File

@ -1,23 +1,23 @@
(module checkers mzscheme
#lang mzscheme
(require (lib "gl-board.ss" "games" "gl-board-game")
(lib "class.ss")
(lib "math.ss")
(lib "mred.ss" "mred")
(lib "unit.ss")
(lib "gl-vectors.ss" "sgl")
(prefix gl- (lib "sgl.ss" "sgl"))
(lib "gl.ss" "sgl")
(lib "array.ss" "srfi" "25")
(lib "unit.ss")
(lib "include-bitmap.ss" "mrlib")
"honu-bitmaps.ss")
(provide game@)
(define-struct image (width height rgba))
(define (argb->rgba argb)
(let* ((length (bytes-length argb))
(rgba (make-gl-ubyte-vector length)))
(let* ([length (bytes-length argb)]
[rgba (make-gl-ubyte-vector length)])
(let loop ((i 0))
(when (< i length)
(gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1)))
@ -28,10 +28,10 @@
rgba))
(define (bitmap->argb bmp)
(let* ((width (send bmp get-width))
(height (send bmp get-height))
(argb (make-bytes (* 4 width height) 255))
(dc (make-object bitmap-dc% bmp)))
(let* ([width (send bmp get-width)]
[height (send bmp get-height)]
[argb (make-bytes (* 4 width height) 255)]
[dc (make-object bitmap-dc% bmp)])
(send dc get-argb-pixels 0 0 width height argb #f)
(when (send bmp get-loaded-mask)
(send dc set-bitmap (send bmp get-loaded-mask))
@ -75,10 +75,10 @@
(export view^)
(define (get-space-draw-fn space)
(let* ((list-id (get-square-dl (space-info-light? space)
(send texture-box get-value)))
(sx (space-info-x space))
(sy (space-info-y space)))
(let* ([list-id (get-square-dl (space-info-light? space)
(send texture-box get-value))]
[sx (space-info-x space)]
[sy (space-info-y space)])
(lambda ()
(gl-push-matrix)
(gl-translate sx sy 0)
@ -89,9 +89,9 @@
(send board add-space (get-space-draw-fn space) space))
(define (get-piece-draw-fn piece glow?)
(let ((list-id (get-checker-dl (eq? 'red (piece-info-color piece))
(let ([list-id (get-checker-dl (eq? 'red (piece-info-color piece))
(piece-info-king? piece)
(send texture-box get-value))))
(send texture-box get-value))])
(if glow?
(lambda (for-shadow?)
(gl-material-v 'front 'emission (gl-float-vector 0.15 0.15 0.15 1.0))
@ -102,33 +102,33 @@
(define add-piece
(case-lambda
((piece) (add-piece piece #f))
((piece glow?)
(send board add-piece (+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0
[(piece) (add-piece piece #f)]
[(piece glow?)
(send board add-piece
(+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0
(get-piece-draw-fn piece glow?)
piece))))
piece)]))
(define (move-piece from to-x to-y)
(remove-piece from)
(add-piece (make-piece-info to-x to-y (piece-info-color from) (piece-info-king? from))))
(add-piece (make-piece-info to-x to-y
(piece-info-color from)
(piece-info-king? from))))
(define (remove-piece p)
(send board remove-piece p))
(define (internal-move old move-to)
(when (piece-info? old)
(move old move-to)))
(when (piece-info? old) (move old move-to)))
(define (set-turn turn moves)
(let* ([pieces (send board get-pieces)])
(let ([pieces (send board get-pieces)])
(for-each (lambda (p)
(send board set-piece-draw p
(get-piece-draw-fn p #f))
(send board set-piece-draw p (get-piece-draw-fn p #f))
(send board enable-piece p #f))
pieces)
(for-each (lambda (p)
(send board set-piece-draw p
(get-piece-draw-fn p #t))
(send board set-piece-draw p (get-piece-draw-fn p #t))
(send board enable-piece p #t))
(moves-list moves)))
(send msg set-label
@ -136,9 +136,7 @@
(format "~a wins!" (if (eq? turn 'red) "Black" "Red"))
(format "~a's turn~a"
(if (eq? turn 'red) "Red" "Black")
(if (moves-forced-jump? moves)
" - must take jump"
"")))))
(if (moves-forced-jump? moves) " - must take jump" "")))))
(define f (new frame% (label "Checkers") (width 800) (height 600)))
(define board
@ -155,8 +153,7 @@
(lambda (box _)
(for-each
(lambda (s)
(send board set-space-draw s
(get-space-draw-fn s)))
(send board set-space-draw s (get-space-draw-fn s)))
(send board get-spaces))
(for-each
(lambda (p)
@ -168,15 +165,13 @@
(send texture-box set-value #t)
(define q
(send board with-gl-context
(lambda () (gl-new-quadric))))
(send board with-gl-context (lambda () (gl-new-quadric))))
(define-values (dark-tex light-tex dark-checker-tex light-checker-tex)
(send board with-gl-context
(lambda ()
(let ((x (glGenTextures 4)))
(values
(gl-vector-ref x 0)
(values (gl-vector-ref x 0)
(gl-vector-ref x 1)
(gl-vector-ref x 2)
(gl-vector-ref x 3))))))
@ -189,7 +184,8 @@
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP)
(glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP)
(glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (image-width img) (image-height img) 0
(glTexImage2D GL_TEXTURE_2D 0 GL_RGBA
(image-width img) (image-height img) 0
GL_RGBA GL_UNSIGNED_BYTE (image-rgba img)))))
(init-tex light-tex light-square-img)
@ -200,13 +196,12 @@
(define (make-piece-dl color height tex shadow?)
(send board with-gl-context
(lambda ()
(let ((list-id (gl-gen-lists 1)))
(let ([list-id (gl-gen-lists 1)])
(gl-quadric-draw-style q 'fill)
(gl-quadric-normals q 'smooth)
(gl-new-list list-id 'compile)
(when shadow?
(gl-disable 'lighting))
(when shadow? (gl-disable 'lighting))
(gl-material-v 'front 'specular (gl-float-vector 1.0 1.0 1.0 1.0))
(gl-material 'front 'shininess 120.0)
@ -230,15 +225,14 @@
(gl-pop-matrix)
(when shadow?
(gl-enable 'lighting))
(when shadow? (gl-enable 'lighting))
(gl-end-list)
list-id))))
(define (make-tex-square-dl tex)
(send board with-gl-context
(lambda ()
(let ((list-id (gl-gen-lists 1)))
(let ([list-id (gl-gen-lists 1)])
(gl-new-list list-id 'compile)
(gl-enable 'texture-2d)
(glBindTexture GL_TEXTURE_2D tex)
@ -261,7 +255,7 @@
(define (make-square-dl color)
(send board with-gl-context
(lambda ()
(let ((list-id (gl-gen-lists 1)))
(let ([list-id (gl-gen-lists 1)])
(gl-new-list list-id 'compile)
(gl-material-v 'front 'ambient-and-diffuse color)
(gl-begin 'polygon)
@ -274,13 +268,14 @@
list-id))))
(define checkers
(map
(lambda (x)
(let ((color (if (car x)
(map (lambda (x)
(let ([color (if (car x)
(color-name->vector "firebrick" #t)
(gl-float-vector 0.15 0.15 0.15 1.0)))
(height (if (cadr x) .4 .2))
(tex (if (caddr x) (if (car x) light-checker-tex dark-checker-tex) #f)))
(gl-float-vector 0.15 0.15 0.15 1.0))]
[height (if (cadr x) .4 .2)]
[tex (if (caddr x)
(if (car x) light-checker-tex dark-checker-tex)
#f)])
(cons x (cons (make-piece-dl color height tex #f)
(make-piece-dl color height tex #t)))))
'((#f #f #f)
@ -302,8 +297,7 @@
(let ((getter (if tex? car cdr)))
(getter (if light? light-square dark-square))))
(define (show)
(send f show #t)))
(define (show) (send f show #t)))
(define-unit model@
(import view^)
@ -312,29 +306,24 @@
(define turn 'red)
(define board (make-array (shape 0 8 0 8) #f))
(let loop ((i 0)
(j 0))
(let loop ([i 0] [j 0])
(cond
((and (< j 8) (< i 8))
[(and (< j 8) (< i 8))
(cond
((even? (+ i j))
[(even? (+ i j))
(add-space (make-space-info j i #f))
(cond
((< i 3)
(cond [(< i 3)
(array-set! board j i (cons 'red #f))
(add-piece (make-piece-info j i 'red #f)))
((> i 4)
(add-piece (make-piece-info j i 'red #f))]
[(> i 4)
(array-set! board j i (cons 'black #f))
(add-piece (make-piece-info j i 'black #f)))))
(else
(add-space (make-space-info j i #t))))
(loop i (add1 j)))
((< i 8) (loop (add1 i) 0))))
(add-piece (make-piece-info j i 'black #f))])]
[else (add-space (make-space-info j i #t))])
(loop i (add1 j))]
[(< i 8) (loop (add1 i) 0)]))
(define (other-color c)
(cond
((eq? c 'red) 'black)
(else 'red)))
(if (eq? c 'red) 'black 'red))
(define (single-move-ok? direction from-x from-y to-x to-y)
(and (= to-y (+ direction from-y))
@ -350,17 +339,18 @@
(define (get-jumped-piece color direction from-x from-y to-x to-y)
(and (= to-y (+ direction direction from-y))
(= 2 (abs (- from-x to-x)))
(let* ((jumped-x (+ from-x (/ (- to-x from-x) 2)))
(jumped-y (+ from-y direction))
(jumped-piece (array-ref board jumped-x jumped-y)))
(let* ([jumped-x (+ from-x (/ (- to-x from-x) 2))]
[jumped-y (+ from-y direction)]
[jumped-piece (array-ref board jumped-x jumped-y)])
(and jumped-piece
(eq? (other-color color) (car jumped-piece))
(make-piece-info jumped-x jumped-y (car jumped-piece) (cdr jumped-piece))))))
(make-piece-info jumped-x jumped-y
(car jumped-piece) (cdr jumped-piece))))))
(define (can-jump? direction from-color from-x from-y)
(let ((to-y (+ direction direction from-y))
(to-x1 (+ from-x 2))
(to-x2 (- from-x 2)))
(let ([to-y (+ direction direction from-y)]
[to-x1 (+ from-x 2)]
[to-x2 (- from-x 2)])
(and (<= 0 to-y 7)
(or (and (<= 0 to-x1 7)
(not (array-ref board to-x1 to-y))
@ -373,7 +363,6 @@
from-x from-y
to-x2 to-y))))))
(define (fold-board f v)
(let iloop ([i 0] [v v])
(if (= i 8)
@ -381,10 +370,7 @@
(let jloop ([j 0] [v v])
(if (= j 8)
(iloop (add1 i) v)
(jloop (add1 j)
(if (even? (+ i j))
(f i j v)
v)))))))
(jloop (add1 j) (if (even? (+ i j)) (f i j v) v)))))))
(define (get-jump-moves)
(let ([direction (if (eq? turn 'red) 1 -1)])
@ -412,34 +398,30 @@
(if (and p
(eq? (car p) turn)
(or (can-move? direction i j)
(and (cdr p)
(can-move? (- direction) i j))))
(and (cdr p) (can-move? (- direction) i j))))
(cons (make-piece-info i j turn (cdr p)) l)
l)))
null))
#f))))
(define (move from to)
(let* ((to-x (inexact->exact (floor (gl-vector-ref to 0))))
(to-y (inexact->exact (floor (gl-vector-ref to 1))))
(from-x (piece-info-x from))
(from-y (piece-info-y from))
(from-color (piece-info-color from))
(from-king? (piece-info-king? from))
(to-king? (or from-king?
(if (eq? 'red from-color)
(= to-y 7)
(= to-y 0))))
(direction (if (eq? turn 'red) 1 -1)))
(let* ([to-x (inexact->exact (floor (gl-vector-ref to 0)))]
[to-y (inexact->exact (floor (gl-vector-ref to 1)))]
[from-x (piece-info-x from)]
[from-y (piece-info-y from)]
[from-color (piece-info-color from)]
[from-king? (piece-info-king? from)]
[to-king? (or from-king? (= to-y (if (eq? 'red from-color) 7 0)))]
[direction (if (eq? turn 'red) 1 -1)])
(when (and (eq? turn from-color)
(<= 0 to-x 7)
(<= 0 to-y 7)
(not (array-ref board to-x to-y)))
(cond
((and (null? (get-jump-moves))
(cond [(and (null? (get-jump-moves))
(or (single-move-ok? direction from-x from-y to-x to-y)
(and from-king?
(single-move-ok? (- direction) from-x from-y to-x to-y))))
(single-move-ok? (- direction) from-x from-y
to-x to-y))))
(move-piece from to-x to-y)
(set! turn (other-color from-color))
(array-set! board to-x to-y (cons from-color to-king?))
@ -447,8 +429,9 @@
(when (and to-king? (not from-king?))
(remove-piece (make-piece-info to-x to-y from-color from-king?))
(add-piece (make-piece-info to-x to-y from-color to-king?)))
(set-turn turn (get-moves)))
((or (get-jumped-piece from-color direction from-x from-y to-x to-y)
(set-turn turn (get-moves))]
[(or (get-jumped-piece from-color direction from-x from-y
to-x to-y)
(and from-king?
(get-jumped-piece from-color (- direction) from-x from-y to-x to-y)))
=>
@ -462,13 +445,16 @@
(remove-piece (make-piece-info to-x to-y from-color from-king?))
(add-piece (make-piece-info to-x to-y from-color to-king?)))
(cond
((or (can-jump? direction from-color to-x to-y)
[(or (can-jump? direction from-color to-x to-y)
(and from-king?
(can-jump? (- direction) from-color to-x to-y)))
(set-turn turn (make-moves (list (make-piece-info to-x to-y from-color to-king?)) #t)))
(else
(set-turn turn
(make-moves (list (make-piece-info
to-x to-y from-color to-king?))
#t))]
[else
(set! turn (other-color from-color))
(set-turn turn (get-moves))))))))))
(set-turn turn (get-moves))]))]))))
(set-turn turn (get-moves))
)
@ -479,8 +465,4 @@
(show))
(define game@
(compound-unit/infer
(import)
(export)
(link view@ model@ show@)))
)
(compound-unit/infer (import) (export) (link view@ model@ show@)))

185
collects/games/crazy8s/crazy8s.ss
View File

@ -1,5 +1,6 @@
(module crazy8s mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred")
(lib "class.ss")
@ -37,16 +38,11 @@
(provide game@)
(define-signature configuration^
(opponents-count
init-hand-size
drag-mode?
new-game))
(opponents-count init-hand-size drag-mode? new-game))
;; This unit drives multiple Crazy 8 instances:
(define game@
(unit
(import)
(export)
(unit (import) (export)
;; Configuration
(define opponents-count (get-preference 'crazy8s:num-opponents (lambda () 1)))
@ -62,22 +58,20 @@
(lambda ()
(start-new-game oc ihs dm?)))))
;; Start a new game as a child process:
(parameterize ([current-custodian (make-custodian)])
(parameterize ([exit-handler (lambda (v)
(custodian-shutdown-all (current-custodian)))])
(parameterize ([current-eventspace (make-eventspace)])
(parameterize* ([current-custodian (make-custodian)]
[exit-handler
(lambda (v)
(custodian-shutdown-all (current-custodian)))]
[current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(invoke-unit configured-game@ (import configuration^))))))))
(lambda () (invoke-unit configured-game@ (import configuration^))))))
;; Start the initial child game:
(start-new-game opponents-count init-hand-size drag-mode?)))
;; This unit is for a particular Crazy 8 instance:
(define configured-game@
(unit
(import configuration^)
(export)
(unit (import configuration^) (export)
;; Randomize
(random-seed (modulo (current-milliseconds) 10000))
@ -90,10 +84,11 @@
;; Add status line and buttons:
(define status-pane (send t create-status-pane))
(new button%
(parent status-pane)
(label "Options...")
(callback (lambda (b e) (configure-dialog))))
(send t add-help-button status-pane (list "games" "crazy8s") "Crazy 8s Help" #f)
[parent status-pane]
[label "Options..."]
[callback (lambda (b e) (configure-dialog))])
(send t add-help-button status-pane
(list "games" "crazy8s") "Crazy 8s Help" #f)
;; The "Options.." button opens a configuration dialog that
;; starts a new game:
@ -122,8 +117,7 @@
(new button%
[label "Close"]
[parent button-panel]
[callback (lambda (b e)
(send d show #f))])
[callback (lambda (b e) (send d show #f))])
(new button%
[label "New Game"]
[parent button-panel]
@ -168,10 +162,7 @@
(define all-cards (shuffle-list (make-deck) 7))
(define deck all-cards)
(define discards null)
(for-each
(lambda (card)
(send card user-can-flip #f))
deck)
(for-each (lambda (card) (send card user-can-flip #f)) deck)
;; We'll need an 8 of each suit for substitutions later
(define (find-8 suit)
@ -189,9 +180,7 @@
(define (deal n)
(let loop ([n n][d deck])
(if (zero? n)
(begin
(set! deck d)
null)
(begin (set! deck d) null)
(cons (car d) (loop (sub1 n) (cdr d))))))
;; Card width & height
@ -232,8 +221,7 @@
bm
;; The callback for the region sends
;; a clonable card to the game driver
(lambda ()
(async-channel-put msg card)))))
(lambda () (async-channel-put msg card)))))
(define hearts-region
(make-suit-region (+ (region-x discard-target-region) cw (* 2 MARGIN))
(+ (region-y discard-target-region)
@ -303,7 +291,8 @@
(send t stack-cards sorted)
(send t move-cards-to-region sorted (player-hand-r you))))
(define clean-button
(make-button-region (region-x (player-r you))
(make-button-region
(region-x (player-r you))
(- (region-y (player-r you))
(+ BUTTON-HEIGHT MARGIN))
PASS-W BUTTON-HEIGHT
@ -321,17 +310,13 @@
(cond
[(= 8 (send a get-value))
(or (not (= 8 (send b get-value)))
(< (remap (send a get-suit-id))
(remap (send b get-suit-id))))]
(< (remap (send a get-suit-id)) (remap (send b get-suit-id))))]
[(= 8 (send b get-value))
#f]
[(= (send a get-suit-id)
(send b get-suit-id))
(< (send a get-value)
(send b get-value))]
[(= (send a get-suit-id) (send b get-suit-id))
(< (send a get-value) (send b get-value))]
[else
(< (remap (send a get-suit-id))
(remap (send b get-suit-id)))]))
(< (remap (send a get-suit-id)) (remap (send b get-suit-id)))]))
(when drag-mode?
(send t add-region
(make-button-region (+ (region-x clean-button) PASS-W MARGIN)
@ -350,10 +335,8 @@
(and (= 1 (length cs))
(let ([c (car cs)])
(and (memq c (player-hand you))
(or (= (send (car discards) get-value)
(send c get-value))
(= (send (car discards) get-suit-id)
(send c get-suit-id))
(or (= (send (car discards) get-value) (send c get-value))
(= (send (car discards) get-suit-id) (send c get-suit-id))
(= (send c get-value) 8))
c))))
@ -362,19 +345,14 @@
(and (null? deck)
(not (ormap (lambda (p)
(and (pair? (player-hand p))
(ormap (lambda (c)
(get-discard-card (list c)))
(ormap (lambda (c) (get-discard-card (list c)))
(player-hand p))))
players))))
;; Auto-player strategy: Choose which valid card to discard
(define (pick-to-discard cards)
(let ([non-8s (filter (lambda (c)
(not (= 8 (send c get-value))))
cards)])
(if (null? non-8s)
(car cards)
(car non-8s))))
(let ([non-8s (filter (lambda (c) (not (= 8 (send c get-value)))) cards)])
(car (if (null? non-8s) cards non-8s))))
;; Auto-player: take a turn
(define (play-opponent p)
@ -413,17 +391,22 @@
(when (and (= 8 (send (car discards) get-value))
(pair? (player-hand p)))
;; Pick a suit based on our hand
(let ([counts (map (lambda (v)
(let ([counts
(map (lambda (v)
(cons v
(length (filter (lambda (c)
(length
(filter
(lambda (c)
(and (= v (send c get-suit-id))
(not (= 8 (send c get-value)))))
(player-hand p)))))
'(1 2 3 4))])
(let ([suit-id
;; Sort based on counts, then pick the first one:
(sub1 (caar (sort counts (lambda (a b) (> (cdr a) (cdr b))))))])
;; Find the clonable 8 for the chosen suit, and reset the discard
(sub1 (caar (sort counts (lambda (a b)
(> (cdr a) (cdr b))))))])
;; Find the clonable 8 for the chosen suit, and
;; reset the discard
(reset-8
(list-ref
(list 8-clubs 8-diamonds 8-hearts 8-spades)
@ -435,14 +418,12 @@
(define (allow-cards on?)
(when (pair? deck)
(send (car deck) user-can-move (and drag-mode? on?)))
(for-each (lambda (c)
(send c user-can-move (and drag-mode? on?)))
(for-each (lambda (c) (send c user-can-move (and drag-mode? on?)))
(player-hand you))
(send t set-single-click-action (if (and on? (not drag-mode?))
click-card
(if drag-mode?
void
(lambda (x) (bell)))))
(send t set-single-click-action
(cond [(and on? (not drag-mode?)) click-card]
[drag-mode? void]
[else (lambda (x) (bell))]))
(when (null? deck)
(if on?
(send t add-region pass-button)
@ -451,8 +432,7 @@
;; Utility: replaces the top discard, which is an 8, with an 8
;; of a particular suit (possibly the same).
(define (reset-8 got-8)
(unless (eq? (send (car discards) get-suit)
(send got-8 get-suit))
(unless (eq? (send (car discards) get-suit) (send got-8 get-suit))
(let ([c (send got-8 copy)])
(send c user-can-move #f)
(send t flip-card (car discards))
@ -471,8 +451,7 @@
(send t add-region diamonds-region)
(send t set-status PICK-A-SUIT)
;; Clicking one of these regions returns a clonable 8 card:
(let ([got-8 (yield msg)])
(reset-8 got-8))
(let ([got-8 (yield msg)]) (reset-8 got-8))
(send t remove-region hearts-region)
(send t remove-region spades-region)
(send t remove-region clubs-region)
@ -493,8 +472,7 @@
discard-target-region
(lambda (cs)
(let ([c (get-discard-card cs)])
(when c
(you-discard c)))))
(when c (you-discard c)))))
(define (you-discard c)
(send c home-region #f)
@ -510,22 +488,18 @@
(set-region-interactive-callback!
(player-r you)
(lambda (in? cs)
(send (car cs) home-region
(if in? (player-r you) deck-region))))
(send (car cs) home-region (if in? (player-r you) deck-region))))
;; Install final callback for hand: draw the card:
(set-region-callback!
(player-r you)
(lambda (cs)
(let ([c (car cs)])
(you-draw c))))
(lambda (cs) (let ([c (car cs)]) (you-draw c))))
(define (you-draw c)
(send t flip-card c)
(send c home-region (player-r you))
(set-player-hand! you (let loop ([l (player-hand you)])
(cond
[(null? l) (list c)]
(cond [(null? l) (list c)]
[(card< c (car l)) (cons c l)]
[else (cons (car l) (loop (cdr l)))])))
(deal 1)
@ -535,12 +509,9 @@
(async-channel-put msg 'draw))
(define (click-card c)
(cond
[(memq c deck) (you-draw c)]
(cond [(memq c deck) (you-draw c)]
[(memq c (player-hand you))
(if (get-discard-card (list c))
(you-discard c)
(bell))]
(if (get-discard-card (list c)) (you-discard c) (bell))]
[else (bell)]))
(unless drag-mode?
@ -559,8 +530,7 @@
players)
;; Opponents's cards and deck initally can't be moved
(for-each
(lambda (card) (send card user-can-move #f))
(for-each (lambda (card) (send card user-can-move #f))
(append
(apply append
(map player-hand (if drag-mode? opponents players)))
@ -589,13 +559,12 @@
(let loop ()
;; Ready deck and/or pass button:
(when (pair? deck)
(when drag-mode?
(send (car deck) user-can-move #t))
(when drag-mode? (send (car deck) user-can-move #t))
(send (car deck) home-region deck-region))
(when (null? deck)
(send t add-region pass-button))
(when (null? deck) (send t add-region pass-button))
;; Tell the player what to do:
(send t set-status (format YOUR-TURN-MESSAGE
(send t set-status
(format YOUR-TURN-MESSAGE
(let ([v (send (car discards) get-value)]
[suit (case (send (car discards) get-suit)
[(hearts) "heart"]
@ -628,49 +597,37 @@
(loop)]
[(discard pass)
;; Hide pass button...
(when (null? deck)
(send t remove-region pass-button))
(when (null? deck) (send t remove-region pass-button))
;; ... and run opponents
(send t set-status "Opponent's turn...")
(unless (null? (player-hand you))
(let oloop ([l opponents])
(cond
[(null? l)
(if (null? l)
;; Check for a stuck game here:
(unless (stuck-game?)
(loop))]
[else (when (play-opponent (car l))
(oloop (cdr l)))])))])))
(unless (stuck-game?) (loop))
(when (play-opponent (car l)) (oloop (cdr l))))))])))
;; Game over: disable player:
(allow-cards #f)
;; Report result:
(send t set-status (cond
[(null? (player-hand you))
GAME-OVER-YOU-WIN]
[(stuck-game?)
GAME-OVER-STUCK]
[else
GAME-OVER]))
(send t set-status (cond [(null? (player-hand you)) GAME-OVER-YOU-WIN]
[(stuck-game?) GAME-OVER-STUCK]
[else GAME-OVER]))
(let ([button
(make-button-region
(+ (region-x discard-region) cw (* 2 MARGIN))
(+ (region-y discard-region) (/ (- ch LABEL-H) 2))
NEW-GAME-W LABEL-H
NEW-GAME (lambda ()
(async-channel-put msg 'new-game)))])
NEW-GAME (lambda () (async-channel-put msg 'new-game)))])
(send t add-region button)
(yield msg)
(send t remove-region button))
(let ([all (send t all-cards)])
;; Gather up cards, with animation
(let ([flip (filter
(lambda (c)
(not (send c face-down?)))
all)])
(let ([flip (filter (lambda (c) (not (send c face-down?))) all)])
(send t flip-cards flip)
(send t move-cards-to-region all deck-region))
;; Reset all cards (no animation)
@ -678,15 +635,11 @@
(send t remove-cards all)
(send t add-cards-to-region all-cards deck-region)
(set! deck (shuffle-list all-cards 7))
(for-each (lambda (c)
(unless (send c face-down?)
(send c flip)))
deck)
(for-each (lambda (c) (unless (send c face-down?) (send c flip))) deck)
(send t stack-cards deck)
(send t end-card-sequence))
;; Re-enable player:
(allow-cards #t)
(gloop)))))
(gloop))))

6
collects/games/crazy8s/doc.txt
View File

@ -1,4 +1,4 @@
** To play _Crazy 8s_, run the "Games" application. **
** To play Crazy 8s, run the "PLT Games" application.
Try to get rid of all you cards by matching the value or suit of the
top card in the discard pile. In the default mode, click a card to
@ -7,8 +7,8 @@ a card from your hand to the discard pile.
An 8 can be discarded at any time, and in that case, the player who
discarded the 8 gets to pick any suit for it (hence the craziness of
8s). When you discard an 8, a panel of buttons appears to the right of
the discard pile, so you can pick the suit.
8s). When you discard an 8, a panel of buttons appears to the right
of the discard pile, so you can pick the suit.
A player can choose to draw a card instead of discarding, as long as
cards are left in the draw pile. A player's turn continues after

1
collects/games/doors/doc.txt
View File

@ -1,4 +1,3 @@
_doors.ss_
The "doors.ss" library builds on "gl-board.ss" to support simple

171
collects/games/games.ss
View File

@ -1,114 +1,97 @@
(module games mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "getinfo.ss" "setup")
(lib "bitmap-label.ss" "mrlib")
"show-help.ss")
#lang scheme/gui
(define game-mapping
(let ([games (let ([d (collection-path "games")])
(filter (lambda (f)
(let ([p (build-path d f)])
(and (directory-exists? p)
(with-handlers ([exn:fail? (lambda (x) #f)])
((get-info (list (string->path "games") f)) 'game (lambda () #f))))))
(directory-list d)))])
(map (lambda (g)
(let ([info (get-info `(,(string->path "games") ,g))])
(list (path->string g)
(info 'game (lambda () "wrong.ss"))
(info 'name (lambda () g))
(require setup/getinfo mrlib/bitmap-label "show-help.ss")
(define-struct game (file name set icon))
(define gamedir (collection-path "games"))
(define (get-game game)
(let* ([game (path-element->string game)]
[info (with-handlers ([exn:fail? (lambda (x) #f)])
(get-info (list "games" game)))]
[main (and info (info 'game (lambda () #f)))]
[gamefile (lambda (f) (build-path gamedir game f))])
(and main
(make-game
(gamefile main)
(info 'name (lambda () (string-titlecase game)))
(info 'game-set (lambda () "Other Games"))
(info 'game-icon (lambda () (build-path (collection-path "games" g)
(format "~a.png" g)))))))
games)))
(info 'game-icon (lambda () (gamefile (format "~a.png" game))))))))
(define (run-game game)
(define c (make-custodian))
(define run
(dynamic-wind
begin-busy-cursor
(lambda ()
(with-handlers ([exn? (lambda (e) (lambda () (raise e)))])
(let ([u (dynamic-require (game-file game) 'game@)])
(lambda () (invoke-unit u)))))
end-busy-cursor))
(parameterize* ([current-custodian c]
[current-namespace (make-gui-empty-namespace)]
[current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(exit-handler (lambda (v) (custodian-shutdown-all c)))
(with-handlers ([exn? (lambda (e)
(message-box (format "Error in \"~a\""
(game-name game))
(exn-message e) f '(ok)))])
(run))))))
(define games
(filter values (map get-game (directory-list gamedir))))
(define game-sets
(let ([ht (make-hash-table 'equal)])
(for ([g games])
(let ([set (game-set g)])
(hash-table-put! ht set (cons g (hash-table-get ht set '())))))
(sort (hash-table-map ht cons)
(lambda (x y)
(let ([xlen (length x)] [ylen (length y)])
(cond [(> xlen ylen) #t]
[(< xlen ylen) #f]
[else (string<? (car x) (car y))]))))))
(define f (new (class frame%
(augment*
[on-close (lambda () (exit))])
(augment* [on-close (lambda () (exit))])
(super-new))
[label "PLT Games"]
[style '(metal no-resize-border)]))
(define hp (make-object horizontal-panel% f))
(define main (make-object vertical-panel% hp))
(define main (make-object horizontal-panel% f))
(send f set-alignment 'left 'top)
(send f stretchable-width #f)
(send f stretchable-height #f)
(define main-horizontal-panel (make-object horizontal-panel% main))
(for ([set game-sets])
(define set-name (car set))
(define games (cdr set))
(define panel
(new group-box-panel% [label set-name] [parent main]))
(define buttons
(map (lambda (game)
(new button%
[label ((bitmap-label-maker (game-name game) (game-icon game))
panel)]
[parent panel]
[callback (lambda _ (run-game game))]))
games))
(define sorted
(sort buttons (lambda (x y) (< (send x min-width) (send y min-width)))))
(send panel change-children (lambda (l) sorted)))
(define (game-button p desc)
(let* ([collect (car desc)]
[file (cadr desc)]
[name (caddr desc)]
[dir (with-handlers ([void (lambda (x) #f)])
(collection-path "games" collect))])
(when dir
(make-object button%
((bitmap-label-maker name (list-ref desc 4))
p)
p
(lambda (b e)
(let ([game@ (dynamic-wind
begin-busy-cursor
(lambda () (dynamic-require (build-path dir file) 'game@))
end-busy-cursor)])
(let ([c (make-custodian)])
(parameterize ([current-custodian c])
(parameterize ([current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(exit-handler (lambda (v)
(custodian-shutdown-all c)))
(invoke-unit game@))))))))))))
(let ([game-mapping (sort game-mapping
(lambda (a b)
(string<? (list-ref a 3) (list-ref b 3))))])
(let loop ([l game-mapping])
(unless (null? l)
(let* ([set (list-ref (car l) 3)]
[p (new group-box-panel%
[label set]
[parent main-horizontal-panel])])
(let xloop ([here (list (car l))]
[l (cdr l)])
(if (and (pair? l)
(string=? set (list-ref (car l) 3)))
(xloop (cons (car l) here) (cdr l))
(begin
(for-each (lambda (g) (game-button p g)) here)
(loop l))))))))
(for-each (lambda (p)
(let ([pred (lambda (x y) (<= (send x min-width) (send y min-width)))])
(send p change-children (lambda (l) (sort l pred)))))
(send main-horizontal-panel get-children))
(send main-horizontal-panel change-children
(lambda (l)
(sort l (lambda (x y)
(let ([l1 (length (send x get-children))]
[l2 (length (send y get-children))])
(cond [(> l1 l2) #t]
[(= l1 l2) (string-ci<? (send x get-label)
(send y get-label))]
[else #f]))))))
(define show-games-help
(show-help '("games") "About PLT Games"))
(define show-games-help (show-help '("games") "About PLT Games"))
(application-about-handler show-games-help)
(application-preferences-handler (lambda ()
(application-preferences-handler
(lambda ()
(message-box
"Oops"
"There aren't actually any preferences. This is just a test for Mac OS X"
f
'(ok))))
(send f show #t))
(send f show #t)

81
collects/games/gcalc/doc.txt
View File

@ -1,4 +1,5 @@
_GCalc_ a system for visually demonstrating the Lambda Calculus.
GCalc is a system for visually demonstrating the Lambda Calculus.
(Not really a game...)
See the following for the principles:
http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
@ -9,30 +10,30 @@ The window layout
-----------------
The window is divided into three working areas, each made of cells.
Cells hold cube objects, which can be dragged between cells (with a few
exceptions that are listed below). The working areas are:
Cells hold cube objects, which can be dragged between cells (with a
few exceptions that are listed below). The working areas are:
1. The right side is the storage area.
This is used for saving objects -- drag any cube to/from here. Note
that cubes can be named for convenience.
1. The right side is the storage area. This is used for saving
objects -- drag any cube to/from here. Note that cubes can be
named for convenience.
2. The left side is a panel of basic color cubes.
These cells always contain a set of basic cubes that are used as the
primitive building blocks all other values are made of. They cannot
be overwritten. (Note that this includes a transparent cell.)
2. The left side is a panel of basic color cubes. These cells always
contain a set of basic cubes that are used as the primitive
building blocks all other values are made of. They cannot be
overwritten. (Note that this includes a transparent cell.)
3. The center part is the working panel.
This is the main panel where new cubes are constructed. The center
cell is similar to a storage cell, and the surrounding eight cells
all perform some operation on this cell.
3. The center part is the working panel. This is the main panel where
new cubes are constructed. The center cell is similar to a storage
cell, and the surrounding eight cells all perform some operation on
this cell.
User Interaction
----------------
Right-click any cell except for the basic colors on the left panel, or
hit escape or F10 for a menu of operations. The menu also includes the
keyboard shortcuts for these operations.
hit escape or F10 for a menu of operations. The menu also includes
the keyboard shortcuts for these operations.
Cube operations
@ -41,38 +42,38 @@ Cube operations
There are six simple operations that are considered part of the simple
graphic cube world. The operations correspond to six of the operation
cells: a left-right composition is built using the left and the right
cells, a top-bottom using the top and the bottom, and a front-back using
the top-left and bottom-right. Dragging a cube to one of these cells
will use the corresponding operator to combine it with the main cell's
cube. Using a right mouse click on one of these cells can be used to
cancel dragging an object to that cell, this is not really an undo
feature: a right-click on the right cell always splits the main cube to
two halves and throws the right side.
cells, a top-bottom using the top and the bottom, and a front-back
using the top-left and bottom-right. Dragging a cube to one of these
cells will use the corresponding operator to combine it with the main
cell's cube. Using a right mouse click on one of these cells can be
used to cancel dragging an object to that cell, this is not really an
undo feature: a right-click on the right cell always splits the main
cube to two halves and throws the right side.
The colored cubes and the six basic operators make this simple domain,
which is extended to form a Lambda-Calculus-like language by adding
abstractions and applications. Right-clicking on a basic cube on the
left panel creates an abstraction which is actually a lambda expression
except that colors are used instead of syntactic variables. For
example, if the main cell contains `R|G' (red-green on the left and
right), then right-clicking the green cube on the left panel leaves us
with `lambda G . R|G', which is visualized as `R|G' with a green circle.
The last two operator cells are used for application of these
abstractions: drag a function to the top-right to have it applied on the
main cube, or to the bottom-left to have the main cube applied to it.
As in the Lambda Calculus, all abstractions have exactly one variable,
use currying for multiple variables.
left panel creates an abstraction which is actually a lambda
expression except that colors are used instead of syntactic variables.
For example, if the main cell contains `R|G' (red-green on the left
and right), then right-clicking the green cube on the left panel
leaves us with `lambda G . R|G', which is visualized as `R|G' with a
green circle. The last two operator cells are used for application of
these abstractions: drag a function to the top-right to have it
applied on the main cube, or to the bottom-left to have the main cube
applied to it. As in the Lambda Calculus, all abstractions have
exactly one variable, use currying for multiple variables.
So far the result is a domain of colored cubes that can be used in the
same way as the simple Lambda Calculus. There is one last extension
that goes one step further: function cubes can themselves be combined
with other functions using the simple operations. This results in
a form of "spatial functions" that behave differently in different parts
with other functions using the simple operations. This results in a
form of "spatial functions" that behave differently in different parts
of the cube according to the construction. For example, a left-right
construction of two functions `f|g' operates on a given cube by applying
`f' on its left part and `g' on its right part. You can use the
preferences dialog to change a few aspects of the computation.
construction of two functions `f|g' operates on a given cube by
applying `f' on its left part and `g' on its right part. You can use
the preferences dialog to change a few aspects of the computation.
Use the "Open Example" menu entry to open a sample file that contains
lots of useful objects (Church numerals, booleans, lists, Y-combinator,
etc).
lots of useful objects (Church numerals, booleans, lists,
Y-combinator, etc).

13
collects/games/gcalc/gcalc.ss
View File

@ -3,15 +3,15 @@
;;; based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
;;; implemented by Eli Barzilay: Maze is Life! (eli@barzilay.org)
(module gcalc mzscheme
#lang mzscheme
(require (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss")
"../show-help.ss" (lib "unit.ss"))
(provide game@)
d
(define customs '())
(define (add-custom! name get set type desc)
(set! customs
(append customs (list (make-custom name get set type desc)))))
(set! customs (append customs (list (make-custom name get set type desc)))))
(define-struct custom (name getter setter type description))
(define-syntax defcustom
(syntax-rules ()
@ -19,8 +19,7 @@
(begin (define var default)
(add-custom! 'var (lambda () var) (lambda (v) (set! var v))
type description))]))
(define game@
(unit (import) (export)
(define game@ (unit (import) (export)
;;;============================================================================
;;; Customizations etc
@ -1025,4 +1024,4 @@
;; start the whole thing
(send gcalc-frame show #t)
)))
))

2
collects/games/ginrummy/doc.txt
View File

@ -1,4 +1,4 @@
** To play _Rummy_, run the "Games" application. **
** To play Rummy, run the "PLT Games" application.
This is a simple variant of Rummy.

184
collects/games/ginrummy/ginrummy.ss
View File

@ -1,5 +1,4 @@
(module ginrummy mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred")
(lib "class.ss")
@ -7,11 +6,7 @@
(lib "list.ss"))
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
;; Initial card count
(define DEAL-COUNT 10)
@ -48,8 +43,7 @@
;; Set up the cards
(define deck (shuffle-list (make-deck) 7))
(for-each
(lambda (card)
(for-each (lambda (card)
(send card user-can-move #f)
(send card user-can-flip #f))
deck)
@ -58,9 +52,7 @@
(define (deal n)
(let loop ([n n][d deck])
(if (zero? n)
(begin
(set! deck d)
null)
(begin (set! deck d) null)
(cons (car d) (loop (sub1 n) (cdr d))))))
;; Card width & height
@ -82,18 +74,11 @@
;; Define the regions
(define machine-region
(make-region
MARGIN MARGIN pw ph
MACHINE-NAME
#f))
(make-region MARGIN MARGIN pw ph MACHINE-NAME #f))
(define you-region
(make-region
MARGIN (- h ph MARGIN) pw ph
YOU-NAME
void))
(make-region MARGIN (- h ph MARGIN) pw ph YOU-NAME void))
(define discard-region
(make-region
(- discard-x MARGIN) (- discard-y MARGIN)
(make-region (- discard-x MARGIN) (- discard-y MARGIN)
(+ cw (* 2 MARGIN)) (+ ch (* 2 MARGIN))
"" #f))
@ -109,8 +94,7 @@
;; Function to inset a region
(define (region->display-region r)
(define m MARGIN)
(make-region
(+ m (region-x r)) (+ m (region-y r))
(make-region (+ m (region-x r)) (+ m (region-y r))
(- (region-w r) (* 2 m)) (- (region-h r) (* 2 m))
#f #f))
@ -120,8 +104,7 @@
(send t move-cards-to-region you-hand (region->display-region you-region))
;; All cards in your hand are movable, but must stay in your region
(for-each
(lambda (card)
(for-each (lambda (card)
(send card home-region you-region)
(send card user-can-move #t))
you-hand)
@ -156,35 +139,33 @@
(and (= 1 (car sorted))
(try (append (cdr sorted) (list 14))))))))))
;; Check how close a hand comes to winning by returning the maximum
;; number of cards that can be arranged into sets. This function is
;; used both to detect gin for the end-of-game condition, and also
;; as part of the machine player's strategy.
;; Check how close a hand comes to winning by returning the maximum number of
;; cards that can be arranged into sets. This function is used both to detect
;; gin for the end-of-game condition, and also as part of the machine player's
;; strategy.
(define (gin-size cards)
(if (<= (length cards) 2)
0
(let* ([sort (lambda (get)
(sort cards (lambda (a b) (< (get a) (get b)))))]
;; It's not reasonable to test every combination of 10 cards,
;; but we can cut down the search space a lot by starting
;; with two different sorts on the card list.
;; It's not reasonable to test every combination of 10 cards, but we
;; can cut down the search space a lot by starting with two
;; different sorts on the card list.
;; We sort by value, to find 3-of-a-kind sets, and by
;; suit-then-value, to find straights. Whatever the
;; best allocation of cards to sets, one of the sets
;; must show up as three cards together in one of the
;; sorted lists. Also, if an extension to that set
;; leads to an optimal allocation, the extended set
;; suit-then-value, to find straights. Whatever the best allocation
;; of cards to sets, one of the sets must show up as three cards
;; together in one of the sorted lists. Also, if an extension to
;; that set leads to an optimal allocation, the extended set
;; corresponds to an extended section of the list.
[value-sorted (sort (lambda (c) (send c get-value)))]
[suit-sorted (sort (lambda (c) (+ (* 20 (send c get-suit-id)) (send c get-value))))]
;; Procedure to find a set allocation given one of the sorted
;; lists. It picks each group of three consecutive items
;; from the list and see how that choice works out.
;; (We're still performing a lot of redundant work here,
;; but it's fast enough.)
;; lists. It picks each group of three consecutive items from the
;; list and see how that choice works out. (We're still performing
;; a lot of redundant work here, but it's fast enough.)
[find-set
(lambda (l)
;; 3loop tries each group of three items
@ -200,32 +181,33 @@
;; No more items? Can't extend the set. Does the
;; set we found work out in the long run?
(+ (length set)
(if (null? pre)
0
(gin-size pre)))]
(if (null? pre) 0 (gin-size pre)))]
;; Try to extend the set...
[(set? (cons (car post) set))
;; The set can be extended.
;; Maybe this extension works in the long run...
;; The set can be extended. Maybe this
;; extension works in the long run...
(max (exloop (cons (car post) set) (cdr post))
;; or maybe without extension works in the long run...
;; or maybe without extension works in
;; the long run...
(+ (length set) (gin-size (append pre post))))]
;; Can't extend the set, so try without extension
;; Can't extend the set, so try without
;; extension
[else (+ (length set)
(gin-size (append pre post)))])))
0)
;; Try next three, if possible
(if (null? post)
0
;; Rotate the group, pulling a new last item in from post
;; and kicking the first item out to pre.
;; Rotate the group, pulling a new last item in from
;; post and kicking the first item out to pre.
(3loop (cons (car group) pre)
(list (cadr group) (caddr group) (car post))
(cdr post))))))])
;; Try the value-sorted list, the the suit-sorted list, then...
(max (find-set value-sorted)
(find-set suit-sorted)
;; the suit-sorted list with with Aces at the end instead of the beginning
;; the suit-sorted list with with Aces at the end instead of the
;; beginning
(let ace-loop ([pre null][l suit-sorted])
(cond
[(null? l)
@ -234,7 +216,8 @@
[(null? (cdr l))
;; No more aces to find
(find-set (reverse (cons (car l) pre)))]
;; Is the front card an ace (before something else of the same suit)?
;; Is the front card an ace (before something else of the same
;; suit)?
[(and (= 1 (send (car l) get-value))
(= (send (car l) get-suit-id) (send (cadr l) get-suit-id)))
;; Ace is at beginning; move it to the end
@ -242,8 +225,7 @@
[ace-suit (send ace get-suit-id)])
(let loop ([pre (cons (cadr l) pre)][l (cddr l)])
;; At end of this suit?
(if (or (null? l)
(> (send (car l) get-suit-id) ace-suit))
(if (or (null? l) (> (send (car l) get-suit-id) ace-suit))
;; At the end; add Ace here
(ace-loop (cons ace pre) l)
;; still looking for new spot for Ace
@ -256,20 +238,19 @@
(define (gin? cards)
(= (gin-size cards) (length cards)))
;; This procedure is the second part of the machine's strategy. If
;; the machine sees two choices that are equally good according to
;; gin-size, then it computes a rating based on pairs, i.e., cards
;; that might eventually go together in a set.
;; This procedure is the second part of the machine's strategy. If the machine
;; sees two choices that are equally good according to gin-size, then it
;; computes a rating based on pairs, i.e., cards that might eventually go
;; together in a set.
(define (pair-rating cards gone-cards)
(let ([suits (map (lambda (card) (send card get-suit-id)) cards)]
[values (map (lambda (card) (send card get-value)) cards)])
;; Its O(n*n), but n is always 10 or 11
(apply +
(map (lambda (suit value)
(apply +
(map (lambda (suit2 value2)
(cond
[(= value value2)
(apply
+ (map (lambda (suit value)
(apply
+ (map (lambda (suit2 value2)
(cond [(= value value2)
(- 2 (count-gone value gone-cards))]
[(= suit suit2)
(rate-straight suit value value2 gone-cards)]
@ -277,11 +258,10 @@
suits values)))
suits values))))
;; count-gone checks how many of a given value are known
;; to be permanently discarded
;; count-gone checks how many of a given value are known to be permanently
;; discarded
(define (count-gone value gone-cards)
(cond
[(null? gone-cards) 0]
(cond [(null? gone-cards) 0]
[(= value (send (car gone-cards) get-value))
(+ 1 (count-gone value (cdr gone-cards)))]
[else (count-gone value (cdr gone-cards))]))
@ -289,34 +269,26 @@
;; count-avail checks whether a given value/suit is
;; known to be discarded (returns 0) or not (returns 1)
(define (count-avail value suit gone-cards)
(cond
[(null? gone-cards) 1]
(cond [(null? gone-cards) 1]
[(and (= value (send (car gone-cards) get-value))
(= suit (send (car gone-cards) get-suit-id)))
0]
[else (count-avail value suit (cdr gone-cards))]))
;; rates the possibility for forming a straight given
;; two card values in a particular suit, and taking
;; into account cards known to be discarded; the
;; rating is the number of non-discarded cards that
;; would form a straight with the given values
;; rates the possibility for forming a straight given two card values in a
;; particular suit, and taking into account cards known to be discarded; the
;; rating is the number of non-discarded cards that would form a straight with
;; the given values
(define (rate-straight suit value value2 gone-cards)
(let ([v1 (if (= value 1)
(if (value2 . > . 6)
14
1)
(if (value2 . > . 6) 14 1)
value)]
[v2 (if (= value2 1)
(if (value . > . 6)
14
1)
(if (value . > . 6) 14 1)
value2)])
(let ([delta (abs (- v1 v2))])
(cond
[(= delta 1)
(cond
[(or (= v1 1) (= v2 1))
(cond [(= delta 1)
(cond [(or (= v1 1) (= v2 1))
;; Might get the 3?
(count-avail 3 suit gone-cards)]
[(or (= v1 14) (= v2 14))
@ -338,9 +310,9 @@
;; The procedure implements the machine's card-drawing choice
(define (machine-wants-card? machine-hand card gone-cards)
;; Simple strategy: the machine wants the card if taking it will
;; make the gin-size of its hand increase, or if taking it will not
;; make the gin-size decrease but will increase the pair rating.
;; Simple strategy: the machine wants the card if taking it will make the
;; gin-size of its hand increase, or if taking it will not make the gin-size
;; decrease but will increase the pair rating.
(let* ([orig-size (gin-size machine-hand)]
[new-hand (remq (machine-discard (cons card machine-hand) gone-cards)
(cons card machine-hand))]
@ -352,19 +324,18 @@
;; The procedure implements the machine's discard choice
(define (machine-discard machine-hand gone-cards)
;; Discard the card that leaves the hand with the largest
;; gin-size. If multiple cards leave the same largest gin size,
;; pick card leaving the best pair rating.
;; Discard the card that leaves the hand with the largest gin-size. If
;; multiple cards leave the same largest gin size, pick card leaving the best
;; pair rating.
(let* ([gin-size-card-pairs
(map (lambda (card) (cons (gin-size (remq card machine-hand))
card))
(map (lambda (card) (cons (gin-size (remq card machine-hand)) card))
machine-hand)]
[most (apply max (map car gin-size-card-pairs))]
[best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)]
[best-cards (map cdr best)]
[rating-card-pairs
(map (lambda (card) (cons (pair-rating (remq card machine-hand) gone-cards)
card))
(map (lambda (card)
(cons (pair-rating (remq card machine-hand) gone-cards) card))
best-cards)]
[most (apply max (map car rating-card-pairs))]
[best (filter (lambda (x) (= most (car x))) rating-card-pairs)])
@ -375,10 +346,10 @@
;; This procedure finalizes the display when the game is over
(define (end-of-game why)
(send t set-status-text
(format "~aGame over. ~a."
(format
"~aGame over. ~a."
why
(cond
[(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal
(cond [(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal
[(gin? you-hand) "You win"]
[else "Opponent wins"])))
(send t cards-face-up machine-hand))
@ -401,7 +372,8 @@
(let loop ()
(check-empty-deck)
;; Your turn; you can select the top card on the deck or on the discard pile
;; Your turn; you can select the top card on the deck or on the discard
;; pile
(send (car discards) user-can-move #t)
(send (car discards) snap-back-after-move #t)
(send (car deck) user-can-move #t)
@ -430,9 +402,9 @@
(send (car discards) home-region #f))
(set-region-callback! you-region #f)
(set-region-interactive-callback! you-region #f)))
;; Interactive callback: change home of card if region is hilited.
;; As a result, the card snaps to where you put it instead of back
;; to its original position.
;; Interactive callback: change home of card if region is hilited. As a
;; result, the card snaps to where you put it instead of back to its
;; original position.
(set-region-interactive-callback!
you-region
(lambda (on? cards)
@ -469,8 +441,7 @@
(set-region-interactive-callback!
discard-region
(lambda (on? cards)
(send (car cards) home-region
(if on? discard-region you-region))))
(send (car cards) home-region (if on? discard-region you-region))))
;; Wait for action
(yield something-happened))
@ -509,5 +480,6 @@
(end-of-game "")
;; Next turn
(loop)))))))))
(loop))))))
))

36
collects/games/gobblet/doc.txt
View File

@ -1,4 +1,4 @@
** To play _Goblet_, run the "Games" application. **
** To play Goblet, run the "PLT Games" application.
"Gobblet!" is a board game from Blue Orange Games:
http://www.blueorangegames.com/
@ -28,14 +28,14 @@ The 3x3 game is a generalization of tic-tac-toe:
* A piece can be placed (or moved to) an empty space, or it can be
placed/moved on top of a smaller piece already on the board,
"gobbling" the smaller piece. The smaller piece does not have to be
an opponent's piece, and the smaller piece may itself have gobbled
another piece previously.
"gobbling" the smaller piece. The smaller piece does not have to
be an opponent's piece, and the smaller piece may itself have
gobbled another piece previously.
* Only visible pieces can be moved, and only visible pieces count
toward winning. Gobbled pieces stay on the board, however, and when
a piece is moved, any piece that it gobbled stays put and becomes
visible.
toward winning. Gobbled pieces stay on the board, however, and
when a piece is moved, any piece that it gobbled stays put and
becomes visible.
* If moving a piece exposes a winning sequence for the opponent, and
if the destination for the move does not cover up one of the other
@ -45,8 +45,8 @@ The 3x3 game is a generalization of tic-tac-toe:
* Technically, if a player touches a piece, then the piece must be
moved on that turn. In other words, you're not allowed to peek
under a piece to remind yourself whether it gobbled anything. If
the piece can't be moved, the player forfeits. This particular rule
is not enforced by our version --- in part because our version
the piece can't be moved, the player forfeits. This particular
rule is not enforced by our version --- in part because our version
supports a rewind button, which is also not in the official game.
The 4x4 game has a few changes:
@ -82,21 +82,21 @@ slightly different way than zooming.) Depending on how keyboard focus
works on your machine, you may have to click the board area to make
these controls work.
The button labeled "<" at the bottom of the window rewinds the game
by one turn. The button labeled ">" re-plays one turn in a rewound
game. An alternate move can be made at any point in a rewound game,
The button labeled "<" at the bottom of the window rewinds the game by
one turn. The button labeled ">" re-plays one turn in a rewound game.
An alternate move can be made at any point in a rewound game,
replacing the old game from that point on.
Auto-Play
---------
Turn on a computer player at any time by checking the "Auto-Play Red"
or "Auto-Play Yellow" checkbox. If you rewind the game, you can choose
an alternate move for yourself or for the auto-player to find out what
would have happened. The auto-player is not always deterministic, so
replying the same move might lead to a different result. You can
disable an auto-player at any point by unchecking the corresponding
"Auto-Play" checkbox.
or "Auto-Play Yellow" checkbox. If you rewind the game, you can
choose an alternate move for yourself or for the auto-player to find
out what would have happened. The auto-player is not always
deterministic, so replying the same move might lead to a different
result. You can disable an auto-player at any point by unchecking the
corresponding "Auto-Play" checkbox.
Important: In the 3x3 game, you CANNOT win as yellow against the smart
auto-player (if the auto-player is allowed to play red from the start

28
collects/games/gobblet/gobblet.ss
View File

@ -1,4 +1,4 @@
(module gobblet mzscheme
#lang mzscheme
(require (lib "unitsig.ss")
(only (lib "unit.ss") unit import export)
(lib "file.ss")
@ -13,18 +13,16 @@
(provide game@)
(define game@
(unit
(import)
(export)
(unit (import) (export)
(define (make-gobblet-unit size)
(compound-unit/sig
(import)
(link [CONFIG : config^ ((unit/sig config^
(import)
(link [CONFIG : config^
((unit/sig config^ (import)
(define BOARD-SIZE size)))]
[RESTART : restart^ ((unit/sig restart^
(import)
[RESTART : restart^
((unit/sig restart^ (import)
(define (new-game n)
(put-preferences '(gobblet:board-size) (list n) void)
(parameterize ([current-eventspace orig-eventspace])
@ -51,12 +49,12 @@
(define (start-gobblet board-size)
;; Start a new game as a child process:
(parameterize ([current-custodian (make-custodian)])
(parameterize ([exit-handler (lambda (v)
(custodian-shutdown-all (current-custodian)))])
(parameterize ([current-eventspace (make-eventspace)])
(parameterize* ([current-custodian (make-custodian)]
[exit-handler
(lambda (v)
(custodian-shutdown-all (current-custodian)))]
[current-eventspace (make-eventspace)])
(queue-callback
(lambda ()
(invoke-unit/sig (make-gobblet-unit board-size))))))))
(lambda () (invoke-unit/sig (make-gobblet-unit board-size))))))
(start-gobblet (get-preference 'gobblet:board-size (lambda () 3))))))
(start-gobblet (get-preference 'gobblet:board-size (lambda () 3)))))

2
collects/games/gofish/doc.txt
View File

@ -1,4 +1,4 @@
** To play _Go Fish_, run the "Games" application. **
** To play Go Fish, run the "PLT Games" application.
Go Fish is the children's card game where you try to get rid of all
you cards by forming pairs. You play against two computer players.

88
collects/games/gofish/gofish.ss
View File

@ -1,5 +1,4 @@
(module gofish mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred")
(lib "class.ss")
@ -7,11 +6,7 @@
(lib "list.ss"))
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
;; Player record
(define-struct player (r hand-r discard-r count-r ; regions
@ -27,8 +22,10 @@
(define DEAL-COUNT 7)
;; Messages
(define YOUR-TURN-MESSAGE "Your turn. (Drag a match to your discard box or drag a card to an opponent.)")
(define GO-FISH-MESSAGE "Go Fish! (Drag a card from the center deck to your box.)")
(define YOUR-TURN-MESSAGE
"Your turn. (Drag a match to your discard box or drag a card to an opponent.)")
(define GO-FISH-MESSAGE
"Go Fish! (Drag a card from the center deck to your box.)")
(define MATCH-MESSAGE "Match!")
(define GAME-OVER-MESSAGE "GAME OVER")
@ -56,8 +53,7 @@
;; Set up the cards
(define deck (shuffle-list (make-deck) 7))
(for-each
(lambda (card)
(for-each (lambda (card)
(send card snap-back-after-move #t)
(send card user-can-flip #f))
deck)
@ -66,9 +62,7 @@
(define (deal n)
(let loop ([n n][d deck])
(if (zero? n)
(begin
(set! deck d)
null)
(begin (set! deck d) null)
(cons (car d) (loop (sub1 n) (cdr d))))))
;; Card width & height
@ -76,10 +70,7 @@
(define ch (send (car deck) card-height))
;; Put the cards on the table
(send t add-cards
deck
(/ (- w cw) 2)
(- (/ (- h ch) 2) (/ ch 3)))
(send t add-cards deck (/ (- w cw) 2) (- (/ (- h ch) 2) (/ ch 3)))
;; Player region size
(define pw (- (/ (- w cw) 2) (* 2 MARGIN)))
@ -88,13 +79,11 @@
;; Region-makers
(define (make-hand-region r)
(define m SUBMARGIN)
(make-region
(+ m (region-x r)) (+ LABEL-H m (region-y r))
(make-region (+ m (region-x r)) (+ LABEL-H m (region-y r))
(- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m))
#f #f))
(define (make-discard-region r)
(make-region
(- (+ (region-x r) (region-w r)) SUBMARGIN cw)
(make-region (- (+ (region-x r) (region-w r)) SUBMARGIN cw)
(- (+ (region-y r) (region-h r)) SUBMARGIN ch)
cw ch
#f #f))
@ -108,20 +97,11 @@
;; Define the initial regions
(define player-1-region
(make-region
MARGIN MARGIN pw ph
PLAYER-1-NAME
void))
(make-region MARGIN MARGIN pw ph PLAYER-1-NAME void))
(define player-2-region
(make-region
(- w MARGIN pw) MARGIN pw ph
PLAYER-2-NAME
void))
(make-region (- w MARGIN pw) MARGIN pw ph PLAYER-2-NAME void))
(define you-region
(make-region
MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph
YOUR-NAME
void))
(make-region MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph YOUR-NAME void))
;; Player setup
(define (create-player r discard-callback)
@ -135,26 +115,23 @@
null)])
(send t add-region r)
(send t add-region (player-count-r p))
(for-each (lambda (card) (send t card-to-front card)) (reverse (player-hand p)))
(for-each (lambda (card)
(send t card-to-front card)) (reverse (player-hand p)))
(send t move-cards-to-region (player-hand p) (player-hand-r p))
p))
(define player-1 (create-player player-1-region #f))
(define player-2 (create-player player-2-region #f))
(define you (create-player you-region
;; Dragging to your discard pile checks to see if the card
;; makes a match:
;; Dragging to your discard pile checks to see if
;; the card makes a match:
(lambda (cards)
(check-hand you (car cards))
(send t set-status YOUR-TURN-MESSAGE))))
;; More card setup: Opponents's cards and deck initally can't be moved
(for-each
(lambda (card) (send card user-can-move #f))
(append
(player-hand player-1)
(player-hand player-2)
deck))
(for-each (lambda (card) (send card user-can-move #f))
(append (player-hand player-1) (player-hand player-2) deck))
;; More card setup: Show your cards
(send t flip-cards (player-hand you))
@ -196,9 +173,8 @@
;; The players has a match! Move the card from the player's hand
;; to his discard pile
(set-player-hand! player (remove* (list card found) h))
(set-player-discarded! player (cons found
(cons card
(player-discarded player))))
(set-player-discarded! player
(list* found card (player-discarded player)))
;; The dicarded cards can no longer be moved
(send card user-can-move #f)
(send found user-can-move #f)
@ -210,8 +186,7 @@
;; Function to enable/disable moving your cards
(define (enable-your-cards on?)
(for-each (lambda (c) (send c user-can-move on?))
(player-hand you)))
(for-each (lambda (c) (send c user-can-move on?)) (player-hand you)))
;; Callbacks communicate back to the main loop via these
(define something-happened (make-semaphore 1))
@ -308,13 +283,12 @@
;; Function to check for end-of-game
(define (check-done k)
(if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you))
(begin
(enable-your-cards #f)
(begin (enable-your-cards #f)
(send t set-status GAME-OVER-MESSAGE))
(k)))
;; Look in opponents' initial hands for matches
;; (Since each player gets 7 cards, it's impossible to run out of cards this way)
;; Look in opponents' initial hands for matches (Since each player gets 7
;; cards, it's impossible to run out of cards this way)
(define (find-initial-matches player)
(when (ormap (lambda (card) (check-hand player card)) (player-hand player))
;; Found a match in the hand
@ -335,8 +309,7 @@
;; No more cards; pass
#f
;; Draw a card (wait for the user to drag it)
(begin
(send t set-status GO-FISH-MESSAGE)
(begin (send t set-status GO-FISH-MESSAGE)
(wiggle-top-card)
(enable-your-cards #f)
(set-region-callback! (player-r player-1) #f)
@ -347,13 +320,10 @@
(enable-your-cards #t)
(check-hand you (car (player-hand you)))))
(check-done loop)
(begin
(send t set-status PLAYER-1-NAME)
(begin (send t set-status PLAYER-1-NAME)
(simulate-player
player-1 player-2
(lambda ()
(send t set-status PLAYER-2-NAME)
(simulate-player player-2 player-1 loop))))))
(check-done loop))))))
(check-done loop)))))

15
collects/games/jewel/doc.txt
View File

@ -1,8 +1,8 @@
** To play _Jewel_, run the "Games" application. **
** To play Jewel, run the "PLT Games" application.
The board is an 8x8 array of jewels of 7 types. You need to get 3 or
more in a row horizontally or vertically in order to score points. You
can swap any two jewels that are next to each other up and down or
more in a row horizontally or vertically in order to score points.
You can swap any two jewels that are next to each other up and down or
left and right. The mechanic is to either:
* Click the mouse on the first one, then drag in the direction for
@ -19,12 +19,11 @@ left. When it counts down to 0 the game is over. Getting 3 in a row
adds time to the clock.
Hit spacebar to start a new game then select the difficulty number by
pressing '0', '1', '2', '3' or '4'. You can always press 'ESC' to exit.
During playing press 'p' to pause the game.
pressing '0', '1', '2', '3' or '4'. You can always press 'ESC' to
exit. During playing press 'p' to pause the game.
The code is released under the LGPL.
The code is a conversion of Dave Ashley's C program to Scheme with some
modifications and enhancements.
The code is released under the LGPL. The code is a conversion of Dave
Ashley's C program to Scheme with some modifications and enhancements.
Enjoy.

8
collects/games/lights-out/doc.txt
View File

@ -1,7 +1,7 @@
_Lights Out_
** To play Lights Out, run the "PLT Games" application.
The object of this game is to turn all of the lights off. Click on a button
to turn that light off, but beware it will also toggle the lights above,
below to the left and to the right of that button.
The object of this game is to turn all of the lights off. Click on a
button to turn that light off, but beware it will also toggle the
lights above, below to the left and to the right of that button.
Good luck.

84
collects/games/lights-out/lights-out.ss
View File

@ -1,19 +1,15 @@
(module lights-out mzscheme
#lang mzscheme
(require "board.ss"
"../show-help.ss"
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "unit.ss"))
(provide game@
lights-out^)
(provide game@ lights-out^)
(define-signature lights-out^
(init-board))
(define-signature lights-out^ (init-board))
(define game@
(unit
(import)
(define game@ (unit (import)
(export lights-out^) ;; : (board -> void) resets the window(s)
(define frame (make-object frame% "Lights Out"))
@ -83,30 +79,21 @@
(let ([ent (vector-ref (vector-ref current-board j) i)]
[dull? (and dull-i
dull-j
(or (and (= i dull-i)
(= j dull-j))
(and (= i (- dull-i 1))
(= j dull-j))
(and (= i (+ dull-i 1))
(= j dull-j))
(and (= i dull-i)
(= j (- dull-j 1)))
(and (= i dull-i)
(= j (+ dull-j 1)))))])
(or (and (= i dull-i) (= j dull-j))
(and (= i (- dull-i 1)) (= j dull-j))
(and (= i (+ dull-i 1)) (= j dull-j))
(and (= i dull-i) (= j (- dull-j 1)))
(and (= i dull-i) (= j (+ dull-j 1)))))])
(if dull?
(if (eq? ent 'x)
(begin
(send dc set-pen dull-off-pen)
(begin (send dc set-pen dull-off-pen)
(send dc set-brush dull-off-brush))
(begin
(send dc set-pen dull-on-pen)
(begin (send dc set-pen dull-on-pen)
(send dc set-brush dull-on-brush)))
(if (eq? ent 'x)
(begin
(send dc set-pen on-pen)
(begin (send dc set-pen on-pen)
(send dc set-brush on-brush))
(begin
(send dc set-pen off-pen)
(begin (send dc set-pen off-pen)
(send dc set-brush off-brush)))))
(let-values ([(x y w h) (tile->screen i j)])
(send dc draw-rectangle x y w h))))]
@ -123,18 +110,14 @@
(lambda ()
(let* ([dc (get-dc)])
(let loop ([j (vector-length current-board)])
(cond
[(zero? j) (void)]
[else
(let loop ([i (vector-length current-board)])
(cond
[(zero? i) (void)]
[else
(draw-tile dc
(- i 1)
(- j 1))
(loop (- i 1))]))
(loop (- j 1))]))))]
(if (zero? j)
(void)
(begin (let loop ([i (vector-length current-board)])
(if (zero? i)
(void)
(begin (draw-tile dc (- i 1) (- j 1))
(loop (- i 1)))))
(loop (- j 1)))))))]
[define/override on-event
(lambda (evt)
@ -162,8 +145,7 @@
(lambda ()
(send (get-dc) clear)
(redraw))]
(super-instantiate ()
(parent frame))))
(super-instantiate () (parent frame))))
(define board-canvas (make-object board-canvas%))
(send board-canvas min-width 100)
@ -191,22 +173,14 @@
(lambda x
(init-board original-board)))
(let ([help (show-help
(list "games" "lights-out")
"Lights Out Help")])
(make-object button% "Help" button-panel
(lambda x
(help))))
(let ([help (show-help (list "games" "lights-out") "Lights Out Help")])
(make-object button% "Help" button-panel (lambda x (help))))
(make-object grow-box-spacer-pane% button-panel)
(send button-panel stretchable-height #f)
(init-board (random-board (+ 3
(random 2)
(random 2)
(random 2)
(random 2)
(random 2))))
;(send frame stretchable-width #f)
;(send frame stretchable-height #f)
(send frame show #t))))
(init-board (random-board
(+ 3 (random 2) (random 2) (random 2) (random 2) (random 2))))
;; (send frame stretchable-width #f)
;; (send frame stretchable-height #f)
(send frame show #t)))

40
collects/games/memory/memory.ss
View File

@ -1,5 +1,4 @@
(module memory mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred")
(lib "class.ss")
@ -8,10 +7,7 @@
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
;; Layout width and height:
(define WIDTH 5)
@ -33,7 +29,8 @@
;; Set up the cards
(define deck
(let ([cards (map (lambda (name value)
(let ([bm (make-object bitmap%
(let ([bm (make-object
bitmap%
(build-path
(collection-path "games" "memory" "images")
(format "~a.png" name)))])
@ -44,8 +41,7 @@
"jack" "star")
'(1 2 3 4 5 6 7 8 9 10))])
(append cards (map (lambda (c) (send c copy)) cards))))
(for-each
(lambda (card)
(for-each (lambda (card)
(send card user-can-move #f)
(send card user-can-flip #t))
deck)
@ -86,8 +82,7 @@
(define card-1 #f)
(define (flip-and-match c)
(cond
[(eq? c card-1)
(cond [(eq? c card-1)
;; Cancel first card
(send t flip-card c)
(set! card-1 #f)]
@ -103,14 +98,11 @@
(send t flip-card c)
(send t card-to-front c)
(run-timer)
(cond
[(not card-1)
(cond [(not card-1)
;; That was the first card
(set! card-1 c)]
[(and (equal? (send card-1 get-value)
(send c get-value))
(equal? (send card-1 get-suit)
(send c get-suit)))
[(and (equal? (send card-1 get-value) (send c get-value))
(equal? (send card-1 get-suit) (send c get-suit)))
;; Match
(send t pause 0.5)
(send t move-cards (list card-1 c) match-x match-y)
@ -148,19 +140,15 @@
(send t end-card-sequence))
(define (get-update-delta)
;; Figure out how many milliseconds to sleep before the next update
(max 0
(inexact->exact
(floor
(- (+ start-time (* 1000 shown-seconds) 1000)
(max 0 (inexact->exact (floor (- (+ start-time (* 1000 shown-seconds) 1000)
(current-inexact-milliseconds))))))
(define time-timer
(make-object timer% (lambda ()
(make-object timer%
(lambda ()
(unless (= matches MAX-MATCHES)
(show-time
(inexact->exact
(floor (/ (- (current-inexact-milliseconds)
start-time)
1000))))
(floor (/ (- (current-inexact-milliseconds) start-time) 1000))))
(send time-timer start (get-update-delta) #t)))))
(define (reset-timer)
(send time-timer stop)
@ -173,4 +161,4 @@
;; Start the game:
(send t pause 0.25)
(setup))))
(setup)))

118
collects/games/mines/mines.ss
View File

@ -3,7 +3,7 @@
;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;;
(module mines mzscheme
#lang mzscheme
(require (lib "etc.ss") ; defines build-vector
(lib "class.ss")
@ -54,11 +54,9 @@
(loop (add1 n) (accum a (f n)))
a)))
;; The rest of the game is implemented in a unit so it can be started multiple times
(define game@
(unit
(import)
(export)
;; The rest of the game is implemented in a unit so it can be started
;; multiple times
(define game@ (unit (import) (export)
;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;;
@ -70,21 +68,11 @@
(define area-hilite 'none) ; 'none, 'local, 'near
(public*
[set-state
(lambda (newstate)
(set! state newstate))]
[get-state
(lambda ()
state)]
[set-neighbor-bomb-count
(lambda (c)
(set! neighbor-bomb-count c))]
[get-neighbor-bomb-count
(lambda ()
neighbor-bomb-count)]
[set-area-hilite
(lambda (mode)
(set! area-hilite mode))]
[set-state (lambda (newstate) (set! state newstate))]
[get-state (lambda () state)]
[set-neighbor-bomb-count (lambda (c) (set! neighbor-bomb-count c))]
[get-neighbor-bomb-count (lambda () neighbor-bomb-count)]
[set-area-hilite (lambda (mode) (set! area-hilite mode))]
[draw-text-tile
(lambda (dc x y w h hilite border? str color)
(if border?
@ -97,12 +85,10 @@
[(local) local-bm]
[else tile-bm])])
x y)
(begin
(send dc set-pen BG-PEN)
(begin (send dc set-pen BG-PEN)
(send dc draw-rectangle x y w h)))
(when str
(cond
[(string? str)
(cond [(string? str)
(send dc set-text-foreground (or color FG-COLOR))
;; Draw text centered in the tile's box:
(let-values ([(tw th d a) (send dc get-text-extent str)])
@ -118,7 +104,8 @@
[(covered) (draw-text-tile dc x y w h hilite #t #f #f)]
[(flagged) (draw-text-tile dc x y w h hilite #t flag-bm #f)]
[(semi-flagged) (draw-text-tile dc x y w h hilite #t "?" #f)]
[(uncovered) (draw-text-tile
[(uncovered)
(draw-text-tile
dc x y w h #f #f
(if (zero? neighbor-bomb-count)
#f
@ -134,9 +121,7 @@
(define explode-source? #f) ; draw this bomb as the one that exploded?
(public*
[set-explode-source
(lambda (s?)
(set! explode-source? s?))])
[set-explode-source (lambda (s?) (set! explode-source? s?))])
(override*
[draw
@ -178,17 +163,12 @@
(define (count-surrounding-bombs x y)
(do-surrounding
x y + 0 0
(lambda (dx dy)
(if (is-bomb? (get-tile (+ x dx) (+ y dy)))
1
0))))
(lambda (dx dy) (if (is-bomb? (get-tile (+ x dx) (+ y dy))) 1 0))))
(define (for-each-tile f)
(step-while 0 < B-WIDTH
(lambda (x)
(step-while 0 < B-HEIGHT
(lambda (y)
(f (get-tile x y) x y))
(step-while 0 < B-HEIGHT (lambda (y) (f (get-tile x y) x y))
void (void)))
void (void)))
@ -198,8 +178,7 @@
(build-vector B-WIDTH
(lambda (i)
(build-vector B-HEIGHT
(lambda (j)
(make-object tile:plain%))))))
(lambda (j) (make-object tile:plain%))))))
;; Randomly insert bombs
(let loop ([n THE-BOMB-COUNT])
(unless (zero? n)
@ -221,7 +200,8 @@
;; ;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;;
;; Make a frame:
(define frame (instantiate
(define frame
(instantiate
(class frame%
(augment*
[on-close ; stop the timer, in case it's running
@ -240,10 +220,12 @@
(send p set-alignment 'center 'center)
p))
(define time-display (make-object message% "Time: 00000" (make-centering-pane panel)))
(define time-display
(make-object message% "Time: 00000" (make-centering-pane panel)))
(make-object button% "Reset" (make-centering-pane panel)
(lambda (b e) (send board-canvas reset)))
(define count-display (make-object message% "Count: 000" (make-centering-pane panel)))
(define count-display
(make-object message% "Count: 000" (make-centering-pane panel)))
(define (set-time t)
(send time-display set-label (string-append "Time: " (number->string t))))
@ -297,15 +279,12 @@
(stop-timer)
(set! ready? #f)
(set! start-time #f)
(unless win?
(show-all-bombs))
(unless win? (show-all-bombs))
(set-count THE-BOMB-COUNT))]
[explode ; stop the game because the player hit a bomb
(lambda ()
(end-of-game #f))]
(lambda () (end-of-game #f))]
[win ; stop the game because the player won
(lambda ()
(end-of-game #t))]
(lambda () (end-of-game #t))]
[reset ; quit the current game and reset the board
(lambda ()
(stop-timer)
@ -338,8 +317,7 @@
(unless (eq? state 'uncovered)
(change-state t state 'uncovered #t)
(paint-one t x2 y2)
(when (zero? nc)
(autoclick-surrounding x2 y2)))))))]
(when (zero? nc) (autoclick-surrounding x2 y2)))))))]
[change-state ; update counters after a tile changes
(lambda (t old-state new-state update-count?)
(send t set-state new-state)
@ -358,22 +336,17 @@
(lambda (x y flag?)
(let* ([t (get-tile x y)]
[state (send t get-state)]
[new-state
(case state
[(covered)
(if flag? 'flagged 'uncovered)]
[(flagged)
(if flag? 'semi-flagged state)]
[(semi-flagged)
(if flag? 'covered 'uncovered)]
[new-state (case state
[(covered) (if flag? 'flagged 'uncovered)]
[(flagged) (if flag? 'semi-flagged state)]
[(semi-flagged) (if flag? 'covered 'uncovered)]
[else state])]
[nc (send t get-neighbor-bomb-count)]
[new-uncover? (and (eq? new-state 'uncovered)
(not (eq? state 'uncovered)))]
[bomb? (is-bomb? t)])
(change-state t state new-state #t)
(when (and new-uncover? bomb?)
(send t set-explode-source #t))
(when (and new-uncover? bomb?) (send t set-explode-source #t))
(paint-one t x y)
(when new-uncover?
(if bomb?
@ -382,20 +355,19 @@
(if (zero? nc)
(autoclick-surrounding x y)
(set-near-hilite t x y))))
(when (and ready? (= cover-count THE-BOMB-COUNT))
(win)))))]
(when (and ready? (= cover-count THE-BOMB-COUNT)) (win)))))]
[paint-one ; draw one tile
(lambda (t x y)
(let ([xloc (* x TILE-HW)]
[yloc (* y TILE-HW)])
(send t draw dc xloc yloc TILE-HW TILE-HW
(and (eq? t clicking)
(if clicking-right? 'right 'left)))))]
(and (eq? t clicking) (if clicking-right? 'right 'left)))))]
[set-near-hilite
(lambda (t x y)
(set! area-hilite t)
(set! area-hilites
(do-surrounding x y append null null
(do-surrounding
x y append null null
(lambda (dx dy)
(let* ([x (+ x dx)]
[y (+ y dy)]
@ -423,12 +395,9 @@
(when (send e button-down?)
(start-timer)))
;; Find the time for an (x,y) pixel position in the canvas
(let* ([x (quotient (inexact->exact (floor (send e get-x)))
TILE-HW)]
[y (quotient (inexact->exact (floor (send e get-y)))
TILE-HW)]
[t (if (and (< -1 x B-WIDTH)
(< -1 y B-HEIGHT))
(let* ([x (quotient (inexact->exact (floor (send e get-x))) TILE-HW)]
[y (quotient (inexact->exact (floor (send e get-y))) TILE-HW)]
[t (if (and (< -1 x B-WIDTH) (< -1 y B-HEIGHT))
(get-tile x y)
#f)]) ; not a tile
(cond
@ -453,7 +422,8 @@
(set! clicking-x x)
(set! clicking-y y)
(when (send e button-down?)
(set! clicking-right? (or (send e button-down? 'right)
(set! clicking-right?
(or (send e button-down? 'right)
(send e get-control-down)
(send e get-alt-down)
(send e get-meta-down))))
@ -482,8 +452,7 @@
(paint-one t x y))]
[else (clear-area-hilite)]))))]
[on-paint ; refresh the board
(lambda ()
(for-each-tile (lambda (tile x y) (paint-one tile x y))))])
(lambda () (for-each-tile (lambda (tile x y) (paint-one tile x y))))])
(super-instantiate (frame))
@ -505,5 +474,4 @@
(define board-canvas (make-object board-canvas% frame))
;; Show the frame (and handle events):
(send frame show #t))))
(send frame show #t)))

44
collects/games/paint-by-numbers/doc.txt
View File

@ -1,28 +1,30 @@
** To play _Paint By Numbers_, run the "Games" application. **
** To play Paint By Numbers, run the "PLT Games" application.
The object of Paint By Numbers is to discover which cells should be
colored blue and which should be colored white. Initially, all squares are
grey, indicating that the correct colors are not known. The lists of
numbers to the left and above the grid are your clues to the correct color
of each square. Each list of numbers specifies the pattern of blue squares
in the row beside it or the column below it. Each number indicates the
length of a group of blue squares. For example, if the list of numbers
beside the first row is "2 3" then you know that there is a contiguous
block of two blue squares followed by a contiguous block of three blue
squares with at least one white square between them. The label does not
tell you where the blue squares are, only their shapes. The trick is to
gather as much information as you can about each row, and then use that
information to determine more about each column. Eventually you should be
able to fill in the entire puzzle.
colored blue and which should be colored white. Initially, all
squares are grey, indicating that the correct colors are not known.
The lists of numbers to the left and above the grid are your clues to
the correct color of each square. Each list of numbers specifies the
pattern of blue squares in the row beside it or the column below it.
Each number indicates the length of a group of blue squares. For
example, if the list of numbers beside the first row is "2 3" then you
know that there is a contiguous block of two blue squares followed by
a contiguous block of three blue squares with at least one white
square between them. The label does not tell you where the blue
squares are, only their shapes. The trick is to gather as much
information as you can about each row, and then use that information
to determine more about each column. Eventually you should be able to
fill in the entire puzzle.
Click on a square to toggle it between blue and gray. Hold down a modifier
key (shift, command, meta, or alt depending on the platform) to toggle a
square between white and gray. The third button under unix and the right
button under windows also toggles between white and gray.
Click on a square to toggle it between blue and gray. Hold down a
modifier key (shift, command, meta, or alt depending on the platform)
to toggle a square between white and gray. The third button under
unix and the right button under windows also toggles between white and
gray.
For some puzzles, hints are available. Choose the Nongram|Show Mistakes
menu item to receive the hints. This will turn all incorrectly colored
squares red.
For some puzzles, hints are available. Choose the Nongram|Show
Mistakes menu item to receive the hints. This will turn all
incorrectly colored squares red.
Thanks to Shoichiro Hattori for his puzzles! Visit him on the web at:

71
collects/games/parcheesi/doc.txt
View File

@ -1,52 +1,47 @@
_Parcheesi_
** To play Parcheesi, run the "PLT Games" application.
Parcheesi is a race game for four players. The goal is for
each player to move their pieces from the starting position
(the circles in the corners) to the home square (in the
center of the board), passing a nearly complete loop around
the board in the counter-clockwise direction and then heads
up towards the main row. For example, the green player
enters from the bottom right, travels around the board on
the light blue squares, passing each of the corners, until
it reaches the middle of the bottom of the board, where it
turns off the light blue squares and heads into the central
region.
Parcheesi is a race game for four players. The goal is for each
player to move their pieces from the starting position (the circles in
the corners) to the home square (in the center of the board), passing
a nearly complete loop around the board in the counter-clockwise
direction and then heads up towards the main row. For example, the
green player enters from the bottom right, travels around the board on
the light blue squares, passing each of the corners, until it reaches
the middle of the bottom of the board, where it turns off the light
blue squares and heads into the central region.
On each turn, the player rolls two dice and advances the
pawn, based on the die rolls. Typically the players may move
a pawn for each die. The pawn moves by the number of pips
showing on the die and all of the dice must be used to
complete a turn.
On each turn, the player rolls two dice and advances the pawn, based
on the die rolls. Typically the players may move a pawn for each die.
The pawn moves by the number of pips showing on the die and all of the
dice must be used to complete a turn.
There are some exceptions, however:
- you must roll a 5 (either directly or via summing) to
enter from the start area to the main ring.
- you must roll a 5 (either directly or via summing) to enter from
the start area to the main ring.
- if two pieces of the same color occupy a square, no
pieces may pass that square.
- if two pieces of the same color occupy a square, no pieces may
pass that square.
- if an opponent's piece lands on your piece, you piece is
returned to the starting area and the opponent receives
a bonus of 20 (which is treated just as if they had
rolled a 20 on the dice)
- if an opponent's piece lands on your piece, you piece is returned
to the starting area and the opponent receives a bonus of 20
(which is treated just as if they had rolled a 20 on the dice).
- if your piece makes it home (and it must do so by exact
count) you get a bonus of 10, to be used as an
additional die roll.
- if your piece makes it home (and it must do so by exact count) you
get a bonus of 10, to be used as an additional die roll.
These rules induce a number of unexpected corner cases, but
the GUI only lets you make legal moves. Watch the space
along the bottom of the board for reasons why a move is
illegal or why you have not used all of your die rolls.
These rules induce a number of unexpected corner cases, but the GUI
only lets you make legal moves. Watch the space along the bottom of
the board for reasons why a move is illegal or why you have not used
all of your die rolls.
The automated players are:
- Reckless Renee, who she tries to maximize the chances
that someone else bops her.
- Reckless Renee, who she tries to maximize the chances that someone
else bops her.
- Polite Polly, who tries to minimize the distance her
pawns move ("no, after _you_. I insist."), and
- Polite Polly, who tries to minimize the distance her pawns move
("no, after _you_. I insist."), and
- Amazing Grace, who tries to minimize the chance she gets
bopped while moving as far as possible.
- Amazing Grace, who tries to minimize the chance she gets bopped
while moving as far as possible.

10
collects/games/pousse/doc.txt
View File

@ -1,4 +1,4 @@
To play _Pousse_, run the "Games" application.
** To play Pousse, run the "PLT Games" application.
Pousse (French for "push", pronounced "poo-ss") is a 2 person game,
played on an N by N board (usually 4x4). Initially the board is
@ -32,13 +32,13 @@ Note that the last marker of the row or column will be pushed off the
board (and must be removed from play) if there are no empty squares on
the insertion row or column.
A row or a column is a "straight" of a given color, if it contains
N markers of the given color.
A row or a column is a "straight" of a given color, if it contains N
markers of the given color.
The game ends either when an insertion
1) repeats a previous configuration of the board; in this case
the player who inserted the marker LOSES.
1) repeats a previous configuration of the board; in this case the
player who inserted the marker LOSES.
2) creates a configuration with more straights of one color than
straights of the other color; the player whose color is dominant

26
collects/games/same/doc.txt
View File

@ -1,18 +1,18 @@
** To play _Same_, run the Games application. **
** To play Same, run the "PLT Games" application.
The object of Same is to score points by removing dots from the
board. To remove a dot, click on it. As long as there is another dot
of the same color next to the clicked dot, it will disappear along
with all adjacent dots of the same color. After the dots disappear,
dots in the rows above the deleted dots will fall into the vacated
spaces. If an entire column is wiped out, all of the dots from the
right will slide left to take up the empty column's space.
The object of Same is to score points by removing dots from the board.
To remove a dot, click on it. As long as there is another dot of the
same color next to the clicked dot, it will disappear along with all
adjacent dots of the same color. After the dots disappear, dots in
the rows above the deleted dots will fall into the vacated spaces. If
an entire column is wiped out, all of the dots from the right will
slide left to take up the empty column's space.
Your score increases for each ball removed from the board. The score
for each click is a function of the number of balls that
disappeared. The "This Click" label shows how many points you would
score for clicking the dots underneath the mouse pointer. The score
varies quadratically with the number of balls, so eliminating many
balls with one click is advantageous.
for each click is a function of the number of balls that disappeared.
The "This Click" label shows how many points you would score for
clicking the dots underneath the mouse pointer. The score varies
quadratically with the number of balls, so eliminating many balls with
one click is advantageous.
Click the New Game button to play again.

146
collects/games/slidey/slidey.ss
View File

@ -1,5 +1,4 @@
(module slidey mzscheme
#lang mzscheme
(require (lib "etc.ss")
(lib "class.ss")
(lib "unit.ss")
@ -7,34 +6,31 @@
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
(define (get-bitmap bitmap)
(define f (make-object dialog% "Choose Size" #f #f #f #f #f '(resize-border)))
(define bm-panel (make-object vertical-panel% f))
(define bm-message (make-object message% bitmap bm-panel))
(define size-message (make-object message%
(format "Image size: ~a x ~a pixels"
(define size-message
(make-object message% (format "Image size: ~a x ~a pixels"
(send bitmap get-width)
(send bitmap get-height))
bm-panel))
(define wide-panel (make-object vertical-panel% f '(border)))
(define sw (make-object slider% "Tiles (width)" 2 30 wide-panel
(lambda (_1 _2)
(update-horizontal-cutoff))))
(lambda (_1 _2) (update-horizontal-cutoff))))
(define tall-panel (make-object vertical-panel% f '(border)))
(define sh (make-object slider% "Tiles (height)" 2 30 tall-panel
(lambda (_1 _2)
(update-vertical-cutoff))))
(lambda (_1 _2) (update-vertical-cutoff))))
(define button-panel (make-object horizontal-panel% f))
(define cancelled? #t)
(define cancel (make-object button% "Cancel" button-panel (lambda (_1 _2) (send f show #f))))
(define ok (make-object button% "OK" button-panel (lambda (_1 _2)
(define cancel (make-object button% "Cancel" button-panel
(lambda (_1 _2) (send f show #f))))
(define ok (make-object button% "OK" button-panel
(lambda (_1 _2)
(set! cancelled? #f)
(send f show #f)) '(border)))
@ -85,23 +81,19 @@
;; board = (vector-of (vector-of (union #f (make-loc n1 n2))))
;; need to make sure that the bitmap divides nicely
;(define bitmap (make-object bitmap% (build-path (collection-path "games" "slidey") "11.jpg")))
;(define board-width 6)
;(define board-height 5)
;;(define bitmap (make-object bitmap% (build-path (collection-path "games" "slidey") "11.jpg")))
;;(define board-width 6)
;;(define board-height 5)
(define (board-for-each board f)
(let loop ([i (vector-length board)])
(cond
[(zero? i) (void)]
[else
(unless (zero? i)
(let ([row (vector-ref board (- i 1))])
(let loop ([j (vector-length row)])
(cond
[(zero? j) (void)]
[else
(unless (zero? j)
(f (- i 1) (- j 1) (vector-ref row (- j 1)))
(loop (- j 1))])))
(loop (- i 1))])))
(loop (- j 1)))))
(loop (- i 1)))))
(define (move-one board from-i from-j to-i to-j)
(let ([from-save (board-ref board from-i from-j)]
@ -131,28 +123,21 @@
(let ([i-diff (abs (- m-hole-i hole-i))])
(let loop ([i 0])
(unless (= i i-diff)
(move-one
board
(+ m-hole-i i)
m-hole-j
(+ m-hole-i i (if (< m-hole-i hole-i) +1 -1))
(move-one board (+ m-hole-i i)
m-hole-j (+ m-hole-i i (if (< m-hole-i hole-i) +1 -1))
m-hole-j)
(loop (+ i 1)))))
(let ([j-diff (abs (- m-hole-j hole-j))])
(let loop ([j 0])
(unless (= j j-diff)
(move-one
board
hole-i
(+ m-hole-j j)
hole-i
(+ m-hole-j j (if (< m-hole-j hole-j) +1 -1)))
(move-one board hole-i (+ m-hole-j j)
hole-i (+ m-hole-j j (if (< m-hole-j hole-j) +1 -1)))
(loop (+ j 1)))))]
[else
(let ([this-dir (get-random-number 4 no-good)])
(let-values ([(new-i new-j)
(case this-dir
; up
;; up
[(0) (values (- m-hole-i 1) m-hole-j)]
[(1) (values (+ m-hole-i 1) m-hole-j)]
[(2) (values m-hole-i (- m-hole-j 1))]
@ -162,25 +147,22 @@
(<= 0 new-j)
(< new-j board-height))
(let ([next-no-good
(case this-dir
[(0) 1]
[(1) 0]
[(2) 3]
[(3) 2])])
(case this-dir [(0) 1] [(1) 0] [(2) 3] [(3) 2])])
(move-one board new-i new-j m-hole-i m-hole-j)
(loop next-no-good (- i 1) new-i new-j))
(loop no-good (- i 1) m-hole-i m-hole-j))))]))))
(define (get-random-number bound no-good)
(let ([raw (random (- bound 1))])
(cond
[(not no-good) raw]
(cond [(not no-good) raw]
[(< raw no-good) raw]
[else (+ raw 1)])))
(define line-brush (send the-brush-list find-or-create-brush "black" 'transparent))
(define line-brush
(send the-brush-list find-or-create-brush "black" 'transparent))
(define line-pen (send the-pen-list find-or-create-pen "white" 1 'solid))
(define mistake-brush (send the-brush-list find-or-create-brush "black" 'transparent))
(define mistake-brush
(send the-brush-list find-or-create-brush "black" 'transparent))
(define mistake-pen (send the-pen-list find-or-create-pen "red" 1 'solid))
(define pict-brush (send the-brush-list find-or-create-brush "black" 'solid))
(define pict-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
@ -194,19 +176,14 @@
(define show-mistakes? #f)
(define/public (show-mistakes nv)
(set! show-mistakes? nv)
(unless solved?
(on-paint)))
(unless solved? (on-paint)))
(define solved? #f)
(define board
(build-vector
board-width
(lambda (i)
(build-vector
board-height
(lambda (j)
(make-loc i j))))))
(lambda (i) (build-vector board-height (lambda (j) (make-loc i j))))))
(define hole-i (- board-width 1))
(define hole-j (- board-height 1))
(board-set! board hole-i hole-j #f)
@ -214,18 +191,13 @@
(define/override (on-paint)
(if solved?
(send (get-dc) draw-bitmap bitmap 0 0)
(board-for-each
board
(lambda (i j v)
(draw-cell i j)))))
(board-for-each board (lambda (i j v) (draw-cell i j)))))
(define/override (on-event evt)
(unless solved?
(cond
[(send evt button-down? 'left)
(when (send evt button-down? 'left)
(let-values ([(i j) (xy->ij (send evt get-x) (send evt get-y))])
(slide i j))]
[else (void)])))
(slide i j)))))
(inherit get-client-size get-dc)
(define/private (check-end-condition)
@ -234,42 +206,33 @@
board
(lambda (i j v)
(when v
(unless (and (= i (loc-x v))
(= j (loc-y v)))
(unless (and (= i (loc-x v)) (= j (loc-y v)))
(set! answer #f)))))
(when answer
(set! solved? #t))))
(when answer (set! solved? #t))))
(define/private (slide i j)
(cond
[(= j hole-j)
(let loop ([new-hole-i hole-i])
(cond
[(= new-hole-i i) (void)]
[else
(let ([next (if (< i hole-i)
sub1
add1)])
(unless (= new-hole-i i)
(let ([next (if (< i hole-i) sub1 add1)])
(move-one board (next new-hole-i) hole-j new-hole-i hole-j)
(draw-cell new-hole-i hole-j)
(draw-cell (next new-hole-i) hole-j)
(loop (next new-hole-i)))]))
(loop (next new-hole-i)))))
(set! hole-i i)
(check-end-condition)
(when solved?
(on-paint))]
(when solved? (on-paint))]
[(= i hole-i)
(let loop ([new-hole-j hole-j])
(cond
[(= new-hole-j j) (void)]
[else
(unless (= new-hole-j j)
(let ([next (if (< j hole-j)
sub1
add1)])
(move-one board hole-i (next new-hole-j) hole-i new-hole-j)
(draw-cell hole-i new-hole-j)
(draw-cell hole-i (next new-hole-j))
(loop (next new-hole-j)))]))
(loop (next new-hole-j)))))
(set! hole-j j)
(check-end-condition)
(when solved?
@ -278,18 +241,14 @@
(define/private (xy->ij x y)
(let-values ([(w h) (get-client-size)])
(values
(inexact->exact (floor (* board-width (/ x w))))
(values (inexact->exact (floor (* board-width (/ x w))))
(inexact->exact (floor (* board-height (/ y h)))))))
(define/private (ij->xywh i j)
(let-values ([(w h) (get-client-size)])
(let ([cell-w (/ w board-width)]
[cell-h (/ h board-height)])
(values (* i cell-w)
(* j cell-h)
cell-w
cell-h))))
(values (* i cell-w) (* j cell-h) cell-w cell-h))))
(define/private (draw-cell draw-i draw-j)
(let-values ([(xd yd wd hd) (ij->xywh draw-i draw-j)])
(let* ([dc (get-dc)]
@ -304,19 +263,17 @@
(if (and show-mistakes?
(or (not (= draw-i bm-i))
(not (= draw-j bm-j))))
(begin
(send dc set-pen mistake-pen)
(begin (send dc set-pen mistake-pen)
(send dc set-brush mistake-brush))
(begin
(send dc set-pen line-pen)
(begin (send dc set-pen line-pen)
(send dc set-brush line-brush)))
(send dc draw-rectangle xd yd wd hd)))
(begin
(send dc set-pen white-pen)
(begin (send dc set-pen white-pen)
(send dc set-brush white-brush)
(send dc draw-rectangle xd yd wd hd))))))
(inherit stretchable-width stretchable-height min-client-width min-client-height)
(inherit stretchable-width stretchable-height
min-client-width min-client-height)
(super-instantiate ())
(randomize-board board hole-i hole-j)
(stretchable-width #f)
@ -327,7 +284,8 @@
(define f (make-object frame% "Slidey"))
(define p (make-object horizontal-panel% f))
(send p set-alignment 'center 'center)
(define slidey-canvas (make-object slidey-canvas%
(define slidey-canvas
(make-object slidey-canvas%
(make-object bitmap%
(build-path (collection-path "games" "slidey") "11.jpg"))
6 6 p))
@ -355,4 +313,6 @@
(make-object menu-item% "Open Image" file-menu (lambda (_1 _2) (change-bitmap)) #\o)
(make-object menu-item% "Close Window" file-menu (lambda (_1 _2) (send f show #f)) #\w)
(send f show #t))))
(send f show #t)
))

2
collects/games/spider/doc.txt
View File

@ -1,4 +1,4 @@
** To play _Spider_, run the "Games" application. **
** To play Spider, run the "PLT Games" application.
Spider is a solitaire card game played with 104 cards. The cards can
include either a single suit, two suits, or four suites. (Choose your

119
collects/games/spider/spider.ss
View File

@ -1,5 +1,4 @@
(module spider mzscheme
#lang mzscheme
(require (lib "cards.ss" "games" "cards")
(lib "class.ss")
@ -17,11 +16,7 @@
(list->vector (vector->list v)))
(provide game@)
(define game@
(unit
(import)
(export)
(define game@ (unit (import) (export)
(define t (make-table "Spider" 11 6))
@ -33,14 +28,11 @@
[(1) (values '(spades) 4)]
[(2) (values '(spades hearts) 2)]
[(4) (values '(spades hearts clubs diamonds) 1)])])
(let ([l (filter (lambda (c)
(memq (send c get-suit) suits))
(make-deck))])
(let ([l (filter (lambda (c) (memq (send c get-suit) suits)) (make-deck))])
(let loop ([n (* 2 copies)])
(if (zero? n)
null
(append (map (lambda (c) (send c copy)) l)
(loop (sub1 n))))))))
(append (map (lambda (c) (send c copy)) l) (loop (sub1 n))))))))
(define deck (make-spider-deck))
@ -68,7 +60,8 @@
(new menu-item%
[label "&Reset Game..."]
[parent file-menu]
[callback (lambda (i e)
[callback
(lambda (i e)
(when (eq? 'yes (message-box "Reset Game"
"Are you sure you want to reset the game?"
t
@ -90,8 +83,7 @@
[label "&Undo"]
[parent edit-menu]
[shortcut #\Z]
[callback (lambda (i e)
(pop-state!))]))
[callback (lambda (i e) (pop-state!))]))
(new separator-menu-item% [parent edit-menu])
@ -99,12 +91,14 @@
[label "&Options..."]
[parent edit-menu]
[callback (lambda (i e)
(define d (new dialog%
(define d
(new dialog%
[label "Spider Options"]
[parent t]
[stretchable-width #f]
[stretchable-height #f]))
(define suits (new radio-box%
(define suits
(new radio-box%
[label #f]
[parent (new group-box-panel%
[parent d]
@ -112,7 +106,8 @@
[stretchable-width #f]
[stretchable-height #f])]
[choices '("1 (easiest)" "2" "4 (hardest)")]))
(define bottom-panel (new horizontal-panel%
(define bottom-panel
(new horizontal-panel%
[parent d]
[alignment '(right center)]
[stretchable-height #f]))
@ -145,14 +140,13 @@
(new menu-item%
[label "&Rules"]
[parent (make-object menu% "&Help" mb)]
[callback (lambda (i e)
(help))])
[callback (lambda (i e) (help))])
(define (push-state!)
(when (null? old-states)
(send undo enable #t))
(set! old-states (cons (make-state
draw-pile
(set! old-states
(cons (make-state draw-pile
(vector-copy stacks)
(vector-copy dones)
done-count
@ -169,8 +163,7 @@
(set! done-count (state-done-count state))
(for-each (lambda (c fd?)
(send c user-can-move #f)
(unless (eq? (send c face-down?) fd?)
(send c flip)))
(unless (eq? (send c face-down?) fd?) (send c flip)))
deck (state-face-down?s state))
(send t move-cards draw-pile dx dy)
(send t stack-cards draw-pile)
@ -179,12 +172,9 @@
(send t stack-cards (vector-ref stacks i))
(loop (add1 i))))
(let loop ([i 0])
(unless (= i (vector-length dones))
(move-dones i)
(loop (add1 i))))
(unless (= i (vector-length dones)) (move-dones i) (loop (add1 i))))
(shift-stacks)
(when (null? old-states)
(send undo enable #f))
(when (null? old-states) (send undo enable #f))
(send t end-card-sequence)))
(define (find-stack find)
@ -192,8 +182,7 @@
(if (= i (vector-length stacks))
#f
(let ([l (vector-ref stacks i)])
(if (and (pair? l)
(memq find l))
(if (and (pair? l) (memq find l))
i
(loop (add1 i)))))))
@ -205,10 +194,8 @@
(define (stacked-cards card)
(let ([i (find-stack card)])
(if i
(reverse
(let loop ([l (vector-ref stacks i)])
(cond
[(not (send (car l) user-can-move)) null]
(reverse (let loop ([l (vector-ref stacks i)])
(cond [(not (send (car l) user-can-move)) null]
[(eq? (car l) card) (list card)]
[else (cons (car l) (loop (cdr l)))])))
#f)))
@ -236,12 +223,10 @@
r
(lambda (on? cards)
(let ([ok? (and on? (drag-ok? cards i))])
(for-each (lambda (c)
(send c snap-back-after-move (not ok?)))
(for-each (lambda (c) (send c snap-back-after-move (not ok?)))
cards)
(let ([l (vector-ref stacks i)])
(unless (null? l)
(send (car l) dim ok?))))))
(unless (null? l) (send (car l) dim ok?))))))
(send t add-region r)
(loop (add1 i)))))
@ -249,16 +234,11 @@
(define (move-to-stack cards i)
(unselect)
(let ([l (vector-ref stacks i)])
(unless (null? l)
(send (car l) dim #f)))
(unless (null? l) (send (car l) dim #f)))
(push-state!)
(remove-from-stack! cards)
(vector-set! stacks i
(append (reverse cards)
(vector-ref stacks i)))
(for-each (lambda (c)
(send c snap-back-after-move #t))
cards)
(vector-set! stacks i (append (reverse cards) (vector-ref stacks i)))
(for-each (lambda (c) (send c snap-back-after-move #t)) cards)
(shift-stacks))
(define selected null)
@ -266,12 +246,10 @@
(define (select cards)
(unselect)
(set! selected cards)
(for-each (lambda (c) (send c dim #t))
selected))
(for-each (lambda (c) (send c dim #t)) selected))
(define (unselect)
(for-each (lambda (c) (send c dim #f))
selected)
(for-each (lambda (c) (send c dim #f)) selected)
(set! selected null))
(define (move-dones i)
@ -280,17 +258,14 @@
dy))
(define (draw push?)
(when push?
(push-state!))
(when push? (push-state!))
(let ([drawn-cards
(let loop ([i 0])
(if (or (= i (vector-length stacks))
(null? draw-pile))
(if (or (= i (vector-length stacks)) (null? draw-pile))
null
(if (vector-ref stacks i)
(let ([a (car draw-pile)])
(vector-set! stacks i (cons a
(vector-ref stacks i)))
(vector-set! stacks i (cons a (vector-ref stacks i)))
(send a flip)
(set! draw-pile (cdr draw-pile))
(cons a (loop (add1 i))))
@ -303,8 +278,7 @@
(let loop ([i 0])
(unless (= i (vector-length stacks))
(let ([l (vector-ref stacks i)])
(when (and (pair? l)
(= 1 (send (car l) get-value)))
(when (and (pair? l) (= 1 (send (car l) get-value)))
(let ([suit (send (car l) get-suit)])
(let loop ([j 2][a (list (car l))][l (cdr l)])
(cond
@ -313,9 +287,7 @@
(vector-set! dones done-count a)
(move-dones done-count)
(set! done-count (add1 done-count))
(for-each (lambda (c)
(send c user-can-move #f))
a)
(for-each (lambda (c) (send c user-can-move #f)) a)
(vector-set! stacks i l)]
[(and (pair? l)
(= j (send (car l) get-value))
@ -351,8 +323,7 @@
(unless (= i (vector-length stacks))
(let ([l (vector-ref stacks i)])
(when (pair? l)
(when (send (car l) face-down?)
(send t flip-card (car l)))
(when (send (car l) face-down?) (send t flip-card (car l)))
(send (car l) user-can-move #t)
(let loop ([l (cdr l)][prev (car l)])
(unless (null? l)
@ -361,11 +332,9 @@
(send (car l) get-suit))
(= (add1 (send prev get-value))
(send (car l) get-value)))
(begin
(send (car l) user-can-move #t)
(begin (send (car l) user-can-move #t)
(loop (cdr l) (car l)))
(for-each (lambda (c)
(send c user-can-move #f))
(for-each (lambda (c) (send c user-can-move #f))
l))))))
(loop (add1 i))))))
@ -376,9 +345,7 @@
(cond
[(and (pair? draw-pile)
(eq? c (car draw-pile)))
(if (ormap null? (vector->list stacks))
(bell)
(draw #t))]
(if (ormap null? (vector->list stacks)) (bell) (draw #t))]
[(and (pair? selected) (eq? c (car selected)))
(unselect)]
[(and (pair? selected)
@ -391,8 +358,7 @@
(send t card-to-front (car (last-pair selected)))
(send t stack-cards (reverse selected))
(move-to-stack selected i))]
[(stacked-cards c)
=> (lambda (cards) (select cards))])))
[(stacked-cards c) => (lambda (cards) (select cards))])))
;; Add a region for each stack to receive clicks when
;; the stack is empty:
@ -422,8 +388,7 @@
(send undo enable #f)
(set! draw-pile (shuffle-list deck 7))
(for-each (lambda (c)
(unless (send c face-down?)
(send c flip))
(unless (send c face-down?) (send c flip))
(send c user-can-flip #f)
(send c user-can-move #f)
(send c snap-back-after-move #t))
@ -442,4 +407,6 @@
(draw #f)
(send t end-card-sequence))
(reset-game!)
(send t show #t))))
(send t show #t)
))