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

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

@ -5,52 +5,46 @@ possible to remap single click (instead of double click)?
|# |#
(module aces mzscheme #lang mzscheme
(require (lib "cards.ss" "games" "cards") (require (lib "cards.ss" "games" "cards")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "list.ss") (lib "list.ss")
(lib "unit.ss")
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
"../show-help.ss") "../show-help.ss")
(provide game@) (provide game@)
(define game@ (unit (import) (export)
(define game@ (define table (make-table "Aces" 6 5))
(unit
(import)
(export)
(define table (make-table "Aces" 6 5)) (make-object button% (string-constant help-menu-label) table
(make-object button% (string-constant help-menu-label) table
(let ([show-help (show-help (list "games" "aces") "Aces Help")]) (let ([show-help (show-help (list "games" "aces") "Aces Help")])
(lambda x (lambda x (show-help))))
(show-help))))
(define draw-pile null) (define draw-pile null)
(define card-height (send (car (make-deck)) card-height)) (define card-height (send (car (make-deck)) card-height))
(define card-width (send (car (make-deck)) card-width)) (define card-width (send (car (make-deck)) card-width))
(define region-height (send table table-height)) (define region-height (send table table-height))
;; space between cards in the 4 stacks ;; space between cards in the 4 stacks
(define card-space 30) (define card-space 30)
(define-struct stack (x y cards)) (define-struct stack (x y cards))
(define (get-x-offset n) (define (get-x-offset n)
(let* ([table-width (send table table-width)] (let* ([table-width (send table table-width)]
[stack-spacing 7] [stack-spacing 7]
[num-stacks 5] [num-stacks 5]
[all-stacks-width [all-stacks-width (+ (* num-stacks card-width)
(+ (* num-stacks card-width)
(* (- num-stacks 1) stack-spacing))]) (* (- num-stacks 1) stack-spacing))])
(+ (- (/ table-width 2) (/ all-stacks-width 2)) (+ (- (/ table-width 2) (/ all-stacks-width 2))
(* n (+ card-width stack-spacing))))) (* n (+ card-width stack-spacing)))))
(define draw-pile-region (define draw-pile-region
(make-button-region (make-button-region
(get-x-offset 0) (get-x-offset 0)
0 0
@ -59,38 +53,24 @@ possible to remap single click (instead of double click)?
#f #f
#f)) #f))
(define stacks (define stacks
(list (list (make-stack (get-x-offset 1) 0 null)
(make-stack (make-stack (get-x-offset 2) 0 null)
(get-x-offset 1) (make-stack (get-x-offset 3) 0 null)
0 (make-stack (get-x-offset 4) 0 null)))
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))) ;; type state = (make-state (listof cards) (listof[4] (listof cards)))
(define-struct state (draw-pile stacks)) (define-struct state (draw-pile stacks))
;; extract-current-state : -> state ;; extract-current-state : -> state
(define (extract-current-state) (define (extract-current-state)
(make-state (make-state (copy-list draw-pile)
(copy-list draw-pile)
(map (lambda (x) (copy-list (stack-cards x))) stacks))) (map (lambda (x) (copy-list (stack-cards x))) stacks)))
(define (copy-list l) (map (lambda (x) x) l)) (define (copy-list l) (map (lambda (x) x) l))
;; install-state : -> void ;; install-state : -> void
(define (install-state state) (define (install-state state)
(send table begin-card-sequence) (send table begin-card-sequence)
;; erase all old snips ;; erase all old snips
@ -115,60 +95,54 @@ possible to remap single click (instead of double click)?
(send table card-to-front draw-pile-card)) (send table card-to-front draw-pile-card))
(reverse draw-pile)) (reverse draw-pile))
(for-each (for-each (lambda (stack)
(lambda (stack)
(let ([num-cards (length (stack-cards stack))]) (let ([num-cards (length (stack-cards stack))])
(send table add-cards (stack-cards stack) 0 0) (send table add-cards (stack-cards stack) 0 0)
(send table move-cards (stack-cards stack) (send table move-cards (stack-cards stack)
(stack-x stack) (stack-x stack)
(stack-y stack) (stack-y stack)
(lambda (i) (lambda (i)
(values 0 (values 0 (* (- num-cards i 1) card-space)))))
(* (- num-cards i 1) card-space)))))
(send table cards-face-up (stack-cards stack))) (send table cards-face-up (stack-cards stack)))
stacks) stacks)
(send table end-card-sequence)) (send table end-card-sequence))
;; undo-stack : (listof state) ;; undo-stack : (listof state)
(define undo-stack null) (define undo-stack null)
;; redo-stack : (listof state) ;; redo-stack : (listof state)
(define redo-stack null) (define redo-stack null)
;; save-undo : -> void ;; save-undo : -> void
;; saves the current state in the undo stack ;; saves the current state in the undo stack
(define (save-undo) (define (save-undo)
(set! undo-stack (cons (extract-current-state) undo-stack)) (set! undo-stack (cons (extract-current-state) undo-stack))
(set! redo-stack null)) (set! redo-stack null))
;; do-undo : -> void ;; do-undo : -> void
;; pre: (not (null? undo-stack)) ;; pre: (not (null? undo-stack))
(define (do-undo) (define (do-undo)
(let ([to-install (car undo-stack)]) (let ([to-install (car undo-stack)])
(set! redo-stack (cons (extract-current-state) redo-stack)) (set! redo-stack (cons (extract-current-state) redo-stack))
(set! undo-stack (cdr undo-stack)) (set! undo-stack (cdr undo-stack))
(install-state to-install))) (install-state to-install)))
;; do-redo : -> void ;; do-redo : -> void
;; pre: (not (null? redo-stack)) ;; pre: (not (null? redo-stack))
(define (do-redo) (define (do-redo)
(let ([to-install (car redo-stack)]) (let ([to-install (car redo-stack)])
(set! undo-stack (cons (extract-current-state) undo-stack)) (set! undo-stack (cons (extract-current-state) undo-stack))
(set! redo-stack (cdr redo-stack)) (set! redo-stack (cdr redo-stack))
(install-state to-install))) (install-state to-install)))
(define (position-cards stack) (define (position-cards stack)
(let ([m (length (stack-cards stack))]) (let ([m (length (stack-cards stack))])
(lambda (i) (lambda (i)
(values 0 (values 0 (if (= m 0) 0 (* (- m i 1) card-space))))))
(if (= m 0)
0
(* (- m i 1) card-space))))))
(define (reset-game) (define (reset-game)
(send table remove-cards draw-pile) (send table remove-cards draw-pile)
(for-each (for-each (lambda (stack) (send table remove-cards (stack-cards stack)))
(lambda (stack) (send table remove-cards (stack-cards stack)))
stacks) stacks)
(set! undo-stack null) (set! undo-stack null)
@ -188,29 +162,26 @@ possible to remap single click (instead of double click)?
(set-stack caddr) (set-stack caddr)
(set-stack cadddr)) (set-stack cadddr))
(for-each (for-each (lambda (stack)
(lambda (stack)
(send table add-cards (send table add-cards
(stack-cards stack) (stack-cards stack)
(stack-x stack) (stack-x stack)
(stack-y stack) (stack-y stack)
(position-cards stack)) (position-cards stack))
(for-each (for-each (lambda (card) (send card flip))
(lambda (card) (send card flip))
(stack-cards stack))) (stack-cards stack)))
stacks) stacks)
(send table add-cards-to-region draw-pile draw-pile-region)) (send table add-cards-to-region draw-pile draw-pile-region))
(define (move-from-deck) (define (move-from-deck)
(save-undo) (save-undo)
(unless (null? draw-pile) (unless (null? draw-pile)
(let ([move-one (let ([move-one
(lambda (select) (lambda (select)
(let ([stack (select stacks)] (let ([stack (select stacks)]
[card (select draw-pile)]) [card (select draw-pile)])
(set-stack-cards! stack (set-stack-cards! stack (cons card (stack-cards stack)))
(cons card (stack-cards stack)))
(send table card-to-front card) (send table card-to-front card)
(send table flip-card card)))]) (send table flip-card card)))])
@ -237,7 +208,7 @@ possible to remap single click (instead of double click)?
(send table move-cards-to-region draw-pile draw-pile-region)))) (send table move-cards-to-region draw-pile draw-pile-region))))
(define (move-to-empty-spot card stack) (define (move-to-empty-spot card stack)
(save-undo) (save-undo)
(send table move-cards (send table move-cards
(list card) (list card)
@ -245,19 +216,16 @@ possible to remap single click (instead of double click)?
(stack-y stack) (stack-y stack)
(position-cards stack)) (position-cards stack))
(remove-card-from-stacks card) (remove-card-from-stacks card)
(set-stack-cards! (set-stack-cards! stack (cons card (stack-cards stack))))
stack
(cons card (stack-cards stack))))
(define (remove-card card) (define (remove-card card)
(save-undo) (save-undo)
(send table remove-card card) (send table remove-card card)
(remove-card-from-stacks card)) (remove-card-from-stacks card))
(define (remove-card-from-stacks card) (define (remove-card-from-stacks card)
(let ([old-cards (map stack-cards stacks)]) (let ([old-cards (map stack-cards stacks)])
(for-each (for-each (lambda (stack)
(lambda (stack)
(set-stack-cards! stack (remq card (stack-cards stack)))) (set-stack-cards! stack (remq card (stack-cards stack))))
stacks) stacks)
(for-each (lambda (stack old-cards) (for-each (lambda (stack old-cards)
@ -270,43 +238,39 @@ possible to remap single click (instead of double click)?
stacks stacks
old-cards))) old-cards)))
(send table set-single-click-action (send table set-single-click-action
(lambda (card) (lambda (card)
(cond (if (send card face-down?)
[(send card face-down?) (move-from-deck)] (move-from-deck)
[else
(let ([bottom-four (let ([bottom-four
(let loop ([l stacks]) (let loop ([l stacks])
(cond (if (null? l)
[(null? l) null] null
[else (let ([stack (car l)]) (let ([stack (car l)])
(if (null? (stack-cards stack)) (if (null? (stack-cards stack))
(loop (cdr l)) (loop (cdr l))
(cons (car (stack-cards stack)) (cons (car (stack-cards stack)) (loop (cdr l)))))))])
(loop (cdr l)))))]))])
(when (memq card bottom-four) (when (memq card bottom-four)
(cond (if (ormap (lambda (bottom-card)
[(ormap (lambda (bottom-card)
(and (eq? (send card get-suit) (and (eq? (send card get-suit)
(send bottom-card get-suit)) (send bottom-card get-suit))
(or (or (and (not (= 1 (send card get-value)))
(and (not (= 1 (send card get-value)))
(= 1 (send bottom-card get-value))) (= 1 (send bottom-card get-value)))
(and (not (= 1 (send card get-value))) (and (not (= 1 (send card get-value)))
(< (send card get-value) (< (send card get-value)
(send bottom-card get-value)))))) (send bottom-card get-value))))))
bottom-four) bottom-four)
(remove-card card)] (remove-card card)
[else (let loop ([stacks stacks]) (let loop ([stacks stacks])
(cond (if (null? stacks)
[(null? stacks) (void)] (void)
[else (let ([stack (car stacks)]) (let ([stack (car stacks)])
(if (null? (stack-cards stack)) (if (null? (stack-cards stack))
(move-to-empty-spot card stack) (move-to-empty-spot card stack)
(loop (cdr stacks))))]))])))]) (loop (cdr stacks))))))))))
(check-game-over))) (check-game-over)))
(define (game-over?) (define (game-over?)
(and (null? draw-pile) (and (null? draw-pile)
(let ([suits/false (let ([suits/false
(map (lambda (x) (map (lambda (x)
@ -323,7 +287,7 @@ possible to remap single click (instead of double click)?
(memq 'hearts suits/false) (memq 'hearts suits/false)
(memq 'spades suits/false)))))) (memq 'spades suits/false))))))
(define (won?) (define (won?)
(and (game-over?) (and (game-over?)
(andmap (lambda (x) (andmap (lambda (x)
(let ([cards (stack-cards x)]) (let ([cards (stack-cards x)])
@ -332,7 +296,7 @@ possible to remap single click (instead of double click)?
(= 1 (send (car cards) get-value))))) (= 1 (send (car cards) get-value)))))
stacks))) stacks)))
(define (check-game-over) (define (check-game-over)
(when (game-over?) (when (game-over?)
(case (message-box "Aces" (case (message-box "Aces"
(if (won?) (if (won?)
@ -343,29 +307,27 @@ possible to remap single click (instead of double click)?
[(yes) (reset-game)] [(yes) (reset-game)]
[(no) (send table show #f)]))) [(no) (send table show #f)])))
(send table add-region draw-pile-region) (send table add-region draw-pile-region)
(reset-game) (reset-game)
(define mb (or (send table get-menu-bar) (define mb (or (send table get-menu-bar)
(make-object menu-bar% table))) (make-object menu-bar% table)))
(define edit-menu (instantiate menu% () (define edit-menu (new menu% [parent mb] [label (string-constant edit-menu)]))
(parent mb) (new menu-item%
(label (string-constant edit-menu)))) [label (string-constant undo-menu-item)]
(instantiate menu-item% () [parent edit-menu]
(label (string-constant undo-menu-item)) [callback (lambda (x y) (do-undo))]
(parent edit-menu) [shortcut #\z]
(callback (lambda (x y) (do-undo))) [demand-callback
(shortcut #\z) (lambda (item) (send item enable (not (null? undo-stack))))])
(demand-callback (new menu-item%
(lambda (item) [label (string-constant redo-menu-item)]
(send item enable (not (null? undo-stack)))))) [parent edit-menu]
(instantiate menu-item% () [callback (lambda (x y) (do-redo))]
(label (string-constant redo-menu-item)) [shortcut #\y]
(parent edit-menu) [demand-callback
(callback (lambda (x y) (do-redo))) (lambda (item) (send item enable (not (null? redo-stack))))])
(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 Aces is a solitaire card game. The object is to remove all of the
from the board, except the four Aces. cards from the board, except the four Aces.
Remove a card by clicking it. You may remove a card when two 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 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. four stacks of cards.
You may also move any card from the bottom of one of the stacks to an 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 empty stack by clicking it. If there are still cards in the deck on
right, you may click the deck to deal four new cards, one onto the the right, you may click the deck to deal four new cards, one onto the
bottom of each stack. bottom of each stack.
Good Luck! Good Luck!

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

@ -29,164 +29,152 @@
;; ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module blackjack mzscheme #lang mzscheme
(require (lib "cards.ss" "games" "cards")
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss") (lib "list.ss")
(lib "list.ss")) (lib "unit.ss"))
(provide game@) (provide game@)
(define game@ (unit (import) (export)
(define game@ ;; Number of decks to use
(unit (define DECK-COUNT 4)
(import)
(export)
;; Number of decks to use ;; Region layout constants
(define DECK-COUNT 4) (define MARGIN 10)
(define SUBMARGIN 10)
(define LABEL-H 15)
;; Region layout constants ;; Randomize
(define MARGIN 10) (random-seed (modulo (current-milliseconds) 10000))
(define SUBMARGIN 10)
(define LABEL-H 15)
;; Randomize ;; Reshuffle when 3/4 of the deck is used
(random-seed (modulo (current-milliseconds) 10000)) (define min-deck-size (/ (* DECK-COUNT 52) 4))
;; Reshuffle when 3/4 of the deck is used ;; Set up the table
(define min-deck-size (/ (* DECK-COUNT 52) 4)) (define t (make-table "Blackjack" 6 3))
(define status-pane (send t create-status-pane))
(send t add-help-button status-pane '("games" "blackjack") "Blackjack Help" #f)
(send t show #t)
(send t set-double-click-action #f)
(send t set-button-action 'left 'drag/one)
(send t set-button-action 'middle 'drag/one)
(send t set-button-action 'right 'drag/one)
;; Set up the table ;; Get table width & height
(define t (make-table "Blackjack" 6 3)) (define w (send t table-width))
(define status-pane (send t create-status-pane)) (define h (send t table-height))
(send t add-help-button status-pane '("games" "blackjack") "Blackjack Help" #f)
(send t show #t)
(send t set-double-click-action #f)
(send t set-button-action 'left 'drag/one)
(send t set-button-action 'middle 'drag/one)
(send t set-button-action 'right 'drag/one)
;; Get table width & height ;; Build the deck
(define w (send t table-width)) (define deck
(define h (send t table-height))
;; Build the deck
(define deck
(let loop ([n DECK-COUNT]) (let loop ([n DECK-COUNT])
(if (zero? n) (if (zero? n)
null null
(append (make-deck) (loop (sub1 n)))))) (append (make-deck) (loop (sub1 n))))))
;; Card width & height ;; Card width & height
(define cw (send (car deck) card-width)) (define cw (send (car deck) card-width))
(define ch (send (car deck) card-height)) (define ch (send (car deck) card-height))
;; Size of buttons ;; Size of buttons
(define BUTTON-HEIGHT 16) (define BUTTON-HEIGHT 16)
(define BUTTON-WIDTH cw) (define BUTTON-WIDTH cw)
;; Cards are not movable ;; Cards are not movable
(for-each (for-each (lambda (card) (send* card (user-can-move #f) (user-can-flip #f)))
(lambda (card)
(send card user-can-move #f)
(send card user-can-flip #f))
deck) deck)
;; Set up card regions ;; Set up card regions
(define deck-region (define deck-region
(make-region MARGIN MARGIN (make-region MARGIN MARGIN cw ch #f #f))
cw ch #f #f))
(define discard-region (define discard-region
(make-region (- w cw MARGIN) MARGIN (make-region (- w cw MARGIN) MARGIN cw ch #f #f))
cw ch #f #f))
(define dealer-region (define dealer-region
(make-region (+ cw (* 2 MARGIN)) MARGIN (make-region (+ cw (* 2 MARGIN)) MARGIN
(- w (* 2 cw) (* 4 MARGIN)) ch (- w (* 2 cw) (* 4 MARGIN)) ch
#f #f)) #f #f))
(define player-region (define player-region
(make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT) (make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT)
(- w (* 2 cw) (* 4 MARGIN)) ch (- w (* 2 cw) (* 4 MARGIN)) ch
#f #f)) #f #f))
;; In case of split, we need more regions ;; In case of split, we need more regions
(define ww (* 3/2 cw)) (define ww (* 3/2 cw))
(define player-2-region (define player-2-region
(make-region MARGIN (region-y player-region) (make-region MARGIN (region-y player-region)
(- w ww (* 3 MARGIN)) (region-h player-region) (- w ww (* 3 MARGIN)) (region-h player-region)
#f #f)) #f #f))
(define player-2-wait-region (define player-2-wait-region
(make-region (region-x player-2-region) (region-y player-2-region) (make-region (region-x player-2-region) (region-y player-2-region)
ww (region-h player-2-region) ww (region-h player-2-region)
#f #f)) #f #f))
(define player-1-region (define player-1-region
(make-region (- w MARGIN (region-w player-2-region)) (region-y player-2-region) (make-region (- w MARGIN (region-w player-2-region)) (region-y player-2-region)
(region-w player-2-region) (region-h player-2-region) (region-w player-2-region) (region-h player-2-region)
#f #f)) #f #f))
(define player-1-wait-region (define player-1-wait-region
(make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww) (make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww)
(region-y player-1-region) (region-y player-1-region)
ww (region-h player-1-region) ww (region-h player-1-region)
#f #f)) #f #f))
(define (make-border-region r) (define (make-border-region r)
(define hm (/ MARGIN 2)) (define hm (/ MARGIN 2))
(make-region (- (region-x r) hm) (- (region-y r) hm) (make-region (- (region-x r) hm) (- (region-y r) hm)
(+ (region-w r) MARGIN) (+ (region-h r) MARGIN) (+ (region-w r) MARGIN) (+ (region-h r) MARGIN)
"" #f)) "" #f))
(define player-1-border (make-border-region player-1-region)) (define player-1-border (make-border-region player-1-region))
(define player-2-border (make-border-region player-2-region)) (define player-2-border (make-border-region player-2-region))
;; Player buttons ;; Player buttons
(define (make-button title pos) (define (make-button title pos)
(make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2) (make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2)
(* pos (+ BUTTON-WIDTH MARGIN))) (* pos (+ BUTTON-WIDTH MARGIN)))
(- h MARGIN BUTTON-HEIGHT) (- h MARGIN BUTTON-HEIGHT)
BUTTON-WIDTH BUTTON-HEIGHT BUTTON-WIDTH BUTTON-HEIGHT
title void)) title void))
(define hit-button (make-button "Hit" 1)) (define hit-button (make-button "Hit" 1))
(define stand-button (make-button "Stand" 2)) (define stand-button (make-button "Stand" 2))
(define split-button (make-button "Split" 0)) (define split-button (make-button "Split" 0))
(define double-button (make-button "Double" 3)) (define double-button (make-button "Double" 3))
;; Put the cards on the table ;; Put the cards on the table
(send t add-cards-to-region deck deck-region) (send t add-cards-to-region deck deck-region)
;; Function to compute the normal or minimum value of a card ;; Function to compute the normal or minimum value of a card
(define (min-card-value c) (define (min-card-value c)
(let ([v (send c get-value)]) (let ([v (send c get-value)]) (if (> v 10) 10 v)))
(if (> v 10)
10
v)))
;; Function to compute the value of a hand, counting aces as 1 or 11 ;; Function to compute the value of a hand, counting aces as 1 or 11
;; to get the highest total possible under 21 ;; to get the highest total possible under 21
(define (best-total l) (define (best-total l)
(let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))] (let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))]
[aces (filter (ace? #t) l)] [aces (filter (ace? #t) l)]
[others (filter (ace? #f) l)] [others (filter (ace? #f) l)]
[base (apply + (map min-card-value others))]) [base (apply + (map min-card-value others))])
(let loop ([l aces][base base]) (let loop ([l aces][base base])
(cond (cond [(null? l) base]
[(null? l) base]
[(<= (+ base (* (length aces) 11)) 21) [(<= (+ base (* (length aces) 11)) 21)
(+ base (* (length aces) 11))] (+ base (* (length aces) 11))]
[else (loop (cdr l) (add1 base))])))) [else (loop (cdr l) (add1 base))]))))
;; Function to test whether a hand is a bust ;; Function to test whether a hand is a bust
(define (bust? p) (define (bust? p)
(> (best-total p) 21)) (> (best-total p) 21))
;; Very simple betting... ;; Very simple betting...
(define money 100) (define money 100)
(define (update-money! d) (define (update-money! d)
(set! money (+ money d)) (set! money (+ money d))
(send t set-status (format "You have $~a. (Each bet is $2.)" money))) (send t set-status (format "You have $~a. (Each bet is $2.)" money)))
;; Let's play! ;; Let's play!
(let shuffle-loop () (let shuffle-loop ()
;; Shuffle the cards, none are discarded, yet ;; Shuffle the cards, none are discarded, yet
(let* ([deck (shuffle-list deck 7)] (let* ([deck (shuffle-list deck 7)]
[discard null] [discard null]
@ -273,8 +261,9 @@
(let ([cont (make-semaphore)]) (let ([cont (make-semaphore)])
(done "Bust" cont) (done "Bust" cont)
(yield cont)))] (yield cont)))]
;; Callback for the hit button; the button's callback ;; Callback for the hit button; the button's callback is
;; is changed for diferent modes: normal, split part 1, or split part 2 ;; changed for diferent modes: normal, split part 1, or split
;; part 2
[make-hit-callback [make-hit-callback
(lambda (get-p set-p! player-region bust) (lambda (get-p set-p! player-region bust)
(lambda () (lambda ()
@ -285,8 +274,7 @@
(send t move-cards-to-region (get-p) player-region) (send t move-cards-to-region (get-p) player-region)
(send t cards-face-up (get-p)) (send t cards-face-up (get-p))
;; Check for bust ;; Check for bust
(when (bust? (get-p)) (when (bust? (get-p)) (bust))))])
(bust))))])
;; Blackjack by player or dealer? ;; Blackjack by player or dealer?
(if (or (= 21 (best-total p)) (if (or (= 21 (best-total p))
(= 21 (best-total d))) (= 21 (best-total d)))
@ -301,16 +289,17 @@
(send t add-region stand-button) (send t add-region stand-button)
(send t add-region double-button) (send t add-region double-button)
;; Set the callbacks for normal (unsplit) hands ;; Set the callbacks for normal (unsplit) hands
(set-region-callback! hit-button (set-region-callback!
(make-hit-callback hit-button
(lambda () p) (make-hit-callback (lambda () p)
(lambda (v) (set! p v)) (lambda (v) (set! p v))
player-region player-region
bust)) bust))
(set-region-callback! stand-button (set-region-callback!
(lambda () stand-button
(semaphore-post continue))) (lambda () (semaphore-post continue)))
(set-region-callback! double-button (set-region-callback!
double-button
(lambda () (lambda ()
;; Note the double for adjusting money on a win ;; Note the double for adjusting money on a win
(set! double? #t) (set! double? #t)
@ -318,30 +307,30 @@
(update-money! -2) (update-money! -2)
;; Deal one more card ;; Deal one more card
((region-callback hit-button)) ((region-callback hit-button))
;; No more cards or actions, but if the player busted, the hit ;; No more cards or actions, but if the player busted, the
;; callback has already continued ;; hit callback has already continued
(unless (bust? p) (unless (bust? p) (semaphore-post continue))))
(semaphore-post continue))))
;; Split allowed? ;; Split allowed?
(when (= (min-card-value (car p)) (min-card-value (cadr p))) (when (= (min-card-value (car p)) (min-card-value (cadr p)))
;; Yes, we can split. If the player hits the split button, ;; Yes, we can split. If the player hits the split button, we
;; we have to split the cards, deal one more to each split ;; have to split the cards, deal one more to each split half
;; half and adjust the callbacks for hit and stand. ;; and adjust the callbacks for hit and stand. (If aces are
;; (If aces are split, the round is over.) ;; split, the round is over.)
(send t add-region split-button) (send t add-region split-button)
(set-region-callback! split-button (set-region-callback!
split-button
(lambda () (lambda ()
;; Double our bet... ;; Double our bet...
(update-money! -2) (update-money! -2)
;; Split the hand ;; Split the hand
(set! p2 (list (cadr p))) (set! p2 (list (cadr p)))
(set! p (list (car p))) (set! p (list (car p)))
;; Move the split halves to the "waiting" area. The ;; Move the split halves to the "waiting" area. The active
;; active area is reserved for hands that are being ;; area is reserved for hands that are being played
;; played
(send t move-cards-to-region p player-1-wait-region) (send t move-cards-to-region p player-1-wait-region)
(send t move-cards-to-region p2 player-2-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! p (append (deal 1) p))
(set! p2 (append (deal 1) p2)) (set! p2 (append (deal 1) p2))
(send t stack-cards p) (send t stack-cards p)
@ -361,7 +350,8 @@
(send t move-cards-to-region p2 player-2-wait-region) (send t move-cards-to-region p2 player-2-wait-region)
;; Let the main loop finish up ;; Let the main loop finish up
(semaphore-post continue))] (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 [switch
(lambda () (lambda ()
;; Unhilite the first hand ;; Unhilite the first hand
@ -391,7 +381,8 @@
(send t move-cards-to-region p player-1-region) (send t move-cards-to-region p player-1-region)
;; Hilite the first hand ;; Hilite the first hand
(send t add-region player-1-border) (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! (set-region-callback!
hit-button hit-button
(make-hit-callback (lambda () p) (make-hit-callback (lambda () p)
@ -402,9 +393,7 @@
(switch) (switch)
(send t add-region hit-button) (send t add-region hit-button)
(send t add-region stand-button)))) (send t add-region stand-button))))
(set-region-callback! (set-region-callback! stand-button switch)))))))
stand-button
switch)))))))
;; Wait until the player is done ;; Wait until the player is done
(yield continue) (yield continue)
;; No more player actions; get rid of the buttons ;; No more player actions; get rid of the buttons
@ -412,10 +401,9 @@
(send t remove-region stand-button) (send t remove-region stand-button)
(send t remove-region double-button) (send t remove-region double-button)
(send t remove-region split-button) (send t remove-region split-button)
;; If all the player's hards are bust, the dealer doesn't do anything ;; If all the player's hards are bust, the dealer doesn't do
(unless (and (bust? p) ;; anything
(or (null? p2) (unless (and (bust? p) (or (null? p2) (bust? p2)))
(bust? p2)))
;; Show the dealer's starting hand ;; Show the dealer's starting hand
(send t card-face-up (cadr d)) (send t card-face-up (cadr d))
(let loop () (let loop ()
@ -442,9 +430,11 @@
(set! discard (append p p2 d discard)) (set! discard (append p p2 d discard))
(send t cards-face-down discard) (send t cards-face-down discard)
(send t move-cards-to-region discard discard-region) (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) (if (< (length deck) min-deck-size)
(begin (begin (send t move-cards-to-region deck discard-region)
(send t move-cards-to-region deck discard-region)
(shuffle-loop)) (shuffle-loop))
(loop))))))))))) (loop))))))))
))

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

@ -1,27 +1,26 @@
** To play _Blackjack_, run the "Games" application. ** ** To play Blackjack, run the "PLT Games" application.
Standard Blackjack rules, plus the following specifics: Standard Blackjack rules, plus the following specifics:
* 1 player (not counting the dealer) * 1 player (not counting the dealer)
* 4 decks, reshuffled after 3/4 of the cards are used * 4 decks, reshuffled after 3/4 of the cards are used
* Dealer stands on soft 17s * Dealer stands on soft 17s
* Splitting is allowed only on the first two cards, and only if * Splitting is allowed only on the first two cards, and only if they
they are equal; 10 and the face cards are all considered equal are equal; 10 and the face cards are all considered equal for
for splitting splitting
* Doubling is allowed on all unsplit hands, not on split hands * Doubling is allowed on all unsplit hands, not on split hands
* No blackjacks after splitting * No blackjacks after splitting
* No surrender * No surrender
* No insurance * No insurance
* No maximum under-21 hand size * 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)

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

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

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

181
collects/games/games.ss
View File

@ -1,114 +1,97 @@
(module games mzscheme #lang scheme/gui
(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")
(define game-mapping (require setup/getinfo mrlib/bitmap-label "show-help.ss")
(let ([games (let ([d (collection-path "games")])
(filter (lambda (f) (define-struct game (file name set icon))
(let ([p (build-path d f)])
(and (directory-exists? p) (define gamedir (collection-path "games"))
(with-handlers ([exn:fail? (lambda (x) #f)])
((get-info (list (string->path "games") f)) 'game (lambda () #f)))))) (define (get-game game)
(directory-list d)))]) (let* ([game (path-element->string game)]
(map (lambda (g) [info (with-handlers ([exn:fail? (lambda (x) #f)])
(let ([info (get-info `(,(string->path "games") ,g))]) (get-info (list "games" game)))]
(list (path->string g) [main (and info (info 'game (lambda () #f)))]
(info 'game (lambda () "wrong.ss")) [gamefile (lambda (f) (build-path gamedir game f))])
(info 'name (lambda () g)) (and main
(make-game
(gamefile main)
(info 'name (lambda () (string-titlecase game)))
(info 'game-set (lambda () "Other Games")) (info 'game-set (lambda () "Other Games"))
(info 'game-icon (lambda () (build-path (collection-path "games" g) (info 'game-icon (lambda () (gamefile (format "~a.png" game))))))))
(format "~a.png" g)))))))
games)))
(define f (new (class frame% (define (run-game game)
(augment* (define c (make-custodian))
[on-close (lambda () (exit))]) (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))])
(super-new)) (super-new))
[label "PLT Games"] [label "PLT Games"]
[style '(metal no-resize-border)])) [style '(metal no-resize-border)]))
(define hp (make-object horizontal-panel% f)) (define main (make-object horizontal-panel% f))
(define main (make-object vertical-panel% hp)) (send f set-alignment 'left 'top)
(send f set-alignment 'left 'top) (send f stretchable-width #f)
(send f stretchable-width #f) (send f stretchable-height #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) (define show-games-help (show-help '("games") "About PLT Games"))
(let* ([collect (car desc)]
[file (cadr desc)] (application-about-handler show-games-help)
[name (caddr desc)] (application-preferences-handler
[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 () (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"))
(application-about-handler show-games-help)
(application-preferences-handler (lambda ()
(message-box (message-box
"Oops" "Oops"
"There aren't actually any preferences. This is just a test for Mac OS X" "There aren't actually any preferences. This is just a test for Mac OS X"
f f
'(ok)))) '(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: See the following for the principles:
http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html 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. 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 Cells hold cube objects, which can be dragged between cells (with a
exceptions that are listed below). The working areas are: few exceptions that are listed below). The working areas are:
1. The right side is the storage area. 1. The right side is the storage area. This is used for saving
This is used for saving objects -- drag any cube to/from here. Note objects -- drag any cube to/from here. Note that cubes can be
that cubes can be named for convenience. named for convenience.
2. The left side is a panel of basic color cubes. 2. The left side is a panel of basic color cubes. These cells always
These cells always contain a set of basic cubes that are used as the contain a set of basic cubes that are used as the primitive
primitive building blocks all other values are made of. They cannot building blocks all other values are made of. They cannot be
be overwritten. (Note that this includes a transparent cell.) overwritten. (Note that this includes a transparent cell.)
3. The center part is the working panel. 3. The center part is the working panel. This is the main panel where
This is the main panel where new cubes are constructed. The center new cubes are constructed. The center cell is similar to a storage
cell is similar to a storage cell, and the surrounding eight cells cell, and the surrounding eight cells all perform some operation on
all perform some operation on this cell. this cell.
User Interaction User Interaction
---------------- ----------------
Right-click any cell except for the basic colors on the left panel, or 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 hit escape or F10 for a menu of operations. The menu also includes
keyboard shortcuts for these operations. the keyboard shortcuts for these operations.
Cube operations Cube operations
@ -41,38 +42,38 @@ Cube operations
There are six simple operations that are considered part of the simple There are six simple operations that are considered part of the simple
graphic cube world. The operations correspond to six of the operation 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 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 cells, a top-bottom using the top and the bottom, and a front-back
the top-left and bottom-right. Dragging a cube to one of these cells using the top-left and bottom-right. Dragging a cube to one of these
will use the corresponding operator to combine it with the main cell's cells will use the corresponding operator to combine it with the main
cube. Using a right mouse click on one of these cells can be used to cell's cube. Using a right mouse click on one of these cells can be
cancel dragging an object to that cell, this is not really an undo used to cancel dragging an object to that cell, this is not really an
feature: a right-click on the right cell always splits the main cube to undo feature: a right-click on the right cell always splits the main
two halves and throws the right side. cube to two halves and throws the right side.
The colored cubes and the six basic operators make this simple domain, The colored cubes and the six basic operators make this simple domain,
which is extended to form a Lambda-Calculus-like language by adding which is extended to form a Lambda-Calculus-like language by adding
abstractions and applications. Right-clicking on a basic cube on the abstractions and applications. Right-clicking on a basic cube on the
left panel creates an abstraction which is actually a lambda expression left panel creates an abstraction which is actually a lambda
except that colors are used instead of syntactic variables. For expression except that colors are used instead of syntactic variables.
example, if the main cell contains `R|G' (red-green on the left and For example, if the main cell contains `R|G' (red-green on the left
right), then right-clicking the green cube on the left panel leaves us and right), then right-clicking the green cube on the left panel
with `lambda G . R|G', which is visualized as `R|G' with a green circle. leaves us with `lambda G . R|G', which is visualized as `R|G' with a
The last two operator cells are used for application of these green circle. The last two operator cells are used for application of
abstractions: drag a function to the top-right to have it applied on the these abstractions: drag a function to the top-right to have it
main cube, or to the bottom-left to have the main cube applied to it. applied on the main cube, or to the bottom-left to have the main cube
As in the Lambda Calculus, all abstractions have exactly one variable, applied to it. As in the Lambda Calculus, all abstractions have
use currying for multiple variables. exactly one variable, use currying for multiple variables.
So far the result is a domain of colored cubes that can be used in the 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 same way as the simple Lambda Calculus. There is one last extension
that goes one step further: function cubes can themselves be combined that goes one step further: function cubes can themselves be combined
with other functions using the simple operations. This results in with other functions using the simple operations. This results in a
a form of "spatial functions" that behave differently in different parts form of "spatial functions" that behave differently in different parts
of the cube according to the construction. For example, a left-right 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 construction of two functions `f|g' operates on a given cube by
`f' on its left part and `g' on its right part. You can use the applying `f' on its left part and `g' on its right part. You can use
preferences dialog to change a few aspects of the computation. the preferences dialog to change a few aspects of the computation.
Use the "Open Example" menu entry to open a sample file that contains Use the "Open Example" menu entry to open a sample file that contains
lots of useful objects (Church numerals, booleans, lists, Y-combinator, lots of useful objects (Church numerals, booleans, lists,
etc). Y-combinator, etc).

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

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

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

@ -1,144 +1,127 @@
#lang mzscheme
(module ginrummy mzscheme (require (lib "cards.ss" "games" "cards")
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss") (lib "unit.ss")
(lib "list.ss")) (lib "list.ss"))
(provide game@) (provide game@)
(define game@ (unit (import) (export)
(define game@ ;; Initial card count
(unit (define DEAL-COUNT 10)
(import)
(export)
;; Initial card count ;; Messages
(define DEAL-COUNT 10) (define YOUR-TURN-MESSAGE "Your turn. (Draw a card or pickup a discard.)")
(define DISCARD-MESSAGE "Drag a card from your hand to discard.")
(define GAME-OVER-MESSAGE "GAME OVER")
;; Messages ;; Area labels
(define YOUR-TURN-MESSAGE "Your turn. (Draw a card or pickup a discard.)") (define YOU-NAME "You")
(define DISCARD-MESSAGE "Drag a card from your hand to discard.") (define MACHINE-NAME "Opponent")
(define GAME-OVER-MESSAGE "GAME OVER")
;; Area labels ;; Region layout constants
(define YOU-NAME "You") (define MARGIN 5)
(define MACHINE-NAME "Opponent") (define LABEL-H 15)
;; Region layout constants ;; Randomize
(define MARGIN 5) (random-seed (modulo (current-milliseconds) 10000))
(define LABEL-H 15)
;; Randomize ;; Set up the table
(random-seed (modulo (current-milliseconds) 10000)) (define t (make-table "Rummy" 8 4.5))
(define status-pane (send t create-status-pane))
(send t add-help-button status-pane '("games" "ginrummy") "Rummy Help" #f)
(send t show #t)
(send t set-double-click-action #f)
(send t set-button-action 'left 'drag-raise/one)
(send t set-button-action 'middle 'drag/one)
(send t set-button-action 'right 'drag/above)
;; Set up the table ;; Get table width & height
(define t (make-table "Rummy" 8 4.5)) (define w (send t table-width))
(define status-pane (send t create-status-pane)) (define h (send t table-height))
(send t add-help-button status-pane '("games" "ginrummy") "Rummy Help" #f)
(send t show #t)
(send t set-double-click-action #f)
(send t set-button-action 'left 'drag-raise/one)
(send t set-button-action 'middle 'drag/one)
(send t set-button-action 'right 'drag/above)
;; Get table width & height ;; Set up the cards
(define w (send t table-width)) (define deck (shuffle-list (make-deck) 7))
(define h (send t table-height)) (for-each (lambda (card)
;; Set up the cards
(define deck (shuffle-list (make-deck) 7))
(for-each
(lambda (card)
(send card user-can-move #f) (send card user-can-move #f)
(send card user-can-flip #f)) (send card user-can-flip #f))
deck) deck)
;; Function for dealing or drawing cards ;; Function for dealing or drawing cards
(define (deal n) (define (deal n)
(let loop ([n n][d deck]) (let loop ([n n][d deck])
(if (zero? n) (if (zero? n)
(begin (begin (set! deck d) null)
(set! deck d)
null)
(cons (car d) (loop (sub1 n) (cdr d)))))) (cons (car d) (loop (sub1 n) (cdr d))))))
;; Card width & height ;; Card width & height
(define cw (send (car deck) card-width)) (define cw (send (car deck) card-width))
(define ch (send (car deck) card-height)) (define ch (send (car deck) card-height))
;; Draw and discard pile locations ;; Draw and discard pile locations
(define draw-x (/ (- w (* 3 cw)) 2)) (define draw-x (/ (- w (* 3 cw)) 2))
(define draw-y (/ (- h ch) 2)) (define draw-y (/ (- h ch) 2))
(define discard-x (+ draw-x (* 2 cw))) (define discard-x (+ draw-x (* 2 cw)))
(define discard-y draw-y) (define discard-y draw-y)
;; Put the cards on the table ;; Put the cards on the table
(send t add-cards deck draw-x draw-y) (send t add-cards deck draw-x draw-y)
;; Player region size ;; Player region size
(define pw (- w (* 2 MARGIN))) (define pw (- w (* 2 MARGIN)))
(define ph (- (* 1.75 ch) (* 4 MARGIN))) (define ph (- (* 1.75 ch) (* 4 MARGIN)))
;; Define the regions ;; Define the regions
(define machine-region (define machine-region
(make-region (make-region MARGIN MARGIN pw ph MACHINE-NAME #f))
MARGIN MARGIN pw ph (define you-region
MACHINE-NAME (make-region MARGIN (- h ph MARGIN) pw ph YOU-NAME void))
#f)) (define discard-region
(define you-region (make-region (- discard-x MARGIN) (- discard-y MARGIN)
(make-region
MARGIN (- h ph MARGIN) pw ph
YOU-NAME
void))
(define discard-region
(make-region
(- discard-x MARGIN) (- discard-y MARGIN)
(+ cw (* 2 MARGIN)) (+ ch (* 2 MARGIN)) (+ cw (* 2 MARGIN)) (+ ch (* 2 MARGIN))
"" #f)) "" #f))
;; Install the visible regions ;; Install the visible regions
(send t add-region machine-region) (send t add-region machine-region)
(send t add-region you-region) (send t add-region you-region)
(send t add-region discard-region) (send t add-region discard-region)
;; Deal the initial hands ;; Deal the initial hands
(define machine-hand (deal DEAL-COUNT)) (define machine-hand (deal DEAL-COUNT))
(define you-hand (deal DEAL-COUNT)) (define you-hand (deal DEAL-COUNT))
;; Function to inset a region ;; Function to inset a region
(define (region->display-region r) (define (region->display-region r)
(define m MARGIN) (define m MARGIN)
(make-region (make-region (+ m (region-x r)) (+ m (region-y r))
(+ m (region-x r)) (+ m (region-y r))
(- (region-w r) (* 2 m)) (- (region-h r) (* 2 m)) (- (region-w r) (* 2 m)) (- (region-h r) (* 2 m))
#f #f)) #f #f))
;; Place cards nicely ;; Place cards nicely
(define machine-display-region (region->display-region machine-region)) (define machine-display-region (region->display-region machine-region))
(send t move-cards-to-region machine-hand machine-display-region) (send t move-cards-to-region machine-hand machine-display-region)
(send t move-cards-to-region you-hand (region->display-region you-region)) (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 ;; All cards in your hand are movable, but must stay in your region
(for-each (for-each (lambda (card)
(lambda (card)
(send card home-region you-region) (send card home-region you-region)
(send card user-can-move #t)) (send card user-can-move #t))
you-hand) you-hand)
;; More card setup: Show your cards ;; More card setup: Show your cards
(send t cards-face-up you-hand) (send t cards-face-up you-hand)
;; Start the discard pile ;; Start the discard pile
(define discards (deal 1)) (define discards (deal 1))
(send t card-face-up (car discards)) (send t card-face-up (car discards))
(send t move-card (car discards) discard-x discard-y) (send t move-card (car discards) discard-x discard-y)
;; ;;;;;;;;;;;;; Finding Rummy and The Machine Player Strategy ;;;;;;;; ;; ;;;;;;;;;;;;; Finding Rummy and The Machine Player Strategy ;;;;;;;;
;; Check whether a group of (at least 3) cards forms a set (building ;; Check whether a group of (at least 3) cards forms a set (building
;; up to gin). ;; up to gin).
(define (set? cards) (define (set? cards)
(let ([values (map (lambda (c) (send c get-value)) cards)] (let ([values (map (lambda (c) (send c get-value)) cards)]
[suits (map (lambda (c) (send c get-suit-id)) cards)]) [suits (map (lambda (c) (send c get-suit-id)) cards)])
;; All same value? ... or ;; All same value? ... or
@ -156,35 +139,33 @@
(and (= 1 (car sorted)) (and (= 1 (car sorted))
(try (append (cdr sorted) (list 14)))))))))) (try (append (cdr sorted) (list 14))))))))))
;; Check how close a hand comes to winning by returning the maximum ;; Check how close a hand comes to winning by returning the maximum number of
;; number of cards that can be arranged into sets. This function is ;; cards that can be arranged into sets. This function is used both to detect
;; used both to detect gin for the end-of-game condition, and also ;; gin for the end-of-game condition, and also as part of the machine player's
;; as part of the machine player's strategy. ;; strategy.
(define (gin-size cards) (define (gin-size cards)
(if (<= (length cards) 2) (if (<= (length cards) 2)
0 0
(let* ([sort (lambda (get) (let* ([sort (lambda (get)
(sort cards (lambda (a b) (< (get a) (get b)))))] (sort cards (lambda (a b) (< (get a) (get b)))))]
;; It's not reasonable to test every combination of 10 cards, ;; It's not reasonable to test every combination of 10 cards, but we
;; but we can cut down the search space a lot by starting ;; can cut down the search space a lot by starting with two
;; with two different sorts on the card list. ;; different sorts on the card list.
;; We sort by value, to find 3-of-a-kind sets, and by ;; We sort by value, to find 3-of-a-kind sets, and by
;; suit-then-value, to find straights. Whatever the ;; suit-then-value, to find straights. Whatever the best allocation
;; best allocation of cards to sets, one of the sets ;; of cards to sets, one of the sets must show up as three cards
;; must show up as three cards together in one of the ;; together in one of the sorted lists. Also, if an extension to
;; sorted lists. Also, if an extension to that set ;; that set leads to an optimal allocation, the extended set
;; leads to an optimal allocation, the extended set
;; corresponds to an extended section of the list. ;; corresponds to an extended section of the list.
[value-sorted (sort (lambda (c) (send c get-value)))] [value-sorted (sort (lambda (c) (send c get-value)))]
[suit-sorted (sort (lambda (c) (+ (* 20 (send c get-suit-id)) (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 ;; Procedure to find a set allocation given one of the sorted
;; lists. It picks each group of three consecutive items ;; lists. It picks each group of three consecutive items from the
;; from the list and see how that choice works out. ;; list and see how that choice works out. (We're still performing
;; (We're still performing a lot of redundant work here, ;; a lot of redundant work here, but it's fast enough.)
;; but it's fast enough.)
[find-set [find-set
(lambda (l) (lambda (l)
;; 3loop tries each group of three items ;; 3loop tries each group of three items
@ -200,32 +181,33 @@
;; No more items? Can't extend the set. Does the ;; No more items? Can't extend the set. Does the
;; set we found work out in the long run? ;; set we found work out in the long run?
(+ (length set) (+ (length set)
(if (null? pre) (if (null? pre) 0 (gin-size pre)))]
0
(gin-size pre)))]
;; Try to extend the set... ;; Try to extend the set...
[(set? (cons (car post) set)) [(set? (cons (car post) set))
;; The set can be extended. ;; The set can be extended. Maybe this
;; Maybe this extension works in the long run... ;; extension works in the long run...
(max (exloop (cons (car post) set) (cdr post)) (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))))] (+ (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) [else (+ (length set)
(gin-size (append pre post)))]))) (gin-size (append pre post)))])))
0) 0)
;; Try next three, if possible ;; Try next three, if possible
(if (null? post) (if (null? post)
0 0
;; Rotate the group, pulling a new last item in from post ;; Rotate the group, pulling a new last item in from
;; and kicking the first item out to pre. ;; post and kicking the first item out to pre.
(3loop (cons (car group) pre) (3loop (cons (car group) pre)
(list (cadr group) (caddr group) (car post)) (list (cadr group) (caddr group) (car post))
(cdr post))))))]) (cdr post))))))])
;; Try the value-sorted list, the the suit-sorted list, then... ;; Try the value-sorted list, the the suit-sorted list, then...
(max (find-set value-sorted) (max (find-set value-sorted)
(find-set suit-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]) (let ace-loop ([pre null][l suit-sorted])
(cond (cond
[(null? l) [(null? l)
@ -234,7 +216,8 @@
[(null? (cdr l)) [(null? (cdr l))
;; No more aces to find ;; No more aces to find
(find-set (reverse (cons (car l) pre)))] (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)) [(and (= 1 (send (car l) get-value))
(= (send (car l) get-suit-id) (send (cadr l) get-suit-id))) (= (send (car l) get-suit-id) (send (cadr l) get-suit-id)))
;; Ace is at beginning; move it to the end ;; Ace is at beginning; move it to the end
@ -242,8 +225,7 @@
[ace-suit (send ace get-suit-id)]) [ace-suit (send ace get-suit-id)])
(let loop ([pre (cons (cadr l) pre)][l (cddr l)]) (let loop ([pre (cons (cadr l) pre)][l (cddr l)])
;; At end of this suit? ;; At end of this suit?
(if (or (null? l) (if (or (null? l) (> (send (car l) get-suit-id) ace-suit))
(> (send (car l) get-suit-id) ace-suit))
;; At the end; add Ace here ;; At the end; add Ace here
(ace-loop (cons ace pre) l) (ace-loop (cons ace pre) l)
;; still looking for new spot for Ace ;; still looking for new spot for Ace
@ -252,24 +234,23 @@
;; Didn't find an ace; keep looking ;; Didn't find an ace; keep looking
(ace-loop (cons (car l) pre) (cdr l))])))))) (ace-loop (cons (car l) pre) (cdr l))]))))))
;; A hand wins if the biggest gin configuration includes all the cards ;; A hand wins if the biggest gin configuration includes all the cards
(define (gin? cards) (define (gin? cards)
(= (gin-size cards) (length cards))) (= (gin-size cards) (length cards)))
;; This procedure is the second part of the machine's strategy. If ;; This procedure is the second part of the machine's strategy. If the machine
;; the machine sees two choices that are equally good according to ;; sees two choices that are equally good according to gin-size, then it
;; gin-size, then it computes a rating based on pairs, i.e., cards ;; computes a rating based on pairs, i.e., cards that might eventually go
;; that might eventually go together in a set. ;; together in a set.
(define (pair-rating cards gone-cards) (define (pair-rating cards gone-cards)
(let ([suits (map (lambda (card) (send card get-suit-id)) cards)] (let ([suits (map (lambda (card) (send card get-suit-id)) cards)]
[values (map (lambda (card) (send card get-value)) cards)]) [values (map (lambda (card) (send card get-value)) cards)])
;; Its O(n*n), but n is always 10 or 11 ;; Its O(n*n), but n is always 10 or 11
(apply + (apply
(map (lambda (suit value) + (map (lambda (suit value)
(apply + (apply
(map (lambda (suit2 value2) + (map (lambda (suit2 value2)
(cond (cond [(= value value2)
[(= value value2)
(- 2 (count-gone value gone-cards))] (- 2 (count-gone value gone-cards))]
[(= suit suit2) [(= suit suit2)
(rate-straight suit value value2 gone-cards)] (rate-straight suit value value2 gone-cards)]
@ -277,46 +258,37 @@
suits values))) suits values)))
suits values)))) suits values))))
;; count-gone checks how many of a given value are known ;; count-gone checks how many of a given value are known to be permanently
;; to be permanently discarded ;; discarded
(define (count-gone value gone-cards) (define (count-gone value gone-cards)
(cond (cond [(null? gone-cards) 0]
[(null? gone-cards) 0]
[(= value (send (car gone-cards) get-value)) [(= value (send (car gone-cards) get-value))
(+ 1 (count-gone value (cdr gone-cards)))] (+ 1 (count-gone value (cdr gone-cards)))]
[else (count-gone value (cdr gone-cards))])) [else (count-gone value (cdr gone-cards))]))
;; count-avail checks whether a given value/suit is ;; count-avail checks whether a given value/suit is
;; known to be discarded (returns 0) or not (returns 1) ;; known to be discarded (returns 0) or not (returns 1)
(define (count-avail value suit gone-cards) (define (count-avail value suit gone-cards)
(cond (cond [(null? gone-cards) 1]
[(null? gone-cards) 1]
[(and (= value (send (car gone-cards) get-value)) [(and (= value (send (car gone-cards) get-value))
(= suit (send (car gone-cards) get-suit-id))) (= suit (send (car gone-cards) get-suit-id)))
0] 0]
[else (count-avail value suit (cdr gone-cards))])) [else (count-avail value suit (cdr gone-cards))]))
;; rates the possibility for forming a straight given ;; rates the possibility for forming a straight given two card values in a
;; two card values in a particular suit, and taking ;; particular suit, and taking into account cards known to be discarded; the
;; into account cards known to be discarded; the ;; rating is the number of non-discarded cards that would form a straight with
;; rating is the number of non-discarded cards that ;; the given values
;; would form a straight with the given values (define (rate-straight suit value value2 gone-cards)
(define (rate-straight suit value value2 gone-cards)
(let ([v1 (if (= value 1) (let ([v1 (if (= value 1)
(if (value2 . > . 6) (if (value2 . > . 6) 14 1)
14
1)
value)] value)]
[v2 (if (= value2 1) [v2 (if (= value2 1)
(if (value . > . 6) (if (value . > . 6) 14 1)
14
1)
value2)]) value2)])
(let ([delta (abs (- v1 v2))]) (let ([delta (abs (- v1 v2))])
(cond (cond [(= delta 1)
[(= delta 1) (cond [(or (= v1 1) (= v2 1))
(cond
[(or (= v1 1) (= v2 1))
;; Might get the 3? ;; Might get the 3?
(count-avail 3 suit gone-cards)] (count-avail 3 suit gone-cards)]
[(or (= v1 14) (= v2 14)) [(or (= v1 14) (= v2 14))
@ -336,11 +308,11 @@
(count-avail middle suit gone-cards))] (count-avail middle suit gone-cards))]
[else 0])))) [else 0]))))
;; The procedure implements the machine's card-drawing choice ;; The procedure implements the machine's card-drawing choice
(define (machine-wants-card? machine-hand card gone-cards) (define (machine-wants-card? machine-hand card gone-cards)
;; Simple strategy: the machine wants the card if taking it will ;; Simple strategy: the machine wants the card if taking it will make the
;; make the gin-size of its hand increase, or if taking it will not ;; gin-size of its hand increase, or if taking it will not make the gin-size
;; make the gin-size decrease but will increase the pair rating. ;; decrease but will increase the pair rating.
(let* ([orig-size (gin-size machine-hand)] (let* ([orig-size (gin-size machine-hand)]
[new-hand (remq (machine-discard (cons card machine-hand) gone-cards) [new-hand (remq (machine-discard (cons card machine-hand) gone-cards)
(cons card machine-hand))] (cons card machine-hand))]
@ -350,41 +322,40 @@
(> (pair-rating new-hand gone-cards) (> (pair-rating new-hand gone-cards)
(pair-rating machine-hand gone-cards)))))) (pair-rating machine-hand gone-cards))))))
;; The procedure implements the machine's discard choice ;; The procedure implements the machine's discard choice
(define (machine-discard machine-hand gone-cards) (define (machine-discard machine-hand gone-cards)
;; Discard the card that leaves the hand with the largest ;; Discard the card that leaves the hand with the largest gin-size. If
;; gin-size. If multiple cards leave the same largest gin size, ;; multiple cards leave the same largest gin size, pick card leaving the best
;; pick card leaving the best pair rating. ;; pair rating.
(let* ([gin-size-card-pairs (let* ([gin-size-card-pairs
(map (lambda (card) (cons (gin-size (remq card machine-hand)) (map (lambda (card) (cons (gin-size (remq card machine-hand)) card))
card))
machine-hand)] machine-hand)]
[most (apply max (map car gin-size-card-pairs))] [most (apply max (map car gin-size-card-pairs))]
[best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)] [best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)]
[best-cards (map cdr best)] [best-cards (map cdr best)]
[rating-card-pairs [rating-card-pairs
(map (lambda (card) (cons (pair-rating (remq card machine-hand) gone-cards) (map (lambda (card)
card)) (cons (pair-rating (remq card machine-hand) gone-cards) card))
best-cards)] best-cards)]
[most (apply max (map car rating-card-pairs))] [most (apply max (map car rating-card-pairs))]
[best (filter (lambda (x) (= most (car x))) rating-card-pairs)]) [best (filter (lambda (x) (= most (car x))) rating-card-pairs)])
(cdar best))) (cdar best)))
;; ;;;;;; Game Loop ;;;;;;;; ;; ;;;;;; Game Loop ;;;;;;;;
;; This procedure finalizes the display when the game is over ;; This procedure finalizes the display when the game is over
(define (end-of-game why) (define (end-of-game why)
(send t set-status-text (send t set-status-text
(format "~aGame over. ~a." (format
"~aGame over. ~a."
why why
(cond (cond [(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal
[(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal
[(gin? you-hand) "You win"] [(gin? you-hand) "You win"]
[else "Opponent wins"]))) [else "Opponent wins"])))
(send t cards-face-up machine-hand)) (send t cards-face-up machine-hand))
;; Deck empty? Shuffle the discard pile (preserving the top discard) ;; Deck empty? Shuffle the discard pile (preserving the top discard)
(define (check-empty-deck) (define (check-empty-deck)
(when (null? deck) (when (null? deck)
(set! deck (shuffle-list (cdr discards) 7)) (set! deck (shuffle-list (cdr discards) 7))
(set! discards (list (car discards))) (set! discards (list (car discards)))
@ -392,8 +363,8 @@
(send t stack-cards deck) (send t stack-cards deck)
(send t move-cards deck draw-x draw-y))) (send t move-cards deck draw-x draw-y)))
;; Check for starge start... ;; Check for starge start...
(if (or (gin? you-hand) (gin? machine-hand)) (if (or (gin? you-hand) (gin? machine-hand))
;; Someone was delt gin - game over ;; Someone was delt gin - game over
(end-of-game "Dealt gin. ") (end-of-game "Dealt gin. ")
@ -401,7 +372,8 @@
(let loop () (let loop ()
(check-empty-deck) (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) user-can-move #t)
(send (car discards) snap-back-after-move #t) (send (car discards) snap-back-after-move #t)
(send (car deck) user-can-move #t) (send (car deck) user-can-move #t)
@ -430,9 +402,9 @@
(send (car discards) home-region #f)) (send (car discards) home-region #f))
(set-region-callback! you-region #f) (set-region-callback! you-region #f)
(set-region-interactive-callback! you-region #f))) (set-region-interactive-callback! you-region #f)))
;; Interactive callback: change home of card if region is hilited. ;; Interactive callback: change home of card if region is hilited. As a
;; As a result, the card snaps to where you put it instead of back ;; result, the card snaps to where you put it instead of back to its
;; to its original position. ;; original position.
(set-region-interactive-callback! (set-region-interactive-callback!
you-region you-region
(lambda (on? cards) (lambda (on? cards)
@ -469,8 +441,7 @@
(set-region-interactive-callback! (set-region-interactive-callback!
discard-region discard-region
(lambda (on? cards) (lambda (on? cards)
(send (car cards) home-region (send (car cards) home-region (if on? discard-region you-region))))
(if on? discard-region you-region))))
;; Wait for action ;; Wait for action
(yield something-happened)) (yield something-happened))
@ -509,5 +480,6 @@
(end-of-game "") (end-of-game "")
;; Next turn ;; 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: "Gobblet!" is a board game from Blue Orange Games:
http://www.blueorangegames.com/ 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 * 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, placed/moved on top of a smaller piece already on the board,
"gobbling" the smaller piece. The smaller piece does not have to be "gobbling" the smaller piece. The smaller piece does not have to
an opponent's piece, and the smaller piece may itself have gobbled be an opponent's piece, and the smaller piece may itself have
another piece previously. gobbled another piece previously.
* Only visible pieces can be moved, and only visible pieces count * Only visible pieces can be moved, and only visible pieces count
toward winning. Gobbled pieces stay on the board, however, and when toward winning. Gobbled pieces stay on the board, however, and
a piece is moved, any piece that it gobbled stays put and becomes when a piece is moved, any piece that it gobbled stays put and
visible. becomes visible.
* If moving a piece exposes a winning sequence for the opponent, and * 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 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 * 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 moved on that turn. In other words, you're not allowed to peek
under a piece to remind yourself whether it gobbled anything. If under a piece to remind yourself whether it gobbled anything. If
the piece can't be moved, the player forfeits. This particular rule the piece can't be moved, the player forfeits. This particular
is not enforced by our version --- in part because our version rule is not enforced by our version --- in part because our version
supports a rewind button, which is also not in the official game. supports a rewind button, which is also not in the official game.
The 4x4 game has a few changes: 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 works on your machine, you may have to click the board area to make
these controls work. these controls work.
The button labeled "<" at the bottom of the window rewinds the game The button labeled "<" at the bottom of the window rewinds the game by
by one turn. The button labeled ">" re-plays one turn in a rewound one turn. The button labeled ">" re-plays one turn in a rewound game.
game. An alternate move can be made at any point 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. replacing the old game from that point on.
Auto-Play Auto-Play
--------- ---------
Turn on a computer player at any time by checking the "Auto-Play Red" 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 or "Auto-Play Yellow" checkbox. If you rewind the game, you can
an alternate move for yourself or for the auto-player to find out what choose an alternate move for yourself or for the auto-player to find
would have happened. The auto-player is not always deterministic, so out what would have happened. The auto-player is not always
replying the same move might lead to a different result. You can deterministic, so replying the same move might lead to a different
disable an auto-player at any point by unchecking the corresponding result. You can disable an auto-player at any point by unchecking the
"Auto-Play" checkbox. corresponding "Auto-Play" checkbox.
Important: In the 3x3 game, you CANNOT win as yellow against the smart 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 auto-player (if the auto-player is allowed to play red from the start

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

@ -1,5 +1,5 @@
(module gobblet mzscheme #lang mzscheme
(require (lib "unitsig.ss") (require (lib "unitsig.ss")
(only (lib "unit.ss") unit import export) (only (lib "unit.ss") unit import export)
(lib "file.ss") (lib "file.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
@ -10,21 +10,19 @@
"explore.ss" "explore.ss"
"../show-help.ss") "../show-help.ss")
(provide game@) (provide game@)
(define game@ (define game@
(unit (unit (import) (export)
(import)
(export)
(define (make-gobblet-unit size) (define (make-gobblet-unit size)
(compound-unit/sig (compound-unit/sig
(import) (import)
(link [CONFIG : config^ ((unit/sig config^ (link [CONFIG : config^
(import) ((unit/sig config^ (import)
(define BOARD-SIZE size)))] (define BOARD-SIZE size)))]
[RESTART : restart^ ((unit/sig restart^ [RESTART : restart^
(import) ((unit/sig restart^ (import)
(define (new-game n) (define (new-game n)
(put-preferences '(gobblet:board-size) (list n) void) (put-preferences '(gobblet:board-size) (list n) void)
(parameterize ([current-eventspace orig-eventspace]) (parameterize ([current-eventspace orig-eventspace])
@ -51,12 +49,12 @@
(define (start-gobblet board-size) (define (start-gobblet board-size)
;; Start a new game as a child process: ;; Start a new game as a child process:
(parameterize ([current-custodian (make-custodian)]) (parameterize* ([current-custodian (make-custodian)]
(parameterize ([exit-handler (lambda (v) [exit-handler
(custodian-shutdown-all (current-custodian)))]) (lambda (v)
(parameterize ([current-eventspace (make-eventspace)]) (custodian-shutdown-all (current-custodian)))]
[current-eventspace (make-eventspace)])
(queue-callback (queue-callback
(lambda () (lambda () (invoke-unit/sig (make-gobblet-unit board-size))))))
(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 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. you cards by forming pairs. You play against two computer players.

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

@ -1,104 +1,93 @@
#lang mzscheme
(module gofish mzscheme (require (lib "cards.ss" "games" "cards")
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss") (lib "unit.ss")
(lib "list.ss")) (lib "list.ss"))
(provide game@) (provide game@)
(define game@ (unit (import) (export)
(define game@ ;; Player record
(unit (define-struct player (r hand-r discard-r count-r ; regions
(import)
(export)
;; Player record
(define-struct player (r hand-r discard-r count-r ; regions
hand discarded ; cards hand discarded ; cards
tried)) ; memory for simulating players tried)) ; memory for simulating players
;; Player names ;; Player names
(define PLAYER-1-NAME "Opponent 1") (define PLAYER-1-NAME "Opponent 1")
(define PLAYER-2-NAME "Opponent 2") (define PLAYER-2-NAME "Opponent 2")
(define YOUR-NAME "You") (define YOUR-NAME "You")
;; Initial card count ;; Initial card count
(define DEAL-COUNT 7) (define DEAL-COUNT 7)
;; Messages ;; Messages
(define YOUR-TURN-MESSAGE "Your turn. (Drag a match to your discard box or drag a card to an opponent.)") (define YOUR-TURN-MESSAGE
(define GO-FISH-MESSAGE "Go Fish! (Drag a card from the center deck to your box.)") "Your turn. (Drag a match to your discard box or drag a card to an opponent.)")
(define MATCH-MESSAGE "Match!") (define GO-FISH-MESSAGE
(define GAME-OVER-MESSAGE "GAME OVER") "Go Fish! (Drag a card from the center deck to your box.)")
(define MATCH-MESSAGE "Match!")
(define GAME-OVER-MESSAGE "GAME OVER")
;; Region layout constants ;; Region layout constants
(define MARGIN 10) (define MARGIN 10)
(define SUBMARGIN 10) (define SUBMARGIN 10)
(define LABEL-H 15) (define LABEL-H 15)
;; Randomize ;; Randomize
(random-seed (modulo (current-milliseconds) 10000)) (random-seed (modulo (current-milliseconds) 10000))
;; Set up the table ;; Set up the table
(define t (make-table "Go Fish" 8 4.5)) (define t (make-table "Go Fish" 8 4.5))
(define status-pane (send t create-status-pane)) (define status-pane (send t create-status-pane))
(send t add-help-button status-pane '("games" "gofish") "Go Fish Help" #f) (send t add-help-button status-pane '("games" "gofish") "Go Fish Help" #f)
(send t show #t) (send t show #t)
(send t set-double-click-action #f) (send t set-double-click-action #f)
(send t set-button-action 'left 'drag-raise/one) (send t set-button-action 'left 'drag-raise/one)
(send t set-button-action 'middle 'drag/one) (send t set-button-action 'middle 'drag/one)
(send t set-button-action 'right 'drag/one) (send t set-button-action 'right 'drag/one)
;; Get table width & height ;; Get table width & height
(define w (send t table-width)) (define w (send t table-width))
(define h (send t table-height)) (define h (send t table-height))
;; Set up the cards ;; Set up the cards
(define deck (shuffle-list (make-deck) 7)) (define deck (shuffle-list (make-deck) 7))
(for-each (for-each (lambda (card)
(lambda (card)
(send card snap-back-after-move #t) (send card snap-back-after-move #t)
(send card user-can-flip #f)) (send card user-can-flip #f))
deck) deck)
;; Function for dealing or drawing cards ;; Function for dealing or drawing cards
(define (deal n) (define (deal n)
(let loop ([n n][d deck]) (let loop ([n n][d deck])
(if (zero? n) (if (zero? n)
(begin (begin (set! deck d) null)
(set! deck d)
null)
(cons (car d) (loop (sub1 n) (cdr d)))))) (cons (car d) (loop (sub1 n) (cdr d))))))
;; Card width & height ;; Card width & height
(define cw (send (car deck) card-width)) (define cw (send (car deck) card-width))
(define ch (send (car deck) card-height)) (define ch (send (car deck) card-height))
;; Put the cards on the table ;; Put the cards on the table
(send t add-cards (send t add-cards deck (/ (- w cw) 2) (- (/ (- h ch) 2) (/ ch 3)))
deck
(/ (- w cw) 2)
(- (/ (- h ch) 2) (/ ch 3)))
;; Player region size ;; Player region size
(define pw (- (/ (- w cw) 2) (* 2 MARGIN))) (define pw (- (/ (- w cw) 2) (* 2 MARGIN)))
(define ph (- (/ (- h (/ ch 3)) 2) (* 2 MARGIN))) (define ph (- (/ (- h (/ ch 3)) 2) (* 2 MARGIN)))
;; Region-makers ;; Region-makers
(define (make-hand-region r) (define (make-hand-region r)
(define m SUBMARGIN) (define m SUBMARGIN)
(make-region (make-region (+ m (region-x r)) (+ LABEL-H m (region-y r))
(+ m (region-x r)) (+ LABEL-H m (region-y r))
(- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m)) (- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m))
#f #f)) #f #f))
(define (make-discard-region r) (define (make-discard-region r)
(make-region (make-region (- (+ (region-x r) (region-w r)) SUBMARGIN cw)
(- (+ (region-x r) (region-w r)) SUBMARGIN cw)
(- (+ (region-y r) (region-h r)) SUBMARGIN ch) (- (+ (region-y r) (region-h r)) SUBMARGIN ch)
cw ch cw ch
#f #f)) #f #f))
(define (make-discard-count-region r c cb) (define (make-discard-count-region r c cb)
(make-region (make-region
(- (+ (region-x r) (region-w r)) SUBMARGIN cw (/ SUBMARGIN 2)) (- (+ (region-x r) (region-w r)) SUBMARGIN cw (/ SUBMARGIN 2))
(- (+ (region-y r) (region-h r)) SUBMARGIN ch LABEL-H (/ SUBMARGIN 2)) (- (+ (region-y r) (region-h r)) SUBMARGIN ch LABEL-H (/ SUBMARGIN 2))
@ -106,25 +95,16 @@
(number->string c) (number->string c)
cb)) cb))
;; Define the initial regions ;; Define the initial regions
(define player-1-region (define player-1-region
(make-region (make-region MARGIN MARGIN pw ph PLAYER-1-NAME void))
MARGIN MARGIN pw ph (define player-2-region
PLAYER-1-NAME (make-region (- w MARGIN pw) MARGIN pw ph PLAYER-2-NAME void))
void)) (define you-region
(define player-2-region (make-region MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph YOUR-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))
;; Player setup ;; Player setup
(define (create-player r discard-callback) (define (create-player r discard-callback)
(let ([p (make-player (let ([p (make-player
r r
(make-hand-region r) (make-hand-region r)
@ -135,32 +115,29 @@
null)]) null)])
(send t add-region r) (send t add-region r)
(send t add-region (player-count-r p)) (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)) (send t move-cards-to-region (player-hand p) (player-hand-r p))
p)) p))
(define player-1 (create-player player-1-region #f)) (define player-1 (create-player player-1-region #f))
(define player-2 (create-player player-2-region #f)) (define player-2 (create-player player-2-region #f))
(define you (create-player you-region (define you (create-player you-region
;; Dragging to your discard pile checks to see if the card ;; Dragging to your discard pile checks to see if
;; makes a match: ;; the card makes a match:
(lambda (cards) (lambda (cards)
(check-hand you (car cards)) (check-hand you (car cards))
(send t set-status YOUR-TURN-MESSAGE)))) (send t set-status YOUR-TURN-MESSAGE))))
;; More card setup: Opponents's cards and deck initally can't be moved ;; More card setup: Opponents's cards and deck initally can't be moved
(for-each (for-each (lambda (card) (send card user-can-move #f))
(lambda (card) (send card user-can-move #f)) (append (player-hand player-1) (player-hand player-2) deck))
(append
(player-hand player-1)
(player-hand player-2)
deck))
;; More card setup: Show your cards ;; More card setup: Show your cards
(send t flip-cards (player-hand you)) (send t flip-cards (player-hand you))
;; Function to update the display for a player record ;; Function to update the display for a player record
(define (rearrange-cards p) (define (rearrange-cards p)
;; Stack cards in 3D first-to-last ;; Stack cards in 3D first-to-last
(send t stack-cards (player-discarded p)) (send t stack-cards (player-discarded p))
(send t stack-cards (player-hand p)) (send t stack-cards (player-hand p))
@ -176,16 +153,16 @@
(send t add-region (player-count-r p)) (send t add-region (player-count-r p))
(send t end-card-sequence)) (send t end-card-sequence))
;; Function to search for an equivalent card ;; Function to search for an equivalent card
(define (find-equiv card hand) (define (find-equiv card hand)
(ormap (lambda (c) (ormap (lambda (c)
(and (not (eq? c card)) (and (not (eq? c card))
(= (send card get-value) (send c get-value)) (= (send card get-value) (send c get-value))
c)) c))
hand)) hand))
;; Function to check for a match involving `card' already in the player's hand ;; Function to check for a match involving `card' already in the player's hand
(define (check-hand player card) (define (check-hand player card)
(let* ([h (player-hand player)] (let* ([h (player-hand player)]
[found (find-equiv card h)]) [found (find-equiv card h)])
(if found (if found
@ -196,9 +173,8 @@
;; The players has a match! Move the card from the player's hand ;; The players has a match! Move the card from the player's hand
;; to his discard pile ;; to his discard pile
(set-player-hand! player (remove* (list card found) h)) (set-player-hand! player (remove* (list card found) h))
(set-player-discarded! player (cons found (set-player-discarded! player
(cons card (list* found card (player-discarded player)))
(player-discarded player))))
;; The dicarded cards can no longer be moved ;; The dicarded cards can no longer be moved
(send card user-can-move #f) (send card user-can-move #f)
(send found user-can-move #f) (send found user-can-move #f)
@ -208,17 +184,16 @@
#t) #t)
#f))) #f)))
;; Function to enable/disable moving your cards ;; Function to enable/disable moving your cards
(define (enable-your-cards on?) (define (enable-your-cards on?)
(for-each (lambda (c) (send c user-can-move on?)) (for-each (lambda (c) (send c user-can-move on?)) (player-hand you)))
(player-hand you)))
;; Callbacks communicate back to the main loop via these ;; Callbacks communicate back to the main loop via these
(define something-happened (make-semaphore 1)) (define something-happened (make-semaphore 1))
(define go-fish? #f) (define go-fish? #f)
;; Function for trying to get a card from another player ;; Function for trying to get a card from another player
(define (ask-player-for-match getter giver card) (define (ask-player-for-match getter giver card)
(let* ([h (player-hand giver)] (let* ([h (player-hand giver)]
[found (find-equiv card h)]) [found (find-equiv card h)])
(if found (if found
@ -235,14 +210,14 @@
;; The giver player doesn't have it - Go Fish! ;; The giver player doesn't have it - Go Fish!
#f))) #f)))
;; Callback for dragging a card to an opponent ;; Callback for dragging a card to an opponent
(define (player-callback player) (define (player-callback player)
(lambda (cards) (lambda (cards)
(set! go-fish? (not (ask-player-for-match you player (car cards)))) (set! go-fish? (not (ask-player-for-match you player (car cards))))
(semaphore-post something-happened))) (semaphore-post something-happened)))
;; Visual info to go fish ;; Visual info to go fish
(define wiggle-top-card (define wiggle-top-card
(lambda () (lambda ()
(let ([top (car deck)] (let ([top (car deck)]
[x (/ (- w cw) 2)] [x (/ (- w cw) 2)]
@ -251,16 +226,16 @@
(send t move-card top (+ x 10) y) (send t move-card top (+ x 10) y)
(send t move-card top x y)))) (send t move-card top x y))))
;; Callback for going fishing ;; Callback for going fishing
(define fishing (define fishing
(lambda (cards) (lambda (cards)
(send t flip-card (car deck)) (send t flip-card (car deck))
(set-player-hand! you (append (deal 1) (player-hand you))) (set-player-hand! you (append (deal 1) (player-hand you)))
(rearrange-cards you) (rearrange-cards you)
(semaphore-post something-happened))) (semaphore-post something-happened)))
;; Function to simulate a player ;; Function to simulate a player
(define (simulate-player player other-player k) (define (simulate-player player other-player k)
;; Try cards in the players hand that haven't been tried ;; Try cards in the players hand that haven't been tried
(let ([cards-to-try (remq* (player-tried player) (player-hand player))]) (let ([cards-to-try (remq* (player-tried player) (player-hand player))])
(if (null? cards-to-try) (if (null? cards-to-try)
@ -305,25 +280,24 @@
;; End of our turn ;; End of our turn
(k)))))))))) (k))))))))))
;; Function to check for end-of-game ;; Function to check for end-of-game
(define (check-done k) (define (check-done k)
(if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you)) (if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you))
(begin (begin (enable-your-cards #f)
(enable-your-cards #f)
(send t set-status GAME-OVER-MESSAGE)) (send t set-status GAME-OVER-MESSAGE))
(k))) (k)))
;; Look in opponents' initial hands for matches ;; Look in opponents' initial hands for matches (Since each player gets 7
;; (Since each player gets 7 cards, it's impossible to run out of cards this way) ;; cards, it's impossible to run out of cards this way)
(define (find-initial-matches player) (define (find-initial-matches player)
(when (ormap (lambda (card) (check-hand player card)) (player-hand player)) (when (ormap (lambda (card) (check-hand player card)) (player-hand player))
;; Found a match in the hand ;; Found a match in the hand
(find-initial-matches player))) (find-initial-matches player)))
(find-initial-matches player-1) (find-initial-matches player-1)
(find-initial-matches player-2) (find-initial-matches player-2)
;; Run the game loop ;; Run the game loop
(let loop () (let loop ()
(set-region-callback! (player-r you) #f) (set-region-callback! (player-r you) #f)
(set-region-callback! (player-r player-1) (player-callback player-1)) (set-region-callback! (player-r player-1) (player-callback player-1))
(set-region-callback! (player-r player-2) (player-callback player-2)) (set-region-callback! (player-r player-2) (player-callback player-2))
@ -335,8 +309,7 @@
;; No more cards; pass ;; No more cards; pass
#f #f
;; Draw a card (wait for the user to drag it) ;; Draw a card (wait for the user to drag it)
(begin (begin (send t set-status GO-FISH-MESSAGE)
(send t set-status GO-FISH-MESSAGE)
(wiggle-top-card) (wiggle-top-card)
(enable-your-cards #f) (enable-your-cards #f)
(set-region-callback! (player-r player-1) #f) (set-region-callback! (player-r player-1) #f)
@ -347,13 +320,10 @@
(enable-your-cards #t) (enable-your-cards #t)
(check-hand you (car (player-hand you))))) (check-hand you (car (player-hand you)))))
(check-done loop) (check-done loop)
(begin (begin (send t set-status PLAYER-1-NAME)
(send t set-status PLAYER-1-NAME)
(simulate-player (simulate-player
player-1 player-2 player-1 player-2
(lambda () (lambda ()
(send t set-status PLAYER-2-NAME) (send t set-status PLAYER-2-NAME)
(simulate-player player-2 player-1 loop)))))) (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 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 more in a row horizontally or vertically in order to score points.
can swap any two jewels that are next to each other up and down or You can swap any two jewels that are next to each other up and down or
left and right. The mechanic is to either: left and right. The mechanic is to either:
* Click the mouse on the first one, then drag in the direction for * 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. adds time to the clock.
Hit spacebar to start a new game then select the difficulty number by 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. pressing '0', '1', '2', '3' or '4'. You can always press 'ESC' to
During playing press 'p' to pause the game. exit. During playing press 'p' to pause the game.
The code is released under the LGPL. The code is released under the LGPL. The code is a conversion of Dave
The code is a conversion of Dave Ashley's C program to Scheme with some Ashley's C program to Scheme with some modifications and enhancements.
modifications and enhancements.
Enjoy. 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 The object of this game is to turn all of the lights off. Click on a
to turn that light off, but beware it will also toggle the lights above, button to turn that light off, but beware it will also toggle the
below to the left and to the right of that button. lights above, below to the left and to the right of that button.
Good luck. Good luck.

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

@ -1,39 +1,35 @@
(module lights-out mzscheme #lang mzscheme
(require "board.ss" (require "board.ss"
"../show-help.ss" "../show-help.ss"
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss")) (lib "unit.ss"))
(provide game@ (provide game@ lights-out^)
lights-out^)
(define-signature lights-out^ (define-signature lights-out^ (init-board))
(init-board))
(define game@ (define game@ (unit (import)
(unit (export lights-out^) ;; : (board -> void) resets the window(s)
(import)
(export lights-out^) ;; : (board -> void) resets the window(s)
(define frame (make-object frame% "Lights Out")) (define frame (make-object frame% "Lights Out"))
(define label-size 30) (define label-size 30)
(define orange (make-object color% 255 165 0)) (define orange (make-object color% 255 165 0))
(define light-orange (make-object color% 255 220 100)) (define light-orange (make-object color% 255 220 100))
(define on-pen (send the-pen-list find-or-create-pen orange 1 'solid)) (define on-pen (send the-pen-list find-or-create-pen orange 1 'solid))
(define on-brush (send the-brush-list find-or-create-brush orange 'solid)) (define on-brush (send the-brush-list find-or-create-brush orange 'solid))
(define off-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)) (define off-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
(define off-brush (send the-brush-list find-or-create-brush "BLACK" 'solid)) (define off-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))
(define dull-on-pen (send the-pen-list find-or-create-pen light-orange 1 'solid)) (define dull-on-pen (send the-pen-list find-or-create-pen light-orange 1 'solid))
(define dull-on-brush (send the-brush-list find-or-create-brush light-orange 'solid)) (define dull-on-brush (send the-brush-list find-or-create-brush light-orange 'solid))
(define dull-off-pen (send the-pen-list find-or-create-pen "DARK GRAY" 1 'solid)) (define dull-off-pen (send the-pen-list find-or-create-pen "DARK GRAY" 1 'solid))
(define dull-off-brush (send the-brush-list find-or-create-brush "DARK GRAY" 'solid)) (define dull-off-brush (send the-brush-list find-or-create-brush "DARK GRAY" 'solid))
(define (flip-one i j) (define (flip-one i j)
(when (and (<= 0 i (- (vector-length current-board) 1)) (when (and (<= 0 i (- (vector-length current-board) 1))
(<= 0 j (- (vector-length current-board) 1))) (<= 0 j (- (vector-length current-board) 1)))
(vector-set! (vector-set!
@ -43,17 +39,17 @@
[(x) 'o] [(x) 'o]
[(o) 'x])))) [(o) 'x]))))
(define (flip-surrounding i j) (define (flip-surrounding i j)
(flip-one i j) (flip-one i j)
(flip-one (- i 1) j) (flip-one (- i 1) j)
(flip-one i (- j 1)) (flip-one i (- j 1))
(flip-one (+ i 1) j) (flip-one (+ i 1) j)
(flip-one i (+ j 1))) (flip-one i (+ j 1)))
(define current-board #f) (define current-board #f)
(define original-board #f) (define original-board #f)
(define board-canvas% (define board-canvas%
(class canvas% (class canvas%
(inherit get-dc get-client-size) (inherit get-dc get-client-size)
@ -83,30 +79,21 @@
(let ([ent (vector-ref (vector-ref current-board j) i)] (let ([ent (vector-ref (vector-ref current-board j) i)]
[dull? (and dull-i [dull? (and dull-i
dull-j dull-j
(or (and (= i dull-i) (or (and (= i dull-i) (= j dull-j))
(= j dull-j)) (and (= i (- dull-i 1)) (= j dull-j))
(and (= i (- dull-i 1)) (and (= i (+ dull-i 1)) (= j dull-j))
(= j dull-j)) (and (= i dull-i) (= j (- dull-j 1)))
(and (= i (+ dull-i 1)) (and (= i dull-i) (= j (+ dull-j 1)))))])
(= j dull-j))
(and (= i dull-i)
(= j (- dull-j 1)))
(and (= i dull-i)
(= j (+ dull-j 1)))))])
(if dull? (if dull?
(if (eq? ent 'x) (if (eq? ent 'x)
(begin (begin (send dc set-pen dull-off-pen)
(send dc set-pen dull-off-pen)
(send dc set-brush dull-off-brush)) (send dc set-brush dull-off-brush))
(begin (begin (send dc set-pen dull-on-pen)
(send dc set-pen dull-on-pen)
(send dc set-brush dull-on-brush))) (send dc set-brush dull-on-brush)))
(if (eq? ent 'x) (if (eq? ent 'x)
(begin (begin (send dc set-pen on-pen)
(send dc set-pen on-pen)
(send dc set-brush on-brush)) (send dc set-brush on-brush))
(begin (begin (send dc set-pen off-pen)
(send dc set-pen off-pen)
(send dc set-brush off-brush))))) (send dc set-brush off-brush)))))
(let-values ([(x y w h) (tile->screen i j)]) (let-values ([(x y w h) (tile->screen i j)])
(send dc draw-rectangle x y w h))))] (send dc draw-rectangle x y w h))))]
@ -123,18 +110,14 @@
(lambda () (lambda ()
(let* ([dc (get-dc)]) (let* ([dc (get-dc)])
(let loop ([j (vector-length current-board)]) (let loop ([j (vector-length current-board)])
(cond (if (zero? j)
[(zero? j) (void)] (void)
[else (begin (let loop ([i (vector-length current-board)])
(let loop ([i (vector-length current-board)]) (if (zero? i)
(cond (void)
[(zero? i) (void)] (begin (draw-tile dc (- i 1) (- j 1))
[else (loop (- i 1)))))
(draw-tile dc (loop (- j 1)))))))]
(- i 1)
(- j 1))
(loop (- i 1))]))
(loop (- j 1))]))))]
[define/override on-event [define/override on-event
(lambda (evt) (lambda (evt)
@ -162,51 +145,42 @@
(lambda () (lambda ()
(send (get-dc) clear) (send (get-dc) clear)
(redraw))] (redraw))]
(super-instantiate () (super-instantiate () (parent frame))))
(parent frame))))
(define board-canvas (make-object board-canvas%)) (define board-canvas (make-object board-canvas%))
(send board-canvas min-width 100) (send board-canvas min-width 100)
(send board-canvas min-height 100) (send board-canvas min-height 100)
(define (copy-board board) (define (copy-board board)
(list->vector (list->vector
(map (lambda (x) (list->vector (vector->list x))) (map (lambda (x) (list->vector (vector->list x)))
(vector->list board)))) (vector->list board))))
(define (init-board new-board) (define (init-board new-board)
(set! current-board new-board) (set! current-board new-board)
(set! original-board (copy-board new-board)) (set! original-board (copy-board new-board))
(send board-canvas on-paint)) (send board-canvas on-paint))
(define button-panel (make-object horizontal-panel% frame)) (define button-panel (make-object horizontal-panel% frame))
(make-object button% "New" button-panel (make-object button% "New" button-panel
(lambda x (lambda x
(let ([res (new-board)]) (let ([res (new-board)])
(when res (when res
(init-board res))))) (init-board res)))))
(make-object button% "Reset" button-panel (make-object button% "Reset" button-panel
(lambda x (lambda x
(init-board original-board))) (init-board original-board)))
(let ([help (show-help (let ([help (show-help (list "games" "lights-out") "Lights Out Help")])
(list "games" "lights-out") (make-object button% "Help" button-panel (lambda x (help))))
"Lights Out Help")])
(make-object button% "Help" button-panel
(lambda x
(help))))
(make-object grow-box-spacer-pane% button-panel) (make-object grow-box-spacer-pane% button-panel)
(send button-panel stretchable-height #f) (send button-panel stretchable-height #f)
(init-board (random-board (+ 3 (init-board (random-board
(random 2) (+ 3 (random 2) (random 2) (random 2) (random 2) (random 2))))
(random 2) ;; (send frame stretchable-width #f)
(random 2) ;; (send frame stretchable-height #f)
(random 2) (send frame show #t)))
(random 2))))
;(send frame stretchable-width #f)
;(send frame stretchable-height #f)
(send frame show #t))))

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

@ -1,39 +1,36 @@
#lang mzscheme
(module memory mzscheme (require (lib "cards.ss" "games" "cards")
(require (lib "cards.ss" "games" "cards")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "unit.ss") (lib "unit.ss")
(lib "list.ss")) (lib "list.ss"))
(provide game@) (provide game@)
(define game@ (define game@ (unit (import) (export)
(unit
(import)
(export)
;; Layout width and height: ;; Layout width and height:
(define WIDTH 5) (define WIDTH 5)
(define HEIGHT 4) (define HEIGHT 4)
(define MAX-MATCHES (/ (* WIDTH HEIGHT) 2)) (define MAX-MATCHES (/ (* WIDTH HEIGHT) 2))
;; Randomize ;; Randomize
(random-seed (modulo (current-milliseconds) 10000)) (random-seed (modulo (current-milliseconds) 10000))
;; Set up the table ;; Set up the table
(define t (make-table "Memory" (+ 2 WIDTH) (+ 1 HEIGHT))) (define t (make-table "Memory" (+ 2 WIDTH) (+ 1 HEIGHT)))
(send t show #t) (send t show #t)
(send t set-double-click-action #f) (send t set-double-click-action #f)
;; Get table width & height ;; Get table width & height
(define w (send t table-width)) (define w (send t table-width))
(define h (send t table-height)) (define h (send t table-height))
;; Set up the cards ;; Set up the cards
(define deck (define deck
(let ([cards (map (lambda (name value) (let ([cards (map (lambda (name value)
(let ([bm (make-object bitmap% (let ([bm (make-object
bitmap%
(build-path (build-path
(collection-path "games" "memory" "images") (collection-path "games" "memory" "images")
(format "~a.png" name)))]) (format "~a.png" name)))])
@ -44,31 +41,30 @@
"jack" "star") "jack" "star")
'(1 2 3 4 5 6 7 8 9 10))]) '(1 2 3 4 5 6 7 8 9 10))])
(append cards (map (lambda (c) (send c copy)) cards)))) (append cards (map (lambda (c) (send c copy)) cards))))
(for-each (for-each (lambda (card)
(lambda (card)
(send card user-can-move #f) (send card user-can-move #f)
(send card user-can-flip #t)) (send card user-can-flip #t))
deck) deck)
;; Card width & height ;; Card width & height
(define cw (send (car deck) card-width)) (define cw (send (car deck) card-width))
(define ch (send (car deck) card-height)) (define ch (send (car deck) card-height))
(define dx (/ cw (+ 2 WIDTH))) (define dx (/ cw (+ 2 WIDTH)))
(define dy (/ ch (+ 1 HEIGHT))) (define dy (/ ch (+ 1 HEIGHT)))
(define match-x (- w cw dx)) (define match-x (- w cw dx))
(define match-y dy) (define match-y dy)
(define time-h (+ 12 5 5)) (define time-h (+ 12 5 5))
(define time-x match-x) (define time-x match-x)
(define time-y (+ ch dy dy)) (define time-y (+ ch dy dy))
;; Put the cards on the table ;; Put the cards on the table
(send t add-cards deck match-x match-y) (send t add-cards deck match-x match-y)
;; Setup ;; Setup
(define (setup) (define (setup)
(reset-timer) (reset-timer)
(set! deck (shuffle-list deck 7)) (set! deck (shuffle-list deck 7))
(send t stack-cards deck) (send t stack-cards deck)
@ -79,15 +75,14 @@
(values (+ dx (* i (+ cw dx))) (values (+ dx (* i (+ cw dx)))
(+ dy (* j (+ ch dy)))))))) (+ dy (* j (+ ch dy))))))))
;; Number of matches found so far: ;; Number of matches found so far:
(define matches 0) (define matches 0)
;; First card flipped, or #f if non flipped, yet ;; First card flipped, or #f if non flipped, yet
(define card-1 #f) (define card-1 #f)
(define (flip-and-match c) (define (flip-and-match c)
(cond (cond [(eq? c card-1)
[(eq? c card-1)
;; Cancel first card ;; Cancel first card
(send t flip-card c) (send t flip-card c)
(set! card-1 #f)] (set! card-1 #f)]
@ -103,14 +98,11 @@
(send t flip-card c) (send t flip-card c)
(send t card-to-front c) (send t card-to-front c)
(run-timer) (run-timer)
(cond (cond [(not card-1)
[(not card-1)
;; That was the first card ;; That was the first card
(set! card-1 c)] (set! card-1 c)]
[(and (equal? (send card-1 get-value) [(and (equal? (send card-1 get-value) (send c get-value))
(send c get-value)) (equal? (send card-1 get-suit) (send c get-suit)))
(equal? (send card-1 get-suit)
(send c get-suit)))
;; Match ;; Match
(send t pause 0.5) (send t pause 0.5)
(send t move-cards (list card-1 c) match-x match-y) (send t move-cards (list card-1 c) match-x match-y)
@ -121,10 +113,10 @@
(send t pause 0.5) (send t pause 0.5)
(send t flip-cards (list card-1 c)) (send t flip-cards (list card-1 c))
(set! card-1 #f)])])) (set! card-1 #f)])]))
(send t set-single-click-action flip-and-match) (send t set-single-click-action flip-and-match)
;; The timer turns out to be the most difficult part: ;; The timer turns out to be the most difficult part:
(define (make-time-region secs) (define (make-time-region secs)
(make-region time-x time-y cw time-h (make-region time-x time-y cw time-h
(if (>= secs 6000) (if (>= secs 6000)
"XX:XX" "XX:XX"
@ -133,11 +125,11 @@
(substring (number->string (+ 100 (quotient secs 60))) 1) (substring (number->string (+ 100 (quotient secs 60))) 1)
(substring (number->string (+ 100 (modulo secs 60))) 1))) (substring (number->string (+ 100 (modulo secs 60))) 1)))
#f)) #f))
(define start-time #f) ; in inexact milliseconds; #f means not started (define start-time #f) ; in inexact milliseconds; #f means not started
(define shown-seconds 0) ; used to compute the delay until the next update (define shown-seconds 0) ; used to compute the delay until the next update
(define time-region (make-time-region 0)) ; old region, so we wan remove it (define time-region (make-time-region 0)) ; old region, so we wan remove it
(send t add-region time-region) ; start with the initial region added (send t add-region time-region) ; start with the initial region added
(define (show-time n) (define (show-time n)
;; Compute new time to show: ;; Compute new time to show:
(set! shown-seconds n) (set! shown-seconds n)
;; Update the time by removing the old region and adding a new one: ;; Update the time by removing the old region and adding a new one:
@ -146,31 +138,27 @@
(set! time-region (make-time-region shown-seconds)) (set! time-region (make-time-region shown-seconds))
(send t add-region time-region) (send t add-region time-region)
(send t end-card-sequence)) (send t end-card-sequence))
(define (get-update-delta) (define (get-update-delta)
;; Figure out how many milliseconds to sleep before the next update ;; Figure out how many milliseconds to sleep before the next update
(max 0 (max 0 (inexact->exact (floor (- (+ start-time (* 1000 shown-seconds) 1000)
(inexact->exact
(floor
(- (+ start-time (* 1000 shown-seconds) 1000)
(current-inexact-milliseconds)))))) (current-inexact-milliseconds))))))
(define time-timer (define time-timer
(make-object timer% (lambda () (make-object timer%
(lambda ()
(unless (= matches MAX-MATCHES) (unless (= matches MAX-MATCHES)
(show-time (show-time
(inexact->exact (inexact->exact
(floor (/ (- (current-inexact-milliseconds) (floor (/ (- (current-inexact-milliseconds) start-time) 1000))))
start-time)
1000))))
(send time-timer start (get-update-delta) #t))))) (send time-timer start (get-update-delta) #t)))))
(define (reset-timer) (define (reset-timer)
(send time-timer stop) (send time-timer stop)
(set! start-time #f) (set! start-time #f)
(show-time 0)) (show-time 0))
(define (run-timer) (define (run-timer)
(unless start-time (unless start-time
(set! start-time (current-inexact-milliseconds)) (set! start-time (current-inexact-milliseconds))
(send time-timer start 1000 #t))) (send time-timer start 1000 #t)))
;; Start the game: ;; Start the game:
(send t pause 0.25) (send t pause 0.25)
(setup)))) (setup)))

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

@ -3,88 +3,76 @@
;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;;
(module mines mzscheme #lang mzscheme
(require (lib "etc.ss") ; defines build-vector (require (lib "etc.ss") ; defines build-vector
(lib "class.ss") (lib "class.ss")
(lib "unit.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "include-bitmap.ss" "mrlib")) (lib "include-bitmap.ss" "mrlib"))
(provide game@) (provide game@)
;; Layout constants ;; Layout constants
(define TILE-HW 24) ; height/width of a tile (define TILE-HW 24) ; height/width of a tile
(define B-WIDTH 16) ; number of tiles across (define B-WIDTH 16) ; number of tiles across
(define B-HEIGHT 16) ; number of tiles down (define B-HEIGHT 16) ; number of tiles down
(define THE-BOMB-COUNT 30) ; number of bombs to hide (define THE-BOMB-COUNT 30) ; number of bombs to hide
;; Bitmap constants ;; Bitmap constants
(define tile-bm (include-bitmap "images/tile.png")) (define tile-bm (include-bitmap "images/tile.png"))
(define lclick-bm (include-bitmap "images/lclick-tile.png")) (define lclick-bm (include-bitmap "images/lclick-tile.png"))
(define rclick-bm (include-bitmap "images/rclick-tile.png")) (define rclick-bm (include-bitmap "images/rclick-tile.png"))
(define local-bm (include-bitmap "images/local-tile.png")) (define local-bm (include-bitmap "images/local-tile.png"))
(define near-bm (include-bitmap "images/near-tile.png")) (define near-bm (include-bitmap "images/near-tile.png"))
(define bomb-bm (include-bitmap "images/bomb.png")) (define bomb-bm (include-bitmap "images/bomb.png"))
(define explode-bm (include-bitmap "images/explode.png")) (define explode-bm (include-bitmap "images/explode.png"))
(define flag-bm (include-bitmap "images/flag.png")) (define flag-bm (include-bitmap "images/flag.png"))
(define DIGIT-COLOR-NAMES (define DIGIT-COLOR-NAMES
;; 0th is background; 8th is foreground ;; 0th is background; 8th is foreground
(vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE" (vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE"
"ORANGE" "YELLOW" "BROWN" "BLACK")) "ORANGE" "YELLOW" "BROWN" "BLACK"))
(define DIGIT-COLORS (define DIGIT-COLORS
(build-vector 9 (lambda (i) (build-vector 9 (lambda (i)
(send the-color-database find-color (send the-color-database find-color
(vector-ref DIGIT-COLOR-NAMES i))))) (vector-ref DIGIT-COLOR-NAMES i)))))
(define BG-COLOR (vector-ref DIGIT-COLORS 0)) (define BG-COLOR (vector-ref DIGIT-COLORS 0))
(define FG-COLOR (vector-ref DIGIT-COLORS 8)) (define FG-COLOR (vector-ref DIGIT-COLORS 8))
(define BLACK-COLOR (send the-color-database find-color "BLACK")) (define BLACK-COLOR (send the-color-database find-color "BLACK"))
(define BG-PEN (make-object pen% BG-COLOR 1 'solid)) (define BG-PEN (make-object pen% BG-COLOR 1 'solid))
(define FG-PEN (make-object pen% FG-COLOR 1 'solid)) (define FG-PEN (make-object pen% FG-COLOR 1 'solid))
;; A function for looping over numbers: ;; A function for looping over numbers:
(define (step-while first test until f accum init) (define (step-while first test until f accum init)
(let loop ([n first][a init]) (let loop ([n first][a init])
(if (test n until) (if (test n until)
(loop (add1 n) (accum a (f n))) (loop (add1 n) (accum a (f n)))
a))) a)))
;; The rest of the game is implemented in a unit so it can be started multiple times ;; The rest of the game is implemented in a unit so it can be started
(define game@ ;; multiple times
(unit (define game@ (unit (import) (export)
(import)
(export)
;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;;
;; Class for a tile object ;; Class for a tile object
(define tile:plain% (define tile:plain%
(class object% (class object%
(define state 'covered) ; 'covered, 'flagged, 'semi-flagged, or 'uncovered (define state 'covered) ; 'covered, 'flagged, 'semi-flagged, or 'uncovered
(define neighbor-bomb-count 0) ; 0 to 8 (define neighbor-bomb-count 0) ; 0 to 8
(define area-hilite 'none) ; 'none, 'local, 'near (define area-hilite 'none) ; 'none, 'local, 'near
(public* (public*
[set-state [set-state (lambda (newstate) (set! state newstate))]
(lambda (newstate) [get-state (lambda () state)]
(set! state newstate))] [set-neighbor-bomb-count (lambda (c) (set! neighbor-bomb-count c))]
[get-state [get-neighbor-bomb-count (lambda () neighbor-bomb-count)]
(lambda () [set-area-hilite (lambda (mode) (set! area-hilite mode))]
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 [draw-text-tile
(lambda (dc x y w h hilite border? str color) (lambda (dc x y w h hilite border? str color)
(if border? (if border?
@ -97,12 +85,10 @@
[(local) local-bm] [(local) local-bm]
[else tile-bm])]) [else tile-bm])])
x y) x y)
(begin (begin (send dc set-pen BG-PEN)
(send dc set-pen BG-PEN)
(send dc draw-rectangle x y w h))) (send dc draw-rectangle x y w h)))
(when str (when str
(cond (cond [(string? str)
[(string? str)
(send dc set-text-foreground (or color FG-COLOR)) (send dc set-text-foreground (or color FG-COLOR))
;; Draw text centered in the tile's box: ;; Draw text centered in the tile's box:
(let-values ([(tw th d a) (send dc get-text-extent str)]) (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)] [(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)] [(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)] [(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 dc x y w h #f #f
(if (zero? neighbor-bomb-count) (if (zero? neighbor-bomb-count)
#f #f
@ -127,16 +114,14 @@
(super-instantiate ()))) (super-instantiate ())))
;; Class for a tile with a bomb underneath ;; Class for a tile with a bomb underneath
(define tile:bomb% (define tile:bomb%
(class tile:plain% (class tile:plain%
(inherit get-state draw-text-tile) (inherit get-state draw-text-tile)
(define explode-source? #f) ; draw this bomb as the one that exploded? (define explode-source? #f) ; draw this bomb as the one that exploded?
(public* (public*
[set-explode-source [set-explode-source (lambda (s?) (set! explode-source? s?))])
(lambda (s?)
(set! explode-source? s?))])
(override* (override*
[draw [draw
@ -148,21 +133,21 @@
(super-instantiate ()))) (super-instantiate ())))
(define (is-bomb? x) (define (is-bomb? x)
(is-a? x tile:bomb%)) (is-a? x tile:bomb%))
;; ;;;;;;;;;;;;;;; Board Operations ;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;; Board Operations ;;;;;;;;;;;;;;;;;;
;; A board is a vector of vectors of tiles ;; A board is a vector of vectors of tiles
(define board #f) ; initialized by calling make-board! (define board #f) ; initialized by calling make-board!
(define (get-tile x y) (define (get-tile x y)
(vector-ref (vector-ref board x) y)) (vector-ref (vector-ref board x) y))
(define (set-tile! x y t) (define (set-tile! x y t)
(vector-set! (vector-ref board x) y t)) (vector-set! (vector-ref board x) y t))
(define (do-surrounding x y accum start default f) (define (do-surrounding x y accum start default f)
(step-while -1 <= 1 (step-while -1 <= 1
(lambda (dx) (lambda (dx)
(step-while -1 <= 1 (step-while -1 <= 1
@ -175,31 +160,25 @@
accum start)) accum start))
accum start)) accum start))
(define (count-surrounding-bombs x y) (define (count-surrounding-bombs x y)
(do-surrounding (do-surrounding
x y + 0 0 x y + 0 0
(lambda (dx dy) (lambda (dx dy) (if (is-bomb? (get-tile (+ x dx) (+ y dy))) 1 0))))
(if (is-bomb? (get-tile (+ x dx) (+ y dy)))
1
0))))
(define (for-each-tile f) (define (for-each-tile f)
(step-while 0 < B-WIDTH (step-while 0 < B-WIDTH
(lambda (x) (lambda (x)
(step-while 0 < B-HEIGHT (step-while 0 < B-HEIGHT (lambda (y) (f (get-tile x y) x y))
(lambda (y)
(f (get-tile x y) x y))
void (void))) void (void)))
void (void))) void (void)))
(define (make-board!) (define (make-board!)
;; Create the board ;; Create the board
(set! board (set! board
(build-vector B-WIDTH (build-vector B-WIDTH
(lambda (i) (lambda (i)
(build-vector B-HEIGHT (build-vector B-HEIGHT
(lambda (j) (lambda (j) (make-object tile:plain%))))))
(make-object tile:plain%))))))
;; Randomly insert bombs ;; Randomly insert bombs
(let loop ([n THE-BOMB-COUNT]) (let loop ([n THE-BOMB-COUNT])
(unless (zero? n) (unless (zero? n)
@ -218,10 +197,11 @@
set-neighbor-bomb-count set-neighbor-bomb-count
(count-surrounding-bombs x y))))) (count-surrounding-bombs x y)))))
;; ;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;;
;; Make a frame: ;; Make a frame:
(define frame (instantiate (define frame
(instantiate
(class frame% (class frame%
(augment* (augment*
[on-close ; stop the timer, in case it's running [on-close ; stop the timer, in case it's running
@ -232,27 +212,29 @@
("Minesweeper") ("Minesweeper")
[style '(no-resize-border metal)])) [style '(no-resize-border metal)]))
;; Make the row of controls at the top of the frame: ;; Make the row of controls at the top of the frame:
(define panel (make-object horizontal-panel% frame)) (define panel (make-object horizontal-panel% frame))
(send panel stretchable-height #f) (send panel stretchable-height #f)
(define (make-centering-pane parent) (define (make-centering-pane parent)
(let ([p (make-object vertical-pane% parent)]) (let ([p (make-object vertical-pane% parent)])
(send p set-alignment 'center 'center) (send p set-alignment 'center 'center)
p)) p))
(define time-display (make-object message% "Time: 00000" (make-centering-pane panel))) (define time-display
(make-object button% "Reset" (make-centering-pane panel) (make-object message% "Time: 00000" (make-centering-pane panel)))
(make-object button% "Reset" (make-centering-pane panel)
(lambda (b e) (send board-canvas reset))) (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) (define (set-time t)
(send time-display set-label (string-append "Time: " (number->string t)))) (send time-display set-label (string-append "Time: " (number->string t))))
(define (set-count c) (define (set-count c)
(send count-display set-label (string-append "Bombs: " (number->string c)))) (send count-display set-label (string-append "Bombs: " (number->string c))))
;; Most of the work is in this class, which extends the basic canvas ;; Most of the work is in this class, which extends the basic canvas
;; class for drawing the Minesweeper board and handling clicks. ;; class for drawing the Minesweeper board and handling clicks.
(define board-canvas% (define board-canvas%
(class canvas% (class canvas%
(init frame) (init frame)
(inherit get-dc min-client-width min-client-height (inherit get-dc min-client-width min-client-height
@ -297,15 +279,12 @@
(stop-timer) (stop-timer)
(set! ready? #f) (set! ready? #f)
(set! start-time #f) (set! start-time #f)
(unless win? (unless win? (show-all-bombs))
(show-all-bombs))
(set-count THE-BOMB-COUNT))] (set-count THE-BOMB-COUNT))]
[explode ; stop the game because the player hit a bomb [explode ; stop the game because the player hit a bomb
(lambda () (lambda () (end-of-game #f))]
(end-of-game #f))]
[win ; stop the game because the player won [win ; stop the game because the player won
(lambda () (lambda () (end-of-game #t))]
(end-of-game #t))]
[reset ; quit the current game and reset the board [reset ; quit the current game and reset the board
(lambda () (lambda ()
(stop-timer) (stop-timer)
@ -338,8 +317,7 @@
(unless (eq? state 'uncovered) (unless (eq? state 'uncovered)
(change-state t state 'uncovered #t) (change-state t state 'uncovered #t)
(paint-one t x2 y2) (paint-one t x2 y2)
(when (zero? nc) (when (zero? nc) (autoclick-surrounding x2 y2)))))))]
(autoclick-surrounding x2 y2)))))))]
[change-state ; update counters after a tile changes [change-state ; update counters after a tile changes
(lambda (t old-state new-state update-count?) (lambda (t old-state new-state update-count?)
(send t set-state new-state) (send t set-state new-state)
@ -358,22 +336,17 @@
(lambda (x y flag?) (lambda (x y flag?)
(let* ([t (get-tile x y)] (let* ([t (get-tile x y)]
[state (send t get-state)] [state (send t get-state)]
[new-state [new-state (case state
(case state [(covered) (if flag? 'flagged 'uncovered)]
[(covered) [(flagged) (if flag? 'semi-flagged state)]
(if flag? 'flagged 'uncovered)] [(semi-flagged) (if flag? 'covered 'uncovered)]
[(flagged)
(if flag? 'semi-flagged state)]
[(semi-flagged)
(if flag? 'covered 'uncovered)]
[else state])] [else state])]
[nc (send t get-neighbor-bomb-count)] [nc (send t get-neighbor-bomb-count)]
[new-uncover? (and (eq? new-state 'uncovered) [new-uncover? (and (eq? new-state 'uncovered)
(not (eq? state 'uncovered)))] (not (eq? state 'uncovered)))]
[bomb? (is-bomb? t)]) [bomb? (is-bomb? t)])
(change-state t state new-state #t) (change-state t state new-state #t)
(when (and new-uncover? bomb?) (when (and new-uncover? bomb?) (send t set-explode-source #t))
(send t set-explode-source #t))
(paint-one t x y) (paint-one t x y)
(when new-uncover? (when new-uncover?
(if bomb? (if bomb?
@ -382,20 +355,19 @@
(if (zero? nc) (if (zero? nc)
(autoclick-surrounding x y) (autoclick-surrounding x y)
(set-near-hilite t x y)))) (set-near-hilite t x y))))
(when (and ready? (= cover-count THE-BOMB-COUNT)) (when (and ready? (= cover-count THE-BOMB-COUNT)) (win)))))]
(win)))))]
[paint-one ; draw one tile [paint-one ; draw one tile
(lambda (t x y) (lambda (t x y)
(let ([xloc (* x TILE-HW)] (let ([xloc (* x TILE-HW)]
[yloc (* y TILE-HW)]) [yloc (* y TILE-HW)])
(send t draw dc xloc yloc TILE-HW TILE-HW (send t draw dc xloc yloc TILE-HW TILE-HW
(and (eq? t clicking) (and (eq? t clicking) (if clicking-right? 'right 'left)))))]
(if clicking-right? 'right 'left)))))]
[set-near-hilite [set-near-hilite
(lambda (t x y) (lambda (t x y)
(set! area-hilite t) (set! area-hilite t)
(set! area-hilites (set! area-hilites
(do-surrounding x y append null null (do-surrounding
x y append null null
(lambda (dx dy) (lambda (dx dy)
(let* ([x (+ x dx)] (let* ([x (+ x dx)]
[y (+ y dy)] [y (+ y dy)]
@ -423,12 +395,9 @@
(when (send e button-down?) (when (send e button-down?)
(start-timer))) (start-timer)))
;; Find the time for an (x,y) pixel position in the canvas ;; Find the time for an (x,y) pixel position in the canvas
(let* ([x (quotient (inexact->exact (floor (send e get-x))) (let* ([x (quotient (inexact->exact (floor (send e get-x))) TILE-HW)]
TILE-HW)] [y (quotient (inexact->exact (floor (send e get-y))) TILE-HW)]
[y (quotient (inexact->exact (floor (send e get-y))) [t (if (and (< -1 x B-WIDTH) (< -1 y B-HEIGHT))
TILE-HW)]
[t (if (and (< -1 x B-WIDTH)
(< -1 y B-HEIGHT))
(get-tile x y) (get-tile x y)
#f)]) ; not a tile #f)]) ; not a tile
(cond (cond
@ -453,7 +422,8 @@
(set! clicking-x x) (set! clicking-x x)
(set! clicking-y y) (set! clicking-y y)
(when (send e button-down?) (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-control-down)
(send e get-alt-down) (send e get-alt-down)
(send e get-meta-down)))) (send e get-meta-down))))
@ -482,8 +452,7 @@
(paint-one t x y))] (paint-one t x y))]
[else (clear-area-hilite)]))))] [else (clear-area-hilite)]))))]
[on-paint ; refresh the board [on-paint ; refresh the board
(lambda () (lambda () (for-each-tile (lambda (tile x y) (paint-one tile x y))))])
(for-each-tile (lambda (tile x y) (paint-one tile x y))))])
(super-instantiate (frame)) (super-instantiate (frame))
@ -501,9 +470,8 @@
(send dc set-brush (send the-brush-list find-or-create-brush (send dc set-brush (send the-brush-list find-or-create-brush
BG-COLOR 'solid)))) BG-COLOR 'solid))))
;; Make the board canvas: ;; Make the board canvas:
(define board-canvas (make-object board-canvas% frame)) (define board-canvas (make-object board-canvas% frame))
;; Show the frame (and handle events):
(send frame show #t))))
;; Show the frame (and handle events):
(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 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 colored blue and which should be colored white. Initially, all
grey, indicating that the correct colors are not known. The lists of squares are grey, indicating that the correct colors are not known.
numbers to the left and above the grid are your clues to the correct color The lists of numbers to the left and above the grid are your clues to
of each square. Each list of numbers specifies the pattern of blue squares the correct color of each square. Each list of numbers specifies the
in the row beside it or the column below it. Each number indicates the pattern of blue squares in the row beside it or the column below it.
length of a group of blue squares. For example, if the list of numbers Each number indicates the length of a group of blue squares. For
beside the first row is "2 3" then you know that there is a contiguous example, if the list of numbers beside the first row is "2 3" then you
block of two blue squares followed by a contiguous block of three blue know that there is a contiguous block of two blue squares followed by
squares with at least one white square between them. The label does not a contiguous block of three blue squares with at least one white
tell you where the blue squares are, only their shapes. The trick is to square between them. The label does not tell you where the blue
gather as much information as you can about each row, and then use that squares are, only their shapes. The trick is to gather as much
information to determine more about each column. Eventually you should be information as you can about each row, and then use that information
able to fill in the entire puzzle. 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 Click on a square to toggle it between blue and gray. Hold down a
key (shift, command, meta, or alt depending on the platform) to toggle a modifier key (shift, command, meta, or alt depending on the platform)
square between white and gray. The third button under unix and the right to toggle a square between white and gray. The third button under
button under windows also toggles between white and gray. unix and the right button under windows also toggles between white and
gray.
For some puzzles, hints are available. Choose the Nongram|Show Mistakes For some puzzles, hints are available. Choose the Nongram|Show
menu item to receive the hints. This will turn all incorrectly colored Mistakes menu item to receive the hints. This will turn all
squares red. incorrectly colored squares red.
Thanks to Shoichiro Hattori for his puzzles! Visit him on the web at: 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 Parcheesi is a race game for four players. The goal is for each
each player to move their pieces from the starting position player to move their pieces from the starting position (the circles in
(the circles in the corners) to the home square (in the the corners) to the home square (in the center of the board), passing
center of the board), passing a nearly complete loop around a nearly complete loop around the board in the counter-clockwise
the board in the counter-clockwise direction and then heads direction and then heads up towards the main row. For example, the
up towards the main row. For example, the green player green player enters from the bottom right, travels around the board on
enters from the bottom right, travels around the board on the light blue squares, passing each of the corners, until it reaches
the light blue squares, passing each of the corners, until the middle of the bottom of the board, where it turns off the light
it reaches the middle of the bottom of the board, where it blue squares and heads into the central region.
turns off the light blue squares and heads into the central
region.
On each turn, the player rolls two dice and advances the On each turn, the player rolls two dice and advances the pawn, based
pawn, based on the die rolls. Typically the players may move on the die rolls. Typically the players may move a pawn for each die.
a pawn for each die. The pawn moves by the number of pips The pawn moves by the number of pips showing on the die and all of the
showing on the die and all of the dice must be used to dice must be used to complete a turn.
complete a turn.
There are some exceptions, however: There are some exceptions, however:
- you must roll a 5 (either directly or via summing) to - you must roll a 5 (either directly or via summing) to enter from
enter from the start area to the main ring. the start area to the main ring.
- if two pieces of the same color occupy a square, no - if two pieces of the same color occupy a square, no pieces may
pieces may pass that square. pass that square.
- if an opponent's piece lands on your piece, you piece is - if an opponent's piece lands on your piece, you piece is returned
returned to the starting area and the opponent receives to the starting area and the opponent receives a bonus of 20
a bonus of 20 (which is treated just as if they had (which is treated just as if they had rolled a 20 on the dice).
rolled a 20 on the dice)
- if your piece makes it home (and it must do so by exact - if your piece makes it home (and it must do so by exact count) you
count) you get a bonus of 10, to be used as an get a bonus of 10, to be used as an additional die roll.
additional die roll.
These rules induce a number of unexpected corner cases, but These rules induce a number of unexpected corner cases, but the GUI
the GUI only lets you make legal moves. Watch the space only lets you make legal moves. Watch the space along the bottom of
along the bottom of the board for reasons why a move is the board for reasons why a move is illegal or why you have not used
illegal or why you have not used all of your die rolls. all of your die rolls.
The automated players are: The automated players are:
- Reckless Renee, who she tries to maximize the chances - Reckless Renee, who she tries to maximize the chances that someone
that someone else bops her. else bops her.
- Polite Polly, who tries to minimize the distance her - Polite Polly, who tries to minimize the distance her pawns move
pawns move ("no, after _you_. I insist."), and ("no, after _you_. I insist."), and
- Amazing Grace, who tries to minimize the chance she gets - Amazing Grace, who tries to minimize the chance she gets bopped
bopped while moving as far as possible. 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, 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 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 board (and must be removed from play) if there are no empty squares on
the insertion row or column. the insertion row or column.
A row or a column is a "straight" of a given color, if it contains A row or a column is a "straight" of a given color, if it contains N
N markers of the given color. markers of the given color.
The game ends either when an insertion The game ends either when an insertion
1) repeats a previous configuration of the board; in this case 1) repeats a previous configuration of the board; in this case the
the player who inserted the marker LOSES. player who inserted the marker LOSES.
2) creates a configuration with more straights of one color than 2) creates a configuration with more straights of one color than
straights of the other color; the player whose color is dominant 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 The object of Same is to score points by removing dots from the board.
board. To remove a dot, click on it. As long as there is another dot To remove a dot, click on it. As long as there is another dot of the
of the same color next to the clicked dot, it will disappear along same color next to the clicked dot, it will disappear along with all
with all adjacent dots of the same color. After the dots disappear, adjacent dots of the same color. After the dots disappear, dots in
dots in the rows above the deleted dots will fall into the vacated the rows above the deleted dots will fall into the vacated spaces. If
spaces. If an entire column is wiped out, all of the dots from the an entire column is wiped out, all of the dots from the right will
right will slide left to take up the empty column's space. slide left to take up the empty column's space.
Your score increases for each ball removed from the board. The score Your score increases for each ball removed from the board. The score
for each click is a function of the number of balls that for each click is a function of the number of balls that disappeared.
disappeared. The "This Click" label shows how many points you would The "This Click" label shows how many points you would score for
score for clicking the dots underneath the mouse pointer. The score clicking the dots underneath the mouse pointer. The score varies
varies quadratically with the number of balls, so eliminating many quadratically with the number of balls, so eliminating many balls with
balls with one click is advantageous. one click is advantageous.
Click the New Game button to play again. Click the New Game button to play again.

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

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

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

@ -1,7 +1,6 @@
#lang mzscheme
(module spider mzscheme (require (lib "cards.ss" "games" "cards")
(require (lib "cards.ss" "games" "cards")
(lib "class.ss") (lib "class.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "list.ss") (lib "list.ss")
@ -9,102 +8,97 @@
(lib "unit.ss") (lib "unit.ss")
"../show-help.ss") "../show-help.ss")
(define (list-first-n l n) (define (list-first-n l n)
(if (zero? n) (if (zero? n)
null null
(cons (car l) (list-first-n (cdr l) (sub1 n))))) (cons (car l) (list-first-n (cdr l) (sub1 n)))))
(define (vector-copy v) (define (vector-copy v)
(list->vector (vector->list v))) (list->vector (vector->list v)))
(provide game@) (provide game@)
(define game@ (unit (import) (export)
(define game@ (define t (make-table "Spider" 11 6))
(unit
(import)
(export)
(define t (make-table "Spider" 11 6)) (define num-suits (get-preference 'spider:num-suits (lambda () 2)))
(define num-suits (get-preference 'spider:num-suits (lambda () 2))) (define (make-spider-deck)
(define (make-spider-deck)
(let-values ([(suits copies) (let-values ([(suits copies)
(case num-suits (case num-suits
[(1) (values '(spades) 4)] [(1) (values '(spades) 4)]
[(2) (values '(spades hearts) 2)] [(2) (values '(spades hearts) 2)]
[(4) (values '(spades hearts clubs diamonds) 1)])]) [(4) (values '(spades hearts clubs diamonds) 1)])])
(let ([l (filter (lambda (c) (let ([l (filter (lambda (c) (memq (send c get-suit) suits)) (make-deck))])
(memq (send c get-suit) suits))
(make-deck))])
(let loop ([n (* 2 copies)]) (let loop ([n (* 2 copies)])
(if (zero? n) (if (zero? n)
null null
(append (map (lambda (c) (send c copy)) l) (append (map (lambda (c) (send c copy)) l) (loop (sub1 n))))))))
(loop (sub1 n))))))))
(define deck (make-spider-deck)) (define deck (make-spider-deck))
(define draw-pile deck) (define draw-pile deck)
(define CARD-WIDTH (send (car deck) card-width)) (define CARD-WIDTH (send (car deck) card-width))
(define CARD-HEIGHT (send (car deck) card-height)) (define CARD-HEIGHT (send (car deck) card-height))
(define dx (quotient CARD-WIDTH 11)) (define dx (quotient CARD-WIDTH 11))
(define dy dx) (define dy dx)
(define stacks (make-vector 10 null)) (define stacks (make-vector 10 null))
(define dones (make-vector 8 null)) (define dones (make-vector 8 null))
(define done-count 0) (define done-count 0)
(define old-states null) (define old-states null)
(define-struct state (draw-pile stacks dones done-count face-down?s)) (define-struct state (draw-pile stacks dones done-count face-down?s))
(define mb (make-object menu-bar% t)) (define mb (make-object menu-bar% t))
(define file-menu (make-object menu% "&File" mb)) (define file-menu (make-object menu% "&File" mb))
(new menu-item% (new menu-item%
[label "&Reset Game..."] [label "&Reset Game..."]
[parent file-menu] [parent file-menu]
[callback (lambda (i e) [callback
(lambda (i e)
(when (eq? 'yes (message-box "Reset Game" (when (eq? 'yes (message-box "Reset Game"
"Are you sure you want to reset the game?" "Are you sure you want to reset the game?"
t t
'(yes-no))) '(yes-no)))
(reset-game!)))]) (reset-game!)))])
(new separator-menu-item% [parent file-menu]) (new separator-menu-item% [parent file-menu])
(new menu-item% (new menu-item%
[label "&Close"] [label "&Close"]
[parent file-menu] [parent file-menu]
[shortcut #\W] [shortcut #\W]
[callback (lambda (i e) (send t show #f))]) [callback (lambda (i e) (send t show #f))])
(define edit-menu (make-object menu% "&Edit" mb)) (define edit-menu (make-object menu% "&Edit" mb))
(define undo (define undo
(new menu-item% (new menu-item%
[label "&Undo"] [label "&Undo"]
[parent edit-menu] [parent edit-menu]
[shortcut #\Z] [shortcut #\Z]
[callback (lambda (i e) [callback (lambda (i e) (pop-state!))]))
(pop-state!))]))
(new separator-menu-item% [parent edit-menu]) (new separator-menu-item% [parent edit-menu])
(new menu-item% (new menu-item%
[label "&Options..."] [label "&Options..."]
[parent edit-menu] [parent edit-menu]
[callback (lambda (i e) [callback (lambda (i e)
(define d (new dialog% (define d
(new dialog%
[label "Spider Options"] [label "Spider Options"]
[parent t] [parent t]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])) [stretchable-height #f]))
(define suits (new radio-box% (define suits
(new radio-box%
[label #f] [label #f]
[parent (new group-box-panel% [parent (new group-box-panel%
[parent d] [parent d]
@ -112,7 +106,8 @@
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])] [stretchable-height #f])]
[choices '("1 (easiest)" "2" "4 (hardest)")])) [choices '("1 (easiest)" "2" "4 (hardest)")]))
(define bottom-panel (new horizontal-panel% (define bottom-panel
(new horizontal-panel%
[parent d] [parent d]
[alignment '(right center)] [alignment '(right center)]
[stretchable-height #f])) [stretchable-height #f]))
@ -145,21 +140,20 @@
(new menu-item% (new menu-item%
[label "&Rules"] [label "&Rules"]
[parent (make-object menu% "&Help" mb)] [parent (make-object menu% "&Help" mb)]
[callback (lambda (i e) [callback (lambda (i e) (help))])
(help))])
(define (push-state!) (define (push-state!)
(when (null? old-states) (when (null? old-states)
(send undo enable #t)) (send undo enable #t))
(set! old-states (cons (make-state (set! old-states
draw-pile (cons (make-state draw-pile
(vector-copy stacks) (vector-copy stacks)
(vector-copy dones) (vector-copy dones)
done-count done-count
(map (lambda (c) (send c face-down?)) deck)) (map (lambda (c) (send c face-down?)) deck))
old-states))) old-states)))
(define (pop-state!) (define (pop-state!)
(let ([state (car old-states)]) (let ([state (car old-states)])
(send t begin-card-sequence) (send t begin-card-sequence)
(set! old-states (cdr old-states)) (set! old-states (cdr old-states))
@ -169,8 +163,7 @@
(set! done-count (state-done-count state)) (set! done-count (state-done-count state))
(for-each (lambda (c fd?) (for-each (lambda (c fd?)
(send c user-can-move #f) (send c user-can-move #f)
(unless (eq? (send c face-down?) fd?) (unless (eq? (send c face-down?) fd?) (send c flip)))
(send c flip)))
deck (state-face-down?s state)) deck (state-face-down?s state))
(send t move-cards draw-pile dx dy) (send t move-cards draw-pile dx dy)
(send t stack-cards draw-pile) (send t stack-cards draw-pile)
@ -179,41 +172,35 @@
(send t stack-cards (vector-ref stacks i)) (send t stack-cards (vector-ref stacks i))
(loop (add1 i)))) (loop (add1 i))))
(let loop ([i 0]) (let loop ([i 0])
(unless (= i (vector-length dones)) (unless (= i (vector-length dones)) (move-dones i) (loop (add1 i))))
(move-dones i)
(loop (add1 i))))
(shift-stacks) (shift-stacks)
(when (null? old-states) (when (null? old-states) (send undo enable #f))
(send undo enable #f))
(send t end-card-sequence))) (send t end-card-sequence)))
(define (find-stack find) (define (find-stack find)
(let loop ([i 0]) (let loop ([i 0])
(if (= i (vector-length stacks)) (if (= i (vector-length stacks))
#f #f
(let ([l (vector-ref stacks i)]) (let ([l (vector-ref stacks i)])
(if (and (pair? l) (if (and (pair? l) (memq find l))
(memq find l))
i i
(loop (add1 i))))))) (loop (add1 i)))))))
(define (remove-from-stack! cards) (define (remove-from-stack! cards)
(let* ([i (find-stack (car cards))] (let* ([i (find-stack (car cards))]
[l (vector-ref stacks i)]) [l (vector-ref stacks i)])
(vector-set! stacks i (list-tail l (length cards))))) (vector-set! stacks i (list-tail l (length cards)))))
(define (stacked-cards card) (define (stacked-cards card)
(let ([i (find-stack card)]) (let ([i (find-stack card)])
(if i (if i
(reverse (reverse (let loop ([l (vector-ref stacks i)])
(let loop ([l (vector-ref stacks i)]) (cond [(not (send (car l) user-can-move)) null]
(cond
[(not (send (car l) user-can-move)) null]
[(eq? (car l) card) (list card)] [(eq? (car l) card) (list card)]
[else (cons (car l) (loop (cdr l)))]))) [else (cons (car l) (loop (cdr l)))])))
#f))) #f)))
(define (drag-ok? cards i) (define (drag-ok? cards i)
(let ([c (car cards)] (let ([c (car cards)]
[l (vector-ref stacks i)]) [l (vector-ref stacks i)])
(and l (and l
@ -221,7 +208,7 @@
(= (send (car l) get-value) (= (send (car l) get-value)
(add1 (send c get-value))))))) (add1 (send c get-value)))))))
(let loop ([i 0]) (let loop ([i 0])
(unless (= i (vector-length stacks)) (unless (= i (vector-length stacks))
null null
(let ([r (make-region (+ dx (* i (+ CARD-WIDTH dx))) (let ([r (make-region (+ dx (* i (+ CARD-WIDTH dx)))
@ -236,61 +223,49 @@
r r
(lambda (on? cards) (lambda (on? cards)
(let ([ok? (and on? (drag-ok? cards i))]) (let ([ok? (and on? (drag-ok? cards i))])
(for-each (lambda (c) (for-each (lambda (c) (send c snap-back-after-move (not ok?)))
(send c snap-back-after-move (not ok?)))
cards) cards)
(let ([l (vector-ref stacks i)]) (let ([l (vector-ref stacks i)])
(unless (null? l) (unless (null? l) (send (car l) dim ok?))))))
(send (car l) dim ok?))))))
(send t add-region r) (send t add-region r)
(loop (add1 i))))) (loop (add1 i)))))
(define (move-to-stack cards i) (define (move-to-stack cards i)
(unselect) (unselect)
(let ([l (vector-ref stacks i)]) (let ([l (vector-ref stacks i)])
(unless (null? l) (unless (null? l) (send (car l) dim #f)))
(send (car l) dim #f)))
(push-state!) (push-state!)
(remove-from-stack! cards) (remove-from-stack! cards)
(vector-set! stacks i (vector-set! stacks i (append (reverse cards) (vector-ref stacks i)))
(append (reverse cards) (for-each (lambda (c) (send c snap-back-after-move #t)) cards)
(vector-ref stacks i)))
(for-each (lambda (c)
(send c snap-back-after-move #t))
cards)
(shift-stacks)) (shift-stacks))
(define selected null) (define selected null)
(define (select cards) (define (select cards)
(unselect) (unselect)
(set! selected cards) (set! selected cards)
(for-each (lambda (c) (send c dim #t)) (for-each (lambda (c) (send c dim #t)) selected))
selected))
(define (unselect) (define (unselect)
(for-each (lambda (c) (send c dim #f)) (for-each (lambda (c) (send c dim #f)) selected)
selected)
(set! selected null)) (set! selected null))
(define (move-dones i) (define (move-dones i)
(send t move-cards (vector-ref dones i) (send t move-cards (vector-ref dones i)
(- (* 10 CARD-WIDTH) dx (* i (+ CARD-WIDTH dx))) (- (* 10 CARD-WIDTH) dx (* i (+ CARD-WIDTH dx)))
dy)) dy))
(define (draw push?) (define (draw push?)
(when push? (when push? (push-state!))
(push-state!))
(let ([drawn-cards (let ([drawn-cards
(let loop ([i 0]) (let loop ([i 0])
(if (or (= i (vector-length stacks)) (if (or (= i (vector-length stacks)) (null? draw-pile))
(null? draw-pile))
null null
(if (vector-ref stacks i) (if (vector-ref stacks i)
(let ([a (car draw-pile)]) (let ([a (car draw-pile)])
(vector-set! stacks i (cons a (vector-set! stacks i (cons a (vector-ref stacks i)))
(vector-ref stacks i)))
(send a flip) (send a flip)
(set! draw-pile (cdr draw-pile)) (set! draw-pile (cdr draw-pile))
(cons a (loop (add1 i)))) (cons a (loop (add1 i))))
@ -299,12 +274,11 @@
(send t stack-cards drawn-cards)) (send t stack-cards drawn-cards))
(shift-stacks)) (shift-stacks))
(define (check-complete) (define (check-complete)
(let loop ([i 0]) (let loop ([i 0])
(unless (= i (vector-length stacks)) (unless (= i (vector-length stacks))
(let ([l (vector-ref stacks i)]) (let ([l (vector-ref stacks i)])
(when (and (pair? l) (when (and (pair? l) (= 1 (send (car l) get-value)))
(= 1 (send (car l) get-value)))
(let ([suit (send (car l) get-suit)]) (let ([suit (send (car l) get-suit)])
(let loop ([j 2][a (list (car l))][l (cdr l)]) (let loop ([j 2][a (list (car l))][l (cdr l)])
(cond (cond
@ -313,9 +287,7 @@
(vector-set! dones done-count a) (vector-set! dones done-count a)
(move-dones done-count) (move-dones done-count)
(set! done-count (add1 done-count)) (set! done-count (add1 done-count))
(for-each (lambda (c) (for-each (lambda (c) (send c user-can-move #f)) a)
(send c user-can-move #f))
a)
(vector-set! stacks i l)] (vector-set! stacks i l)]
[(and (pair? l) [(and (pair? l)
(= j (send (car l) get-value)) (= j (send (car l) get-value))
@ -324,7 +296,7 @@
[else (void)]))))) [else (void)])))))
(loop (add1 i))))) (loop (add1 i)))))
(define (shift-stacks) (define (shift-stacks)
(unselect) (unselect)
(check-complete) (check-complete)
(let ([cards (apply append (map reverse (vector->list stacks)))] (let ([cards (apply append (map reverse (vector->list stacks)))]
@ -351,8 +323,7 @@
(unless (= i (vector-length stacks)) (unless (= i (vector-length stacks))
(let ([l (vector-ref stacks i)]) (let ([l (vector-ref stacks i)])
(when (pair? l) (when (pair? l)
(when (send (car l) face-down?) (when (send (car l) face-down?) (send t flip-card (car l)))
(send t flip-card (car l)))
(send (car l) user-can-move #t) (send (car l) user-can-move #t)
(let loop ([l (cdr l)][prev (car l)]) (let loop ([l (cdr l)][prev (car l)])
(unless (null? l) (unless (null? l)
@ -361,24 +332,20 @@
(send (car l) get-suit)) (send (car l) get-suit))
(= (add1 (send prev get-value)) (= (add1 (send prev get-value))
(send (car l) get-value))) (send (car l) get-value)))
(begin (begin (send (car l) user-can-move #t)
(send (car l) user-can-move #t)
(loop (cdr l) (car l))) (loop (cdr l) (car l)))
(for-each (lambda (c) (for-each (lambda (c) (send c user-can-move #f))
(send c user-can-move #f))
l)))))) l))))))
(loop (add1 i)))))) (loop (add1 i))))))
(send t set-double-click-action void) (send t set-double-click-action void)
(send t set-single-click-action (send t set-single-click-action
(lambda (c) (lambda (c)
(cond (cond
[(and (pair? draw-pile) [(and (pair? draw-pile)
(eq? c (car draw-pile))) (eq? c (car draw-pile)))
(if (ormap null? (vector->list stacks)) (if (ormap null? (vector->list stacks)) (bell) (draw #t))]
(bell)
(draw #t))]
[(and (pair? selected) (eq? c (car selected))) [(and (pair? selected) (eq? c (car selected)))
(unselect)] (unselect)]
[(and (pair? selected) [(and (pair? selected)
@ -391,12 +358,11 @@
(send t card-to-front (car (last-pair selected))) (send t card-to-front (car (last-pair selected)))
(send t stack-cards (reverse selected)) (send t stack-cards (reverse selected))
(move-to-stack selected i))] (move-to-stack selected i))]
[(stacked-cards c) [(stacked-cards c) => (lambda (cards) (select cards))])))
=> (lambda (cards) (select cards))])))
;; Add a region for each stack to receive clicks when ;; Add a region for each stack to receive clicks when
;; the stack is empty: ;; the stack is empty:
(let loop ([i 0]) (let loop ([i 0])
(unless (= i (vector-length stacks)) (unless (= i (vector-length stacks))
(send t add-region (make-button-region (send t add-region (make-button-region
(+ dx (* i (+ CARD-WIDTH dx))) (+ dx (* i (+ CARD-WIDTH dx)))
@ -409,11 +375,11 @@
(move-to-stack selected i))))) (move-to-stack selected i)))))
(loop (add1 i)))) (loop (add1 i))))
(send t set-button-action 'left 'drag-raise/above) (send t set-button-action 'left 'drag-raise/above)
(send t set-button-action 'middle 'drag-raise/above) (send t set-button-action 'middle 'drag-raise/above)
(send t set-button-action 'right 'drag-raise/above) (send t set-button-action 'right 'drag-raise/above)
(define (reset-game!) (define (reset-game!)
(send t remove-cards deck) (send t remove-cards deck)
(set! deck (make-spider-deck)) (set! deck (make-spider-deck))
(send t add-cards deck dx dy) (send t add-cards deck dx dy)
@ -422,8 +388,7 @@
(send undo enable #f) (send undo enable #f)
(set! draw-pile (shuffle-list deck 7)) (set! draw-pile (shuffle-list deck 7))
(for-each (lambda (c) (for-each (lambda (c)
(unless (send c face-down?) (unless (send c face-down?) (send c flip))
(send c flip))
(send c user-can-flip #f) (send c user-can-flip #f)
(send c user-can-move #f) (send c user-can-move #f)
(send c snap-back-after-move #t)) (send c snap-back-after-move #t))
@ -441,5 +406,7 @@
(loop (add1 i)))) (loop (add1 i))))
(draw #f) (draw #f)
(send t end-card-sequence)) (send t end-card-sequence))
(reset-game!) (reset-game!)
(send t show #t)))) (send t show #t)
))