diff --git a/collects/games/aces/aces.scm b/collects/games/aces/aces.scm index c7ce210b11..a509c16a56 100644 --- a/collects/games/aces/aces.scm +++ b/collects/games/aces/aces.scm @@ -5,367 +5,329 @@ possible to remap single click (instead of double click)? |# -(module aces mzscheme - - (require (lib "cards.ss" "games" "cards") - (lib "class.ss") - (lib "unit.ss") - (lib "mred.ss" "mred") - (lib "list.ss") - (lib "string-constant.ss" "string-constants") - "../show-help.ss") - - (provide game@) - - (define game@ - (unit - (import) - (export) - - (define table (make-table "Aces" 6 5)) +#lang mzscheme - (make-object button% (string-constant help-menu-label) table - (let ([show-help (show-help (list "games" "aces") "Aces Help")]) - (lambda x - (show-help)))) - - (define draw-pile null) - - (define card-height (send (car (make-deck)) card-height)) - (define card-width (send (car (make-deck)) card-width)) - (define region-height (send table table-height)) +(require (lib "cards.ss" "games" "cards") + (lib "class.ss") + (lib "mred.ss" "mred") + (lib "list.ss") + (lib "unit.ss") + (lib "string-constant.ss" "string-constants") + "../show-help.ss") - ;; space between cards in the 4 stacks - (define card-space 30) - - (define-struct stack (x y cards)) - - (define (get-x-offset n) - (let* ([table-width (send table table-width)] - [stack-spacing 7] - [num-stacks 5] - [all-stacks-width - (+ (* num-stacks card-width) - (* (- num-stacks 1) stack-spacing))]) - (+ (- (/ table-width 2) (/ all-stacks-width 2)) - (* n (+ card-width stack-spacing))))) - - (define draw-pile-region - (make-button-region - (get-x-offset 0) - 0 - card-width - region-height ; card-height - #f - #f)) - - (define stacks - (list - (make-stack - (get-x-offset 1) - 0 - null) - (make-stack - (get-x-offset 2) - 0 - null) - (make-stack - (get-x-offset 3) - 0 - null) - (make-stack - (get-x-offset 4) - 0 - null))) +(provide game@) +(define game@ (unit (import) (export) - ;; type state = (make-state (listof cards) (listof[4] (listof cards))) - (define-struct state (draw-pile stacks)) +(define table (make-table "Aces" 6 5)) - ;; extract-current-state : -> state - (define (extract-current-state) - (make-state - (copy-list draw-pile) - (map (lambda (x) (copy-list (stack-cards x))) stacks))) - - (define (copy-list l) (map (lambda (x) x) l)) - - ;; install-state : -> void - (define (install-state state) - (send table begin-card-sequence) +(make-object button% (string-constant help-menu-label) table + (let ([show-help (show-help (list "games" "aces") "Aces Help")]) + (lambda x (show-help)))) - ;; erase all old snips - (send table remove-cards draw-pile) - (for-each (lambda (stack) - (send table remove-cards (stack-cards stack))) - stacks) - - ;; restore old state - (set! draw-pile (state-draw-pile state)) - (for-each (lambda (stack cards) (set-stack-cards! stack cards)) - stacks - (state-stacks state)) - - ;; restore GUI - (for-each (lambda (draw-pile-card) - (send table add-card draw-pile-card 0 0)) - draw-pile) - (send table move-cards-to-region draw-pile draw-pile-region) - (for-each (lambda (draw-pile-card) - (send table card-face-down draw-pile-card) - (send table card-to-front draw-pile-card)) - (reverse draw-pile)) - - (for-each - (lambda (stack) - (let ([num-cards (length (stack-cards stack))]) - (send table add-cards (stack-cards stack) 0 0) - (send table move-cards (stack-cards stack) - (stack-x stack) - (stack-y stack) - (lambda (i) - (values 0 - (* (- num-cards i 1) card-space))))) - (send table cards-face-up (stack-cards stack))) - stacks) - (send table end-card-sequence)) +(define draw-pile null) - ;; undo-stack : (listof state) - (define undo-stack null) +(define card-height (send (car (make-deck)) card-height)) +(define card-width (send (car (make-deck)) card-width)) +(define region-height (send table table-height)) - ;; redo-stack : (listof state) - (define redo-stack null) - - ;; save-undo : -> void - ;; saves the current state in the undo stack - (define (save-undo) - (set! undo-stack (cons (extract-current-state) undo-stack)) - (set! redo-stack null)) +;; space between cards in the 4 stacks +(define card-space 30) - ;; do-undo : -> void - ;; pre: (not (null? undo-stack)) - (define (do-undo) - (let ([to-install (car undo-stack)]) - (set! redo-stack (cons (extract-current-state) redo-stack)) - (set! undo-stack (cdr undo-stack)) - (install-state to-install))) - - ;; do-redo : -> void - ;; pre: (not (null? redo-stack)) - (define (do-redo) - (let ([to-install (car redo-stack)]) - (set! undo-stack (cons (extract-current-state) undo-stack)) - (set! redo-stack (cdr redo-stack)) - (install-state to-install))) - - (define (position-cards stack) - (let ([m (length (stack-cards stack))]) - (lambda (i) - (values 0 - (if (= m 0) - 0 - (* (- m i 1) card-space)))))) - - (define (reset-game) - (send table remove-cards draw-pile) - (for-each - (lambda (stack) (send table remove-cards (stack-cards stack))) - stacks) - - (set! undo-stack null) - (set! redo-stack null) - - (let* ([deck (shuffle-list (make-deck) 7)] - [set-stack - (lambda (which) - (set-stack-cards! (which stacks) (list (which deck))))]) - (for-each (lambda (card) - (send card user-can-move #f) - (send card user-can-flip #f)) - deck) - (set! draw-pile (cddddr deck)) - (set-stack car) - (set-stack cadr) - (set-stack caddr) - (set-stack cadddr)) - - (for-each - (lambda (stack) - (send table add-cards - (stack-cards stack) - (stack-x stack) - (stack-y stack) - (position-cards stack)) - (for-each - (lambda (card) (send card flip)) - (stack-cards stack))) - stacks) - - (send table add-cards-to-region draw-pile draw-pile-region)) - - (define (move-from-deck) - (save-undo) - (unless (null? draw-pile) - (let ([move-one - (lambda (select) - (let ([stack (select stacks)] - [card (select draw-pile)]) - (set-stack-cards! stack - (cons card (stack-cards stack))) - (send table card-to-front card) - (send table flip-card card)))]) - - (send table begin-card-sequence) - (move-one car) - (move-one cadr) - (move-one caddr) - (move-one cadddr) - (send table end-card-sequence) +(define-struct stack (x y cards)) - (let ([cards-to-move (list (car draw-pile) - (cadr draw-pile) - (caddr draw-pile) - (cadddr draw-pile))]) - (send table move-cards cards-to-move - 0 0 - (lambda (i) - (let ([stack (list-ref stacks i)]) - (let-values ([(dx dy) ((position-cards stack) 0)]) - (values (+ dx (stack-x stack)) - (+ dy (stack-y stack)))))))) - - (set! draw-pile (cddddr draw-pile)) - - (send table move-cards-to-region draw-pile draw-pile-region)))) - - (define (move-to-empty-spot card stack) - (save-undo) - (send table move-cards - (list card) - (stack-x stack) - (stack-y stack) - (position-cards stack)) - (remove-card-from-stacks card) - (set-stack-cards! - stack - (cons card (stack-cards stack)))) - - (define (remove-card card) - (save-undo) - (send table remove-card card) - (remove-card-from-stacks card)) - - (define (remove-card-from-stacks card) - (let ([old-cards (map stack-cards stacks)]) - (for-each - (lambda (stack) - (set-stack-cards! stack (remq card (stack-cards stack)))) - stacks) - (for-each (lambda (stack old-cards) - (unless (equal? (stack-cards stack) old-cards) - (send table move-cards - (stack-cards stack) - (stack-x stack) - (stack-y stack) - (position-cards stack)))) - stacks - old-cards))) - - (send table set-single-click-action - (lambda (card) - (cond - [(send card face-down?) (move-from-deck)] - [else - (let ([bottom-four - (let loop ([l stacks]) - (cond - [(null? l) null] - [else (let ([stack (car l)]) - (if (null? (stack-cards stack)) - (loop (cdr l)) - (cons (car (stack-cards stack)) - (loop (cdr l)))))]))]) - (when (memq card bottom-four) - (cond - [(ormap (lambda (bottom-card) - (and (eq? (send card get-suit) - (send bottom-card get-suit)) - (or - (and (not (= 1 (send card get-value))) - (= 1 (send bottom-card get-value))) - (and (not (= 1 (send card get-value))) - (< (send card get-value) - (send bottom-card get-value)))))) - bottom-four) - (remove-card card)] - [else (let loop ([stacks stacks]) - (cond - [(null? stacks) (void)] - [else (let ([stack (car stacks)]) - (if (null? (stack-cards stack)) - (move-to-empty-spot card stack) - (loop (cdr stacks))))]))])))]) +(define (get-x-offset n) + (let* ([table-width (send table table-width)] + [stack-spacing 7] + [num-stacks 5] + [all-stacks-width (+ (* num-stacks card-width) + (* (- num-stacks 1) stack-spacing))]) + (+ (- (/ table-width 2) (/ all-stacks-width 2)) + (* n (+ card-width stack-spacing))))) + +(define draw-pile-region + (make-button-region + (get-x-offset 0) + 0 + card-width + region-height ; card-height + #f + #f)) + +(define stacks + (list (make-stack (get-x-offset 1) 0 null) + (make-stack (get-x-offset 2) 0 null) + (make-stack (get-x-offset 3) 0 null) + (make-stack (get-x-offset 4) 0 null))) + +;; type state = (make-state (listof cards) (listof[4] (listof cards))) +(define-struct state (draw-pile stacks)) + +;; extract-current-state : -> state +(define (extract-current-state) + (make-state (copy-list draw-pile) + (map (lambda (x) (copy-list (stack-cards x))) stacks))) + +(define (copy-list l) (map (lambda (x) x) l)) + +;; install-state : -> void +(define (install-state state) + (send table begin-card-sequence) + + ;; erase all old snips + (send table remove-cards draw-pile) + (for-each (lambda (stack) + (send table remove-cards (stack-cards stack))) + stacks) + + ;; restore old state + (set! draw-pile (state-draw-pile state)) + (for-each (lambda (stack cards) (set-stack-cards! stack cards)) + stacks + (state-stacks state)) + + ;; restore GUI + (for-each (lambda (draw-pile-card) + (send table add-card draw-pile-card 0 0)) + draw-pile) + (send table move-cards-to-region draw-pile draw-pile-region) + (for-each (lambda (draw-pile-card) + (send table card-face-down draw-pile-card) + (send table card-to-front draw-pile-card)) + (reverse draw-pile)) + + (for-each (lambda (stack) + (let ([num-cards (length (stack-cards stack))]) + (send table add-cards (stack-cards stack) 0 0) + (send table move-cards (stack-cards stack) + (stack-x stack) + (stack-y stack) + (lambda (i) + (values 0 (* (- num-cards i 1) card-space))))) + (send table cards-face-up (stack-cards stack))) + stacks) + (send table end-card-sequence)) + +;; undo-stack : (listof state) +(define undo-stack null) + +;; redo-stack : (listof state) +(define redo-stack null) + +;; save-undo : -> void +;; saves the current state in the undo stack +(define (save-undo) + (set! undo-stack (cons (extract-current-state) undo-stack)) + (set! redo-stack null)) + +;; do-undo : -> void +;; pre: (not (null? undo-stack)) +(define (do-undo) + (let ([to-install (car undo-stack)]) + (set! redo-stack (cons (extract-current-state) redo-stack)) + (set! undo-stack (cdr undo-stack)) + (install-state to-install))) + +;; do-redo : -> void +;; pre: (not (null? redo-stack)) +(define (do-redo) + (let ([to-install (car redo-stack)]) + (set! undo-stack (cons (extract-current-state) undo-stack)) + (set! redo-stack (cdr redo-stack)) + (install-state to-install))) + +(define (position-cards stack) + (let ([m (length (stack-cards stack))]) + (lambda (i) + (values 0 (if (= m 0) 0 (* (- m i 1) card-space)))))) + +(define (reset-game) + (send table remove-cards draw-pile) + (for-each (lambda (stack) (send table remove-cards (stack-cards stack))) + stacks) + + (set! undo-stack null) + (set! redo-stack null) + + (let* ([deck (shuffle-list (make-deck) 7)] + [set-stack + (lambda (which) + (set-stack-cards! (which stacks) (list (which deck))))]) + (for-each (lambda (card) + (send card user-can-move #f) + (send card user-can-flip #f)) + deck) + (set! draw-pile (cddddr deck)) + (set-stack car) + (set-stack cadr) + (set-stack caddr) + (set-stack cadddr)) + + (for-each (lambda (stack) + (send table add-cards + (stack-cards stack) + (stack-x stack) + (stack-y stack) + (position-cards stack)) + (for-each (lambda (card) (send card flip)) + (stack-cards stack))) + stacks) + + (send table add-cards-to-region draw-pile draw-pile-region)) + +(define (move-from-deck) + (save-undo) + (unless (null? draw-pile) + (let ([move-one + (lambda (select) + (let ([stack (select stacks)] + [card (select draw-pile)]) + (set-stack-cards! stack (cons card (stack-cards stack))) + (send table card-to-front card) + (send table flip-card card)))]) + + (send table begin-card-sequence) + (move-one car) + (move-one cadr) + (move-one caddr) + (move-one cadddr) + (send table end-card-sequence) + + (let ([cards-to-move (list (car draw-pile) + (cadr draw-pile) + (caddr draw-pile) + (cadddr draw-pile))]) + (send table move-cards cards-to-move + 0 0 + (lambda (i) + (let ([stack (list-ref stacks i)]) + (let-values ([(dx dy) ((position-cards stack) 0)]) + (values (+ dx (stack-x stack)) + (+ dy (stack-y stack)))))))) + + (set! draw-pile (cddddr draw-pile)) + + (send table move-cards-to-region draw-pile draw-pile-region)))) + +(define (move-to-empty-spot card stack) + (save-undo) + (send table move-cards + (list card) + (stack-x stack) + (stack-y stack) + (position-cards stack)) + (remove-card-from-stacks card) + (set-stack-cards! stack (cons card (stack-cards stack)))) + +(define (remove-card card) + (save-undo) + (send table remove-card card) + (remove-card-from-stacks card)) + +(define (remove-card-from-stacks card) + (let ([old-cards (map stack-cards stacks)]) + (for-each (lambda (stack) + (set-stack-cards! stack (remq card (stack-cards stack)))) + stacks) + (for-each (lambda (stack old-cards) + (unless (equal? (stack-cards stack) old-cards) + (send table move-cards + (stack-cards stack) + (stack-x stack) + (stack-y stack) + (position-cards stack)))) + stacks + old-cards))) + +(send table set-single-click-action + (lambda (card) + (if (send card face-down?) + (move-from-deck) + (let ([bottom-four + (let loop ([l stacks]) + (if (null? l) + null + (let ([stack (car l)]) + (if (null? (stack-cards stack)) + (loop (cdr l)) + (cons (car (stack-cards stack)) (loop (cdr l)))))))]) + (when (memq card bottom-four) + (if (ormap (lambda (bottom-card) + (and (eq? (send card get-suit) + (send bottom-card get-suit)) + (or (and (not (= 1 (send card get-value))) + (= 1 (send bottom-card get-value))) + (and (not (= 1 (send card get-value))) + (< (send card get-value) + (send bottom-card get-value)))))) + bottom-four) + (remove-card card) + (let loop ([stacks stacks]) + (if (null? stacks) + (void) + (let ([stack (car stacks)]) + (if (null? (stack-cards stack)) + (move-to-empty-spot card stack) + (loop (cdr stacks)))))))))) (check-game-over))) - - (define (game-over?) - (and (null? draw-pile) - (let ([suits/false - (map (lambda (x) - (let ([stack-cards (stack-cards x)]) - (if (null? stack-cards) - #f - (send (car stack-cards) get-suit)))) - stacks)]) - - (if (member #f suits/false) - #f - (and (memq 'clubs suits/false) - (memq 'diamonds suits/false) - (memq 'hearts suits/false) - (memq 'spades suits/false)))))) - - (define (won?) - (and (game-over?) - (andmap (lambda (x) - (let ([cards (stack-cards x)]) - (and (not (null? cards)) - (null? (cdr cards)) - (= 1 (send (car cards) get-value))))) - stacks))) - - (define (check-game-over) - (when (game-over?) - (case (message-box "Aces" - (if (won?) - "Congratulations! You win! Play again?" - "Game Over. Play again?") - table - '(yes-no)) - [(yes) (reset-game)] - [(no) (send table show #f)]))) - (send table add-region draw-pile-region) - (reset-game) - - (define mb (or (send table get-menu-bar) - (make-object menu-bar% table))) - (define edit-menu (instantiate menu% () - (parent mb) - (label (string-constant edit-menu)))) - (instantiate menu-item% () - (label (string-constant undo-menu-item)) - (parent edit-menu) - (callback (lambda (x y) (do-undo))) - (shortcut #\z) - (demand-callback - (lambda (item) - (send item enable (not (null? undo-stack)))))) - (instantiate menu-item% () - (label (string-constant redo-menu-item)) - (parent edit-menu) - (callback (lambda (x y) (do-redo))) - (shortcut #\y) - (demand-callback - (lambda (item) - (send item enable (not (null? redo-stack)))))) - - (send table show #t)))) +(define (game-over?) + (and (null? draw-pile) + (let ([suits/false + (map (lambda (x) + (let ([stack-cards (stack-cards x)]) + (if (null? stack-cards) + #f + (send (car stack-cards) get-suit)))) + stacks)]) + + (if (member #f suits/false) + #f + (and (memq 'clubs suits/false) + (memq 'diamonds suits/false) + (memq 'hearts suits/false) + (memq 'spades suits/false)))))) + +(define (won?) + (and (game-over?) + (andmap (lambda (x) + (let ([cards (stack-cards x)]) + (and (not (null? cards)) + (null? (cdr cards)) + (= 1 (send (car cards) get-value))))) + stacks))) + +(define (check-game-over) + (when (game-over?) + (case (message-box "Aces" + (if (won?) + "Congratulations! You win! Play again?" + "Game Over. Play again?") + table + '(yes-no)) + [(yes) (reset-game)] + [(no) (send table show #f)]))) + +(send table add-region draw-pile-region) +(reset-game) + +(define mb (or (send table get-menu-bar) + (make-object menu-bar% table))) +(define edit-menu (new menu% [parent mb] [label (string-constant edit-menu)])) +(new menu-item% + [label (string-constant undo-menu-item)] + [parent edit-menu] + [callback (lambda (x y) (do-undo))] + [shortcut #\z] + [demand-callback + (lambda (item) (send item enable (not (null? undo-stack))))]) +(new menu-item% + [label (string-constant redo-menu-item)] + [parent edit-menu] + [callback (lambda (x y) (do-redo))] + [shortcut #\y] + [demand-callback + (lambda (item) (send item enable (not (null? redo-stack))))]) + +(send table show #t) + +)) diff --git a/collects/games/aces/doc.txt b/collects/games/aces/doc.txt index fc85d495ad..3e9246f8fc 100644 --- a/collects/games/aces/doc.txt +++ b/collects/games/aces/doc.txt @@ -1,17 +1,17 @@ -** To play _Aces_, run the "Games" application. ** +** To play Aces, run the "PLT Games" application. -Aces is a solitaire card game. The object is to remove all of the cards -from the board, except the four Aces. +Aces is a solitaire card game. The object is to remove all of the +cards from the board, except the four Aces. -Remove a card by clicking it. You may remove a card when two -conditions are true. First, it must be at the bottom of one of the -four stacks of cards. Second, either the ace of the same suit, or a +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 +four stacks of cards. Second, either the ace of the same suit, or a higher card of the same suit must also be at the bottom of one of the four stacks of cards. -You may also move any card from the bottom of one of the stacks to an -empty stack by clicking it. If there are still cards in the deck on the -right, you may click the deck to deal four new cards, one onto the +You may also move any card from the bottom of one of the stacks to an +empty stack by clicking it. If there are still cards in the deck on +the right, you may click the deck to deal four new cards, one onto the bottom of each stack. Good Luck! diff --git a/collects/games/blackjack/blackjack.ss b/collects/games/blackjack/blackjack.ss index 88d0de4d1c..cabe36bf59 100644 --- a/collects/games/blackjack/blackjack.ss +++ b/collects/games/blackjack/blackjack.ss @@ -1,450 +1,440 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Blackjack -;; +;; ;; The standard rules apply. Specifics: -;; +;; ;; 1 player (not counting the dealer) -;; +;; ;; 4 decks, reshuffled after 3/4 of the cards are used -;; +;; ;; Dealer stands on soft 17s -;; +;; ;; Splitting allowed only on the first two cards, and only if they ;; are equal; 10 and the face cards are all considered equal for ;; splitting -;; +;; ;; Doubling allowed on all unsplit hands, not on split hands -;; +;; ;; No blackjacks after splitting -;; +;; ;; No surrender -;; +;; ;; No insurance -;; +;; ;; 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) -;; +;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(module blackjack mzscheme - (require (lib "cards.ss" "games" "cards") - (lib "mred.ss" "mred") - (lib "class.ss") - (lib "unit.ss") - (lib "list.ss")) - - (provide game@) - - (define game@ - (unit - (import) - (export) - - ;; Number of decks to use - (define DECK-COUNT 4) - - ;; Region layout constants - (define MARGIN 10) - (define SUBMARGIN 10) - (define LABEL-H 15) - - ;; Randomize - (random-seed (modulo (current-milliseconds) 10000)) - - ;; Reshuffle when 3/4 of the deck is used - (define min-deck-size (/ (* DECK-COUNT 52) 4)) - - ;; Set up the table - (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) - - ;; Get table width & height - (define w (send t table-width)) - (define h (send t table-height)) - - ;; Build the deck - (define deck - (let loop ([n DECK-COUNT]) - (if (zero? n) - null - (append (make-deck) (loop (sub1 n)))))) - - ;; Card width & height - (define cw (send (car deck) card-width)) - (define ch (send (car deck) card-height)) - - ;; Size of buttons - (define BUTTON-HEIGHT 16) - (define BUTTON-WIDTH cw) - - ;; Cards are not movable - (for-each - (lambda (card) - (send card user-can-move #f) - (send card user-can-flip #f)) - deck) - - ;; Set up card regions - (define deck-region - (make-region MARGIN MARGIN - cw ch #f #f)) - - (define discard-region - (make-region (- w cw MARGIN) MARGIN - cw ch #f #f)) - - (define dealer-region - (make-region (+ cw (* 2 MARGIN)) MARGIN - (- w (* 2 cw) (* 4 MARGIN)) ch - #f #f)) - - (define player-region - (make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT) - (- w (* 2 cw) (* 4 MARGIN)) ch - #f #f)) - - ;; In case of split, we need more regions - (define ww (* 3/2 cw)) - (define player-2-region - (make-region MARGIN (region-y player-region) - (- w ww (* 3 MARGIN)) (region-h player-region) - #f #f)) - (define player-2-wait-region - (make-region (region-x player-2-region) (region-y player-2-region) - ww (region-h player-2-region) - #f #f)) - (define player-1-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) - #f #f)) - (define player-1-wait-region - (make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww) - (region-y player-1-region) - ww (region-h player-1-region) - #f #f)) - (define (make-border-region r) - (define hm (/ MARGIN 2)) - (make-region (- (region-x r) hm) (- (region-y r) hm) - (+ (region-w r) MARGIN) (+ (region-h r) MARGIN) - "" #f)) - (define player-1-border (make-border-region player-1-region)) - (define player-2-border (make-border-region player-2-region)) - - ;; Player buttons - (define (make-button title pos) - (make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2) - (* pos (+ BUTTON-WIDTH MARGIN))) - (- h MARGIN BUTTON-HEIGHT) - BUTTON-WIDTH BUTTON-HEIGHT - title void)) - (define hit-button (make-button "Hit" 1)) - (define stand-button (make-button "Stand" 2)) - (define split-button (make-button "Split" 0)) - (define double-button (make-button "Double" 3)) - - ;; Put the cards on the table - (send t add-cards-to-region deck deck-region) - - ;; Function to compute the normal or minimum value of a card - (define (min-card-value c) - (let ([v (send c get-value)]) - (if (> v 10) - 10 - v))) - - ;; Function to compute the value of a hand, counting aces as 1 or 11 - ;; to get the highest total possible under 21 - (define (best-total l) - (let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))] - [aces (filter (ace? #t) l)] - [others (filter (ace? #f) l)] - [base (apply + (map min-card-value others))]) - (let loop ([l aces][base base]) - (cond - [(null? l) base] - [(<= (+ base (* (length aces) 11)) 21) - (+ base (* (length aces) 11))] - [else (loop (cdr l) (add1 base))])))) - - ;; Function to test whether a hand is a bust - (define (bust? p) - (> (best-total p) 21)) - - ;; Very simple betting... - (define money 100) - (define (update-money! d) - (set! money (+ money d)) - (send t set-status (format "You have $~a. (Each bet is $2.)" money))) - - ;; Let's play! - (let shuffle-loop () - ;; Shuffle the cards, none are discarded, yet - (let* ([deck (shuffle-list deck 7)] - [discard null] - [deal (lambda (n) - (let deal ([n n]) - (if (zero? n) - null - (let ([c (car deck)]) - (set! deck (cdr deck)) - (cons c (deal (sub1 n)))))))]) - ;; Put the shuffled deck in place - (send t move-cards-to-region deck deck-region) - (send t stack-cards deck) - ;; Loop rounds over while there's enough cards in the deck - (let loop () - ;; All bets are $2 - (update-money! -2) - ;; Deal to player - (let ([p (deal 2)] - [p2 null] ; in case of splitting - [double? #f]) ; in case of doubling (flag is needed to adjust money) - ;; Move the player's cards into place and show them - (send t move-cards-to-region p player-region) - (send t cards-face-up p) - ;; Deal to dealer - (let ([d (deal 2)]) - ;; Move the dealer's cards into place and show one - (send t move-cards-to-region d dealer-region) - (send t card-face-up (car d)) - (let* ([continue (make-semaphore)] - ;; Make a button in the center to show results - [make-status - (lambda (title continue) - (let ([r (make-button-region - (/ (- w (* 2 cw)) 2) - (region-y hit-button) - (* 2 cw) BUTTON-HEIGHT - title #f)]) - (set-region-callback! r (lambda () - (send t remove-region r) - (semaphore-post continue))) - r))] - ;; Done with hand: - [done - (lambda (title continue) - (send t remove-region hit-button) - (send t remove-region stand-button) - (send t add-region (make-status title continue)))] - ;; Compute winnings (not called for busts by the player) - [finish - (lambda (p blackjack?) - (let ([pt (best-total p)] - [dt (best-total d)] - [continue (make-semaphore)]) - (cond - [(or (> dt 21) (> pt dt)) - (update-money! (if blackjack? 5 (if double? 8 4))) - (done (if blackjack? - "Blackjack" - "You Win") - continue)] - [(> dt pt) - (done (if blackjack? - "Dealer Blackjack" - "You Lose") - continue)] - [else (update-money! (if double? 4 2)) - (done "Push" continue)]) - (yield continue)))] - ;; Done with the first hand of a split - [finish-split - (lambda (p player-region player-wait-region player-border) - (unless (bust? p) - (send t move-cards-to-region p player-region) - (send t add-region player-border) - (finish p #f) - (send t remove-region player-border) - (send t move-cards-to-region p player-wait-region)))] - ;; Player busts - [bust (lambda () - (done "Bust" continue))] - ;; Bust in one hand of a split - [local-bust (lambda () - (let ([cont (make-semaphore)]) - (done "Bust" cont) - (yield cont)))] - ;; Callback for the hit button; the button's callback - ;; is changed for diferent modes: normal, split part 1, or split part 2 - [make-hit-callback - (lambda (get-p set-p! player-region bust) - (lambda () - (send t remove-region double-button) - (send t remove-region split-button) - (set-p! (append (deal 1) (get-p))) - (send t stack-cards (get-p)) - (send t move-cards-to-region (get-p) player-region) - (send t cards-face-up (get-p)) - ;; Check for bust - (when (bust? (get-p)) - (bust))))]) - ;; Blackjack by player or dealer? - (if (or (= 21 (best-total p)) - (= 21 (best-total d))) - (begin - ;; Show the dealers cards... - (send t cards-face-up d) - ;; ... and compute the result - (finish p #t)) - (begin - ;; Three basic actions are allowed: - (send t add-region hit-button) - (send t add-region stand-button) - (send t add-region double-button) - ;; Set the callbacks for normal (unsplit) hands - (set-region-callback! hit-button - (make-hit-callback - (lambda () p) - (lambda (v) (set! p v)) - player-region - bust)) - (set-region-callback! stand-button - (lambda () +#lang mzscheme + +(require (lib "cards.ss" "games" "cards") + (lib "mred.ss" "mred") + (lib "class.ss") + (lib "list.ss") + (lib "unit.ss")) + +(provide game@) +(define game@ (unit (import) (export) + +;; Number of decks to use +(define DECK-COUNT 4) + +;; Region layout constants +(define MARGIN 10) +(define SUBMARGIN 10) +(define LABEL-H 15) + +;; Randomize +(random-seed (modulo (current-milliseconds) 10000)) + +;; Reshuffle when 3/4 of the deck is used +(define min-deck-size (/ (* DECK-COUNT 52) 4)) + +;; Set up the table +(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) + +;; Get table width & height +(define w (send t table-width)) +(define h (send t table-height)) + +;; Build the deck +(define deck + (let loop ([n DECK-COUNT]) + (if (zero? n) + null + (append (make-deck) (loop (sub1 n)))))) + +;; Card width & height +(define cw (send (car deck) card-width)) +(define ch (send (car deck) card-height)) + +;; Size of buttons +(define BUTTON-HEIGHT 16) +(define BUTTON-WIDTH cw) + +;; Cards are not movable +(for-each (lambda (card) (send* card (user-can-move #f) (user-can-flip #f))) + deck) + +;; Set up card regions +(define deck-region + (make-region MARGIN MARGIN cw ch #f #f)) + +(define discard-region + (make-region (- w cw MARGIN) MARGIN cw ch #f #f)) + +(define dealer-region + (make-region (+ cw (* 2 MARGIN)) MARGIN + (- w (* 2 cw) (* 4 MARGIN)) ch + #f #f)) + +(define player-region + (make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT) + (- w (* 2 cw) (* 4 MARGIN)) ch + #f #f)) + +;; In case of split, we need more regions +(define ww (* 3/2 cw)) +(define player-2-region + (make-region MARGIN (region-y player-region) + (- w ww (* 3 MARGIN)) (region-h player-region) + #f #f)) +(define player-2-wait-region + (make-region (region-x player-2-region) (region-y player-2-region) + ww (region-h player-2-region) + #f #f)) +(define player-1-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) + #f #f)) +(define player-1-wait-region + (make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww) + (region-y player-1-region) + ww (region-h player-1-region) + #f #f)) +(define (make-border-region r) + (define hm (/ MARGIN 2)) + (make-region (- (region-x r) hm) (- (region-y r) hm) + (+ (region-w r) MARGIN) (+ (region-h r) MARGIN) + "" #f)) +(define player-1-border (make-border-region player-1-region)) +(define player-2-border (make-border-region player-2-region)) + +;; Player buttons +(define (make-button title pos) + (make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2) + (* pos (+ BUTTON-WIDTH MARGIN))) + (- h MARGIN BUTTON-HEIGHT) + BUTTON-WIDTH BUTTON-HEIGHT + title void)) +(define hit-button (make-button "Hit" 1)) +(define stand-button (make-button "Stand" 2)) +(define split-button (make-button "Split" 0)) +(define double-button (make-button "Double" 3)) + +;; Put the cards on the table +(send t add-cards-to-region deck deck-region) + +;; Function to compute the normal or minimum value of a card +(define (min-card-value c) + (let ([v (send c get-value)]) (if (> v 10) 10 v))) + +;; Function to compute the value of a hand, counting aces as 1 or 11 +;; to get the highest total possible under 21 +(define (best-total l) + (let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))] + [aces (filter (ace? #t) l)] + [others (filter (ace? #f) l)] + [base (apply + (map min-card-value others))]) + (let loop ([l aces][base base]) + (cond [(null? l) base] + [(<= (+ base (* (length aces) 11)) 21) + (+ base (* (length aces) 11))] + [else (loop (cdr l) (add1 base))])))) + +;; Function to test whether a hand is a bust +(define (bust? p) + (> (best-total p) 21)) + +;; Very simple betting... +(define money 100) +(define (update-money! d) + (set! money (+ money d)) + (send t set-status (format "You have $~a. (Each bet is $2.)" money))) + +;; Let's play! +(let shuffle-loop () + ;; Shuffle the cards, none are discarded, yet + (let* ([deck (shuffle-list deck 7)] + [discard null] + [deal (lambda (n) + (let deal ([n n]) + (if (zero? n) + null + (let ([c (car deck)]) + (set! deck (cdr deck)) + (cons c (deal (sub1 n)))))))]) + ;; Put the shuffled deck in place + (send t move-cards-to-region deck deck-region) + (send t stack-cards deck) + ;; Loop rounds over while there's enough cards in the deck + (let loop () + ;; All bets are $2 + (update-money! -2) + ;; Deal to player + (let ([p (deal 2)] + [p2 null] ; in case of splitting + [double? #f]) ; in case of doubling (flag is needed to adjust money) + ;; Move the player's cards into place and show them + (send t move-cards-to-region p player-region) + (send t cards-face-up p) + ;; Deal to dealer + (let ([d (deal 2)]) + ;; Move the dealer's cards into place and show one + (send t move-cards-to-region d dealer-region) + (send t card-face-up (car d)) + (let* ([continue (make-semaphore)] + ;; Make a button in the center to show results + [make-status + (lambda (title continue) + (let ([r (make-button-region + (/ (- w (* 2 cw)) 2) + (region-y hit-button) + (* 2 cw) BUTTON-HEIGHT + title #f)]) + (set-region-callback! r (lambda () + (send t remove-region r) (semaphore-post continue))) - (set-region-callback! double-button - (lambda () - ;; Note the double for adjusting money on a win - (set! double? #t) - ;; Double the bet - (update-money! -2) - ;; Deal one more card - ((region-callback hit-button)) - ;; No more cards or actions, but if the player busted, the hit - ;; callback has already continued - (unless (bust? p) - (semaphore-post continue)))) - ;; Split allowed? - (when (= (min-card-value (car p)) (min-card-value (cadr p))) - ;; Yes, we can split. If the player hits the split button, - ;; we have to split the cards, deal one more to each split - ;; half and adjust the callbacks for hit and stand. - ;; (If aces are split, the round is over.) - (send t add-region split-button) - (set-region-callback! split-button - (lambda () - ;; Double our bet... - (update-money! -2) - ;; Split the hand - (set! p2 (list (cadr p))) - (set! p (list (car p))) - ;; Move the split halves to the "waiting" area. The - ;; active area is reserved for hands that are being - ;; played - (send t move-cards-to-region p player-1-wait-region) - (send t move-cards-to-region p2 player-2-wait-region) - ;; Deal one more card to each half and move them into place - (set! p (append (deal 1) p)) - (set! p2 (append (deal 1) p2)) - (send t stack-cards p) - (send t stack-cards p2) - (send t move-cards-to-region p player-1-wait-region) - (send t move-cards-to-region p2 player-2-wait-region) - ;; Show the newly dealt cards - (send t flip-cards (list (car p) (car p2))) - ;; No more splits, no doubling - (send t remove-region split-button) - (send t remove-region double-button) - ;; Function called when the last split hand is done - (let* ([close-split - (lambda () - ;; Unhilite the second hand - (send t remove-region player-2-border) - (send t move-cards-to-region p2 player-2-wait-region) - ;; Let the main loop finish up - (semaphore-post continue))] - ;; Callback to swicth from the first split hand to the second - [switch - (lambda () - ;; Unhilite the first hand - (send t remove-region player-1-border) - (send t move-cards-to-region p player-1-wait-region) - ;; Hilite the second hand - (send t move-cards-to-region p2 player-2-region) - (send t add-region player-2-border) - ;; Adjust callbacks to operate on the second hand - (set-region-callback! - hit-button - (make-hit-callback (lambda () p2) - (lambda (v) (set! p2 v)) - player-2-region - (lambda () - (local-bust) - (close-split)))) - (set-region-callback! - stand-button - close-split))]) - ;; Did we split aces? - (if (= 1 (send (cadr p) get-value)) - ;; Split aces; no more cards - (semaphore-post continue) - (begin - ;; The first of the split hands is ready to go - (send t move-cards-to-region p player-1-region) - ;; Hilite the first hand - (send t add-region player-1-border) - ;; Adjust callbacks to work on the first of a split hand - (set-region-callback! - hit-button - (make-hit-callback (lambda () p) - (lambda (v) (set! p v)) - player-1-region - (lambda () - (local-bust) - (switch) - (send t add-region hit-button) - (send t add-region stand-button)))) - (set-region-callback! - stand-button - switch))))))) - ;; Wait until the player is done - (yield continue) - ;; No more player actions; get rid of the buttons - (send t remove-region hit-button) - (send t remove-region stand-button) - (send t remove-region double-button) - (send t remove-region split-button) - ;; If all the player's hards are bust, the dealer doesn't do anything - (unless (and (bust? p) - (or (null? p2) - (bust? p2))) - ;; Show the dealer's starting hand - (send t card-face-up (cadr d)) - (let loop () - ;; Hit on 16 or lower, stand on 17 and higher - (when (< (best-total d) 17) - ;; Hit the dealer - (set! d (append (deal 1) d)) - (send t stack-cards d) - (send t move-cards-to-region d dealer-region) - (send t cards-face-up d) - (loop))) - (if (null? p2) - ;; Finish normal game (adjusts winnings) - (finish p #f) - ;; Finish split game (adjusts winnings for each hand) - (begin - (finish-split p player-1-region player-1-wait-region player-1-border) - (finish-split p2 player-2-region player-2-wait-region player-2-border)))))) - ;; Move all the discarded cards to the back - (unless (null? discard) - (send t card-to-back (car discard)) - (send t stack-cards discard)) - ;; Discard all the cards we used - (set! discard (append p p2 d discard)) - (send t cards-face-down discard) - (send t move-cards-to-region discard discard-region) - ;; Go again. Check whether we should reshuffle the deck or keep going with this one - (if (< (length deck) min-deck-size) - (begin - (send t move-cards-to-region deck discard-region) - (shuffle-loop)) - (loop))))))))))) + r))] + ;; Done with hand: + [done + (lambda (title continue) + (send t remove-region hit-button) + (send t remove-region stand-button) + (send t add-region (make-status title continue)))] + ;; Compute winnings (not called for busts by the player) + [finish + (lambda (p blackjack?) + (let ([pt (best-total p)] + [dt (best-total d)] + [continue (make-semaphore)]) + (cond + [(or (> dt 21) (> pt dt)) + (update-money! (if blackjack? 5 (if double? 8 4))) + (done (if blackjack? + "Blackjack" + "You Win") + continue)] + [(> dt pt) + (done (if blackjack? + "Dealer Blackjack" + "You Lose") + continue)] + [else (update-money! (if double? 4 2)) + (done "Push" continue)]) + (yield continue)))] + ;; Done with the first hand of a split + [finish-split + (lambda (p player-region player-wait-region player-border) + (unless (bust? p) + (send t move-cards-to-region p player-region) + (send t add-region player-border) + (finish p #f) + (send t remove-region player-border) + (send t move-cards-to-region p player-wait-region)))] + ;; Player busts + [bust (lambda () + (done "Bust" continue))] + ;; Bust in one hand of a split + [local-bust (lambda () + (let ([cont (make-semaphore)]) + (done "Bust" cont) + (yield cont)))] + ;; Callback for the hit button; the button's callback is + ;; changed for diferent modes: normal, split part 1, or split + ;; part 2 + [make-hit-callback + (lambda (get-p set-p! player-region bust) + (lambda () + (send t remove-region double-button) + (send t remove-region split-button) + (set-p! (append (deal 1) (get-p))) + (send t stack-cards (get-p)) + (send t move-cards-to-region (get-p) player-region) + (send t cards-face-up (get-p)) + ;; Check for bust + (when (bust? (get-p)) (bust))))]) + ;; Blackjack by player or dealer? + (if (or (= 21 (best-total p)) + (= 21 (best-total d))) + (begin + ;; Show the dealers cards... + (send t cards-face-up d) + ;; ... and compute the result + (finish p #t)) + (begin + ;; Three basic actions are allowed: + (send t add-region hit-button) + (send t add-region stand-button) + (send t add-region double-button) + ;; Set the callbacks for normal (unsplit) hands + (set-region-callback! + hit-button + (make-hit-callback (lambda () p) + (lambda (v) (set! p v)) + player-region + bust)) + (set-region-callback! + stand-button + (lambda () (semaphore-post continue))) + (set-region-callback! + double-button + (lambda () + ;; Note the double for adjusting money on a win + (set! double? #t) + ;; Double the bet + (update-money! -2) + ;; Deal one more card + ((region-callback hit-button)) + ;; No more cards or actions, but if the player busted, the + ;; hit callback has already continued + (unless (bust? p) (semaphore-post continue)))) + ;; Split allowed? + (when (= (min-card-value (car p)) (min-card-value (cadr p))) + ;; Yes, we can split. If the player hits the split button, we + ;; have to split the cards, deal one more to each split half + ;; and adjust the callbacks for hit and stand. (If aces are + ;; split, the round is over.) + (send t add-region split-button) + (set-region-callback! + split-button + (lambda () + ;; Double our bet... + (update-money! -2) + ;; Split the hand + (set! p2 (list (cadr p))) + (set! p (list (car p))) + ;; Move the split halves to the "waiting" area. The active + ;; area is reserved for hands that are being played + (send t move-cards-to-region p player-1-wait-region) + (send t move-cards-to-region p2 player-2-wait-region) + ;; Deal one more card to each half and move them into + ;; place + (set! p (append (deal 1) p)) + (set! p2 (append (deal 1) p2)) + (send t stack-cards p) + (send t stack-cards p2) + (send t move-cards-to-region p player-1-wait-region) + (send t move-cards-to-region p2 player-2-wait-region) + ;; Show the newly dealt cards + (send t flip-cards (list (car p) (car p2))) + ;; No more splits, no doubling + (send t remove-region split-button) + (send t remove-region double-button) + ;; Function called when the last split hand is done + (let* ([close-split + (lambda () + ;; Unhilite the second hand + (send t remove-region player-2-border) + (send t move-cards-to-region p2 player-2-wait-region) + ;; Let the main loop finish up + (semaphore-post continue))] + ;; Callback to swicth from the first split hand to + ;; the second + [switch + (lambda () + ;; Unhilite the first hand + (send t remove-region player-1-border) + (send t move-cards-to-region p player-1-wait-region) + ;; Hilite the second hand + (send t move-cards-to-region p2 player-2-region) + (send t add-region player-2-border) + ;; Adjust callbacks to operate on the second hand + (set-region-callback! + hit-button + (make-hit-callback (lambda () p2) + (lambda (v) (set! p2 v)) + player-2-region + (lambda () + (local-bust) + (close-split)))) + (set-region-callback! + stand-button + close-split))]) + ;; Did we split aces? + (if (= 1 (send (cadr p) get-value)) + ;; Split aces; no more cards + (semaphore-post continue) + (begin + ;; The first of the split hands is ready to go + (send t move-cards-to-region p player-1-region) + ;; Hilite the first hand + (send t add-region player-1-border) + ;; Adjust callbacks to work on the first of a split + ;; hand + (set-region-callback! + hit-button + (make-hit-callback (lambda () p) + (lambda (v) (set! p v)) + player-1-region + (lambda () + (local-bust) + (switch) + (send t add-region hit-button) + (send t add-region stand-button)))) + (set-region-callback! stand-button switch))))))) + ;; Wait until the player is done + (yield continue) + ;; No more player actions; get rid of the buttons + (send t remove-region hit-button) + (send t remove-region stand-button) + (send t remove-region double-button) + (send t remove-region split-button) + ;; If all the player's hards are bust, the dealer doesn't do + ;; anything + (unless (and (bust? p) (or (null? p2) (bust? p2))) + ;; Show the dealer's starting hand + (send t card-face-up (cadr d)) + (let loop () + ;; Hit on 16 or lower, stand on 17 and higher + (when (< (best-total d) 17) + ;; Hit the dealer + (set! d (append (deal 1) d)) + (send t stack-cards d) + (send t move-cards-to-region d dealer-region) + (send t cards-face-up d) + (loop))) + (if (null? p2) + ;; Finish normal game (adjusts winnings) + (finish p #f) + ;; Finish split game (adjusts winnings for each hand) + (begin + (finish-split p player-1-region player-1-wait-region player-1-border) + (finish-split p2 player-2-region player-2-wait-region player-2-border)))))) + ;; Move all the discarded cards to the back + (unless (null? discard) + (send t card-to-back (car discard)) + (send t stack-cards discard)) + ;; Discard all the cards we used + (set! discard (append p p2 d discard)) + (send t cards-face-down discard) + (send t move-cards-to-region discard discard-region) + ;; Go again. Check whether we should reshuffle the deck or keep + ;; going with this one + (if (< (length deck) min-deck-size) + (begin (send t move-cards-to-region deck discard-region) + (shuffle-loop)) + (loop)))))))) + +)) diff --git a/collects/games/blackjack/doc.txt b/collects/games/blackjack/doc.txt index a73db82d6c..fe4ed2b5e4 100644 --- a/collects/games/blackjack/doc.txt +++ b/collects/games/blackjack/doc.txt @@ -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: - * 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 - they are equal; 10 and the face cards are all considered equal - for splitting +* Splitting is allowed only on the first two cards, and only if they + are equal; 10 and the face cards are all considered equal for + splitting - * Doubling is allowed on all unsplit hands, not on split hands +* 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 - - * Dealer's second card is not revealed if the player busts (or - both halves of a split hand bust) +* 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) diff --git a/collects/games/checkers/checkers.ss b/collects/games/checkers/checkers.ss index c17a04baa5..05838410a6 100644 --- a/collects/games/checkers/checkers.ss +++ b/collects/games/checkers/checkers.ss @@ -1,244 +1,238 @@ -(module checkers mzscheme - (require (lib "gl-board.ss" "games" "gl-board-game") - (lib "class.ss") - (lib "math.ss") - (lib "mred.ss" "mred") - (lib "gl-vectors.ss" "sgl") - (prefix gl- (lib "sgl.ss" "sgl")) - (lib "gl.ss" "sgl") - (lib "array.ss" "srfi" "25") - (lib "unit.ss") - (lib "include-bitmap.ss" "mrlib") - "honu-bitmaps.ss") - - (provide game@) +#lang mzscheme - (define-struct image (width height rgba)) - - (define (argb->rgba argb) - (let* ((length (bytes-length argb)) - (rgba (make-gl-ubyte-vector length))) - (let loop ((i 0)) - (when (< i length) - (gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1))) - (gl-vector-set! rgba (+ i 1) (bytes-ref argb (+ i 2))) - (gl-vector-set! rgba (+ i 2) (bytes-ref argb (+ i 3))) - (gl-vector-set! rgba (+ i 3) (bytes-ref argb (+ i 0))) - (loop (+ i 4)))) - rgba)) - - (define (bitmap->argb bmp) - (let* ((width (send bmp get-width)) - (height (send bmp get-height)) - (argb (make-bytes (* 4 width height) 255)) - (dc (make-object bitmap-dc% bmp))) - (send dc get-argb-pixels 0 0 width height argb #f) - (when (send bmp get-loaded-mask) - (send dc set-bitmap (send bmp get-loaded-mask)) - (send dc get-argb-pixels 0 0 width height argb #t)) - (send dc set-bitmap #f) - argb)) - - (define (bitmap->image bmp) - (make-image (send bmp get-width) (send bmp get-height) - (argb->rgba (bitmap->argb bmp)))) +(require (lib "gl-board.ss" "games" "gl-board-game") + (lib "class.ss") + (lib "math.ss") + (lib "mred.ss" "mred") + (lib "unit.ss") + (lib "gl-vectors.ss" "sgl") + (prefix gl- (lib "sgl.ss" "sgl")) + (lib "gl.ss" "sgl") + (lib "array.ss" "srfi" "25") + (lib "include-bitmap.ss" "mrlib") + "honu-bitmaps.ss") +(provide game@) - (define light-square-img (bitmap->image (include-bitmap "light.jpg"))) - (define light-square-color (gl-float-vector .7216 .6471 .5176 1)) - (define dark-square-img (bitmap->image (include-bitmap "dark.jpg"))) - (define dark-square-color (gl-float-vector .4745 .3569 .2627 1)) - - (define (color-name->vector name darken?) - (let ([color (send the-color-database find-color name)] - [adj (if darken? sqr values)]) - (unless color - (error 'color-name->vector "could not find ~e" name)) - (gl-float-vector (adj (/ (send color red) 255)) - (adj (/ (send color green) 255)) - (adj (/ (send color blue) 255)) - 1.0))) - - (define light-checker-img (bitmap->image honu-down-bitmap)) - (define dark-checker-img (bitmap->image honu-bitmap)) - - (define-struct space-info (x y light?)) - (define-struct piece-info (x y color king?) (make-inspector)) - (define-struct moves (list forced-jump?)) +(define-struct image (width height rgba)) - (define-signature model^ - (move)) - (define-signature view^ - (add-space add-piece remove-piece move-piece set-turn show)) +(define (argb->rgba argb) + (let* ([length (bytes-length argb)] + [rgba (make-gl-ubyte-vector length)]) + (let loop ((i 0)) + (when (< i length) + (gl-vector-set! rgba (+ i 0) (bytes-ref argb (+ i 1))) + (gl-vector-set! rgba (+ i 1) (bytes-ref argb (+ i 2))) + (gl-vector-set! rgba (+ i 2) (bytes-ref argb (+ i 3))) + (gl-vector-set! rgba (+ i 3) (bytes-ref argb (+ i 0))) + (loop (+ i 4)))) + rgba)) - (define-unit view@ - (import model^) - (export view^) +(define (bitmap->argb bmp) + (let* ([width (send bmp get-width)] + [height (send bmp get-height)] + [argb (make-bytes (* 4 width height) 255)] + [dc (make-object bitmap-dc% bmp)]) + (send dc get-argb-pixels 0 0 width height argb #f) + (when (send bmp get-loaded-mask) + (send dc set-bitmap (send bmp get-loaded-mask)) + (send dc get-argb-pixels 0 0 width height argb #t)) + (send dc set-bitmap #f) + argb)) - (define (get-space-draw-fn space) - (let* ((list-id (get-square-dl (space-info-light? space) - (send texture-box get-value))) - (sx (space-info-x space)) - (sy (space-info-y space))) - (lambda () - (gl-push-matrix) - (gl-translate sx sy 0) - (gl-call-list list-id) - (gl-pop-matrix)))) - - (define (add-space space) - (send board add-space (get-space-draw-fn space) space)) +(define (bitmap->image bmp) + (make-image (send bmp get-width) (send bmp get-height) + (argb->rgba (bitmap->argb bmp)))) - (define (get-piece-draw-fn piece glow?) - (let ((list-id (get-checker-dl (eq? 'red (piece-info-color piece)) - (piece-info-king? piece) - (send texture-box get-value)))) - (if glow? - (lambda (for-shadow?) - (gl-material-v 'front 'emission (gl-float-vector 0.15 0.15 0.15 1.0)) - (gl-call-list ((if for-shadow? cdr car) list-id)) - (gl-material-v 'front 'emission (gl-float-vector 0.0 0.0 0.0 1.0))) - (lambda (for-shadow?) - (gl-call-list ((if for-shadow? cdr car) list-id)))))) - - (define add-piece - (case-lambda - ((piece) (add-piece piece #f)) - ((piece glow?) - (send board add-piece (+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0 - (get-piece-draw-fn piece glow?) - piece)))) - - (define (move-piece from to-x to-y) - (remove-piece from) - (add-piece (make-piece-info to-x to-y (piece-info-color from) (piece-info-king? from)))) - - (define (remove-piece p) - (send board remove-piece p)) +(define light-square-img (bitmap->image (include-bitmap "light.jpg"))) +(define light-square-color (gl-float-vector .7216 .6471 .5176 1)) +(define dark-square-img (bitmap->image (include-bitmap "dark.jpg"))) +(define dark-square-color (gl-float-vector .4745 .3569 .2627 1)) - (define (internal-move old move-to) - (when (piece-info? old) - (move old move-to))) +(define (color-name->vector name darken?) + (let ([color (send the-color-database find-color name)] + [adj (if darken? sqr values)]) + (unless color + (error 'color-name->vector "could not find ~e" name)) + (gl-float-vector (adj (/ (send color red) 255)) + (adj (/ (send color green) 255)) + (adj (/ (send color blue) 255)) + 1.0))) - (define (set-turn turn moves) - (let* ([pieces (send board get-pieces)]) - (for-each (lambda (p) - (send board set-piece-draw p - (get-piece-draw-fn p #f)) - (send board enable-piece p #f)) - pieces) - (for-each (lambda (p) - (send board set-piece-draw p - (get-piece-draw-fn p #t)) - (send board enable-piece p #t)) - (moves-list moves))) - (send msg set-label - (if (null? (moves-list moves)) - (format "~a wins!" (if (eq? turn 'red) "Black" "Red")) - (format "~a's turn~a" - (if (eq? turn 'red) "Red" "Black") - (if (moves-forced-jump? moves) - " - must take jump" - ""))))) - - (define f (new frame% (label "Checkers") (width 800) (height 600))) - (define board - (new gl-board% (parent f) (who "Checkers") - (min-x 0.0) (max-x 8.0) (min-y 0.0) (max-y 8.0) - (lift .35) - (move internal-move))) - (define hp (new horizontal-pane% (parent f) (stretchable-height #f))) - (define msg - (new message% (label "") (parent hp) (stretchable-width #t))) - (define texture-box - (new check-box% (label "Textured") (parent hp) - (callback - (lambda (box _) - (for-each - (lambda (s) - (send board set-space-draw s - (get-space-draw-fn s))) - (send board get-spaces)) - (for-each - (lambda (p) - (send board set-piece-draw p - (get-piece-draw-fn p (send board enabled? p)))) - (send board get-pieces)) - (send board refresh))))) - (new grow-box-spacer-pane% [parent hp]) - (send texture-box set-value #t) - - (define q - (send board with-gl-context - (lambda () (gl-new-quadric)))) +(define light-checker-img (bitmap->image honu-down-bitmap)) +(define dark-checker-img (bitmap->image honu-bitmap)) - (define-values (dark-tex light-tex dark-checker-tex light-checker-tex) - (send board with-gl-context +(define-struct space-info (x y light?)) +(define-struct piece-info (x y color king?) (make-inspector)) +(define-struct moves (list forced-jump?)) + +(define-signature model^ + (move)) +(define-signature view^ + (add-space add-piece remove-piece move-piece set-turn show)) + +(define-unit view@ + (import model^) + (export view^) + + (define (get-space-draw-fn space) + (let* ([list-id (get-square-dl (space-info-light? space) + (send texture-box get-value))] + [sx (space-info-x space)] + [sy (space-info-y space)]) + (lambda () + (gl-push-matrix) + (gl-translate sx sy 0) + (gl-call-list list-id) + (gl-pop-matrix)))) + + (define (add-space space) + (send board add-space (get-space-draw-fn space) space)) + + (define (get-piece-draw-fn piece glow?) + (let ([list-id (get-checker-dl (eq? 'red (piece-info-color piece)) + (piece-info-king? piece) + (send texture-box get-value))]) + (if glow? + (lambda (for-shadow?) + (gl-material-v 'front 'emission (gl-float-vector 0.15 0.15 0.15 1.0)) + (gl-call-list ((if for-shadow? cdr car) list-id)) + (gl-material-v 'front 'emission (gl-float-vector 0.0 0.0 0.0 1.0))) + (lambda (for-shadow?) + (gl-call-list ((if for-shadow? cdr car) list-id)))))) + + (define add-piece + (case-lambda + [(piece) (add-piece piece #f)] + [(piece glow?) + (send board add-piece + (+ .5 (piece-info-x piece)) (+ .5 (piece-info-y piece)) 0.0 + (get-piece-draw-fn piece glow?) + piece)])) + + (define (move-piece from to-x to-y) + (remove-piece from) + (add-piece (make-piece-info to-x to-y + (piece-info-color from) + (piece-info-king? from)))) + + (define (remove-piece p) + (send board remove-piece p)) + + (define (internal-move old move-to) + (when (piece-info? old) (move old move-to))) + + (define (set-turn turn moves) + (let ([pieces (send board get-pieces)]) + (for-each (lambda (p) + (send board set-piece-draw p (get-piece-draw-fn p #f)) + (send board enable-piece p #f)) + pieces) + (for-each (lambda (p) + (send board set-piece-draw p (get-piece-draw-fn p #t)) + (send board enable-piece p #t)) + (moves-list moves))) + (send msg set-label + (if (null? (moves-list moves)) + (format "~a wins!" (if (eq? turn 'red) "Black" "Red")) + (format "~a's turn~a" + (if (eq? turn 'red) "Red" "Black") + (if (moves-forced-jump? moves) " - must take jump" ""))))) + + (define f (new frame% (label "Checkers") (width 800) (height 600))) + (define board + (new gl-board% (parent f) (who "Checkers") + (min-x 0.0) (max-x 8.0) (min-y 0.0) (max-y 8.0) + (lift .35) + (move internal-move))) + (define hp (new horizontal-pane% (parent f) (stretchable-height #f))) + (define msg + (new message% (label "") (parent hp) (stretchable-width #t))) + (define texture-box + (new check-box% (label "Textured") (parent hp) + (callback + (lambda (box _) + (for-each + (lambda (s) + (send board set-space-draw s (get-space-draw-fn s))) + (send board get-spaces)) + (for-each + (lambda (p) + (send board set-piece-draw p + (get-piece-draw-fn p (send board enabled? p)))) + (send board get-pieces)) + (send board refresh))))) + (new grow-box-spacer-pane% [parent hp]) + (send texture-box set-value #t) + + (define q + (send board with-gl-context (lambda () (gl-new-quadric)))) + + (define-values (dark-tex light-tex dark-checker-tex light-checker-tex) + (send board with-gl-context (lambda () (let ((x (glGenTextures 4))) - (values - (gl-vector-ref x 0) - (gl-vector-ref x 1) - (gl-vector-ref x 2) - (gl-vector-ref x 3)))))) - - (define (init-tex tex img) - (send board with-gl-context - (lambda () - (glBindTexture GL_TEXTURE_2D tex) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_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_T GL_CLAMP) - (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (image-width img) (image-height img) 0 - GL_RGBA GL_UNSIGNED_BYTE (image-rgba img))))) - - (init-tex light-tex light-square-img) - (init-tex dark-tex dark-square-img) - (init-tex dark-checker-tex dark-checker-img) - (init-tex light-checker-tex light-checker-img) - - (define (make-piece-dl color height tex shadow?) - (send board with-gl-context - (lambda () - (let ((list-id (gl-gen-lists 1))) - (gl-quadric-draw-style q 'fill) - (gl-quadric-normals q 'smooth) - (gl-new-list list-id 'compile) - - (when shadow? - (gl-disable 'lighting)) - (gl-material-v 'front 'specular (gl-float-vector 1.0 1.0 1.0 1.0)) - (gl-material 'front 'shininess 120.0) - - (gl-material-v 'front 'ambient-and-diffuse color) - (gl-cylinder q .35 .35 height 25 1) - (gl-push-matrix) - (gl-translate 0.0 0.0 height) - - (when (and tex (not shadow?)) - (gl-enable 'texture-2d) - (glBindTexture GL_TEXTURE_2D tex) - (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_DECAL) - (gl-quadric-texture q #t)) - - (gl-disk q 0.0 .35 25 1) - - (when (and tex (not shadow?)) - (gl-quadric-texture q #f) - (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE) - (gl-disable 'texture-2d)) - - (gl-pop-matrix) - - (when shadow? - (gl-enable 'lighting)) - (gl-end-list) - list-id)))) + (values (gl-vector-ref x 0) + (gl-vector-ref x 1) + (gl-vector-ref x 2) + (gl-vector-ref x 3)))))) - (define (make-tex-square-dl tex) - (send board with-gl-context + (define (init-tex tex img) + (send board with-gl-context (lambda () - (let ((list-id (gl-gen-lists 1))) + (glBindTexture GL_TEXTURE_2D tex) + (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_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_T GL_CLAMP) + (glTexImage2D GL_TEXTURE_2D 0 GL_RGBA + (image-width img) (image-height img) 0 + GL_RGBA GL_UNSIGNED_BYTE (image-rgba img))))) + + (init-tex light-tex light-square-img) + (init-tex dark-tex dark-square-img) + (init-tex dark-checker-tex dark-checker-img) + (init-tex light-checker-tex light-checker-img) + + (define (make-piece-dl color height tex shadow?) + (send board with-gl-context + (lambda () + (let ([list-id (gl-gen-lists 1)]) + (gl-quadric-draw-style q 'fill) + (gl-quadric-normals q 'smooth) + (gl-new-list list-id 'compile) + + (when shadow? (gl-disable 'lighting)) + (gl-material-v 'front 'specular (gl-float-vector 1.0 1.0 1.0 1.0)) + (gl-material 'front 'shininess 120.0) + + (gl-material-v 'front 'ambient-and-diffuse color) + (gl-cylinder q .35 .35 height 25 1) + (gl-push-matrix) + (gl-translate 0.0 0.0 height) + + (when (and tex (not shadow?)) + (gl-enable 'texture-2d) + (glBindTexture GL_TEXTURE_2D tex) + (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_DECAL) + (gl-quadric-texture q #t)) + + (gl-disk q 0.0 .35 25 1) + + (when (and tex (not shadow?)) + (gl-quadric-texture q #f) + (glTexEnvf GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE) + (gl-disable 'texture-2d)) + + (gl-pop-matrix) + + (when shadow? (gl-enable 'lighting)) + (gl-end-list) + list-id)))) + + (define (make-tex-square-dl tex) + (send board with-gl-context + (lambda () + (let ([list-id (gl-gen-lists 1)]) (gl-new-list list-id 'compile) (gl-enable 'texture-2d) (glBindTexture GL_TEXTURE_2D tex) @@ -258,10 +252,10 @@ (gl-end-list) list-id)))) - (define (make-square-dl color) - (send board with-gl-context + (define (make-square-dl color) + (send board with-gl-context (lambda () - (let ((list-id (gl-gen-lists 1))) + (let ([list-id (gl-gen-lists 1)]) (gl-new-list list-id 'compile) (gl-material-v 'front 'ambient-and-diffuse color) (gl-begin 'polygon) @@ -272,15 +266,16 @@ (gl-end) (gl-end-list) list-id)))) - - (define checkers - (map - (lambda (x) - (let ((color (if (car x) + + (define checkers + (map (lambda (x) + (let ([color (if (car x) (color-name->vector "firebrick" #t) - (gl-float-vector 0.15 0.15 0.15 1.0))) - (height (if (cadr x) .4 .2)) - (tex (if (caddr x) (if (car x) light-checker-tex dark-checker-tex) #f))) + (gl-float-vector 0.15 0.15 0.15 1.0))] + [height (if (cadr x) .4 .2)] + [tex (if (caddr x) + (if (car x) light-checker-tex dark-checker-tex) + #f)]) (cons x (cons (make-piece-dl color height tex #f) (make-piece-dl color height tex #t))))) '((#f #f #f) @@ -291,155 +286,142 @@ (#t #f #t) (#t #t #f) (#t #t #t)))) - (define (get-checker-dl light? king? tex?) - (cdr (assoc (list light? king? tex?) checkers))) - - (define dark-square (cons (make-tex-square-dl dark-tex) - (make-square-dl dark-square-color))) - (define light-square (cons (make-tex-square-dl light-tex) - (make-square-dl light-square-color))) - (define (get-square-dl light? tex?) - (let ((getter (if tex? car cdr))) - (getter (if light? light-square dark-square)))) - - (define (show) - (send f show #t))) - - (define-unit model@ - (import view^) - (export model^) + (define (get-checker-dl light? king? tex?) + (cdr (assoc (list light? king? tex?) checkers))) - (define turn 'red) - (define board (make-array (shape 0 8 0 8) #f)) - - (let loop ((i 0) - (j 0)) - (cond - ((and (< j 8) (< i 8)) - (cond - ((even? (+ i j)) - (add-space (make-space-info j i #f)) - (cond - ((< i 3) + (define dark-square (cons (make-tex-square-dl dark-tex) + (make-square-dl dark-square-color))) + (define light-square (cons (make-tex-square-dl light-tex) + (make-square-dl light-square-color))) + (define (get-square-dl light? tex?) + (let ((getter (if tex? car cdr))) + (getter (if light? light-square dark-square)))) + + (define (show) (send f show #t))) + +(define-unit model@ + (import view^) + (export model^) + + (define turn 'red) + (define board (make-array (shape 0 8 0 8) #f)) + + (let loop ([i 0] [j 0]) + (cond + [(and (< j 8) (< i 8)) + (cond + [(even? (+ i j)) + (add-space (make-space-info j i #f)) + (cond [(< i 3) (array-set! board j i (cons 'red #f)) - (add-piece (make-piece-info j i 'red #f))) - ((> i 4) + (add-piece (make-piece-info j i 'red #f))] + [(> i 4) (array-set! board j i (cons 'black #f)) - (add-piece (make-piece-info j i 'black #f))))) - (else - (add-space (make-space-info j i #t)))) - (loop i (add1 j))) - ((< i 8) (loop (add1 i) 0)))) + (add-piece (make-piece-info j i 'black #f))])] + [else (add-space (make-space-info j i #t))]) + (loop i (add1 j))] + [(< i 8) (loop (add1 i) 0)])) - (define (other-color c) - (cond - ((eq? c 'red) 'black) - (else 'red))) - - (define (single-move-ok? direction from-x from-y to-x to-y) - (and (= to-y (+ direction from-y)) - (= 1 (abs (- from-x to-x))))) + (define (other-color c) + (if (eq? c 'red) 'black 'red)) - (define (can-move? direction from-x from-y) - (and (<= 0 (+ from-y direction) 7) - (or (and (<= 0 (+ from-x 1) 7) - (not (array-ref board (+ from-x 1) (+ from-y direction)))) - (and (<= 0 (+ from-x -1) 7) - (not (array-ref board (+ from-x -1) (+ from-y direction))))))) - - (define (get-jumped-piece color direction from-x from-y to-x to-y) - (and (= to-y (+ direction direction from-y)) - (= 2 (abs (- from-x to-x))) - (let* ((jumped-x (+ from-x (/ (- to-x from-x) 2))) - (jumped-y (+ from-y direction)) - (jumped-piece (array-ref board jumped-x jumped-y))) - (and jumped-piece - (eq? (other-color color) (car jumped-piece)) - (make-piece-info jumped-x jumped-y (car jumped-piece) (cdr jumped-piece)))))) - - (define (can-jump? direction from-color from-x from-y) - (let ((to-y (+ direction direction from-y)) - (to-x1 (+ from-x 2)) - (to-x2 (- from-x 2))) - (and (<= 0 to-y 7) - (or (and (<= 0 to-x1 7) - (not (array-ref board to-x1 to-y)) - (get-jumped-piece from-color direction - from-x from-y - to-x1 to-y)) - (and (<= 0 to-x2) - (not (array-ref board to-x2 to-y)) - (get-jumped-piece from-color direction - from-x from-y - to-x2 to-y)))))) - + (define (single-move-ok? direction from-x from-y to-x to-y) + (and (= to-y (+ direction from-y)) + (= 1 (abs (- from-x to-x))))) - (define (fold-board f v) - (let iloop ([i 0][v v]) - (if (= i 8) - v - (let jloop ([j 0][v v]) - (if (= j 8) - (iloop (add1 i) v) - (jloop (add1 j) - (if (even? (+ i j)) - (f i j v) - v))))))) + (define (can-move? direction from-x from-y) + (and (<= 0 (+ from-y direction) 7) + (or (and (<= 0 (+ from-x 1) 7) + (not (array-ref board (+ from-x 1) (+ from-y direction)))) + (and (<= 0 (+ from-x -1) 7) + (not (array-ref board (+ from-x -1) (+ from-y direction))))))) - (define (get-jump-moves) - (let ([direction (if (eq? turn 'red) 1 -1)]) - (fold-board - (lambda (i j l) - (let ([p (array-ref board i j)]) - (if (and p - (eq? (car p) turn) - (or (can-jump? direction turn i j) - (and (cdr p) - (can-jump? (- direction) turn i j)))) - (cons (make-piece-info i j turn (cdr p)) l) - l))) - null))) + (define (get-jumped-piece color direction from-x from-y to-x to-y) + (and (= to-y (+ direction direction from-y)) + (= 2 (abs (- from-x to-x))) + (let* ([jumped-x (+ from-x (/ (- to-x from-x) 2))] + [jumped-y (+ from-y direction)] + [jumped-piece (array-ref board jumped-x jumped-y)]) + (and jumped-piece + (eq? (other-color color) (car jumped-piece)) + (make-piece-info jumped-x jumped-y + (car jumped-piece) (cdr jumped-piece)))))) - (define (get-moves) - (let ([jumps (get-jump-moves)]) - (if (pair? jumps) - (make-moves jumps #t) - (make-moves - (let ([direction (if (eq? turn 'red) 1 -1)]) - (fold-board - (lambda (i j l) - (let ([p (array-ref board i j)]) - (if (and p - (eq? (car p) turn) - (or (can-move? direction i j) - (and (cdr p) - (can-move? (- direction) i j)))) - (cons (make-piece-info i j turn (cdr p)) l) - l))) - null)) - #f)))) + (define (can-jump? direction from-color from-x from-y) + (let ([to-y (+ direction direction from-y)] + [to-x1 (+ from-x 2)] + [to-x2 (- from-x 2)]) + (and (<= 0 to-y 7) + (or (and (<= 0 to-x1 7) + (not (array-ref board to-x1 to-y)) + (get-jumped-piece from-color direction + from-x from-y + to-x1 to-y)) + (and (<= 0 to-x2) + (not (array-ref board to-x2 to-y)) + (get-jumped-piece from-color direction + from-x from-y + to-x2 to-y)))))) - (define (move from to) - (let* ((to-x (inexact->exact (floor (gl-vector-ref to 0)))) - (to-y (inexact->exact (floor (gl-vector-ref to 1)))) - (from-x (piece-info-x from)) - (from-y (piece-info-y from)) - (from-color (piece-info-color from)) - (from-king? (piece-info-king? from)) - (to-king? (or from-king? - (if (eq? 'red from-color) - (= to-y 7) - (= to-y 0)))) - (direction (if (eq? turn 'red) 1 -1))) - (when (and (eq? turn from-color) - (<= 0 to-x 7) - (<= 0 to-y 7) - (not (array-ref board to-x to-y))) - (cond - ((and (null? (get-jump-moves)) + (define (fold-board f v) + (let iloop ([i 0] [v v]) + (if (= i 8) + v + (let jloop ([j 0] [v v]) + (if (= j 8) + (iloop (add1 i) v) + (jloop (add1 j) (if (even? (+ i j)) (f i j v) v))))))) + + (define (get-jump-moves) + (let ([direction (if (eq? turn 'red) 1 -1)]) + (fold-board + (lambda (i j l) + (let ([p (array-ref board i j)]) + (if (and p + (eq? (car p) turn) + (or (can-jump? direction turn i j) + (and (cdr p) + (can-jump? (- direction) turn i j)))) + (cons (make-piece-info i j turn (cdr p)) l) + l))) + null))) + + (define (get-moves) + (let ([jumps (get-jump-moves)]) + (if (pair? jumps) + (make-moves jumps #t) + (make-moves + (let ([direction (if (eq? turn 'red) 1 -1)]) + (fold-board + (lambda (i j l) + (let ([p (array-ref board i j)]) + (if (and p + (eq? (car p) turn) + (or (can-move? direction i j) + (and (cdr p) (can-move? (- direction) i j)))) + (cons (make-piece-info i j turn (cdr p)) l) + l))) + null)) + #f)))) + + (define (move from to) + (let* ([to-x (inexact->exact (floor (gl-vector-ref to 0)))] + [to-y (inexact->exact (floor (gl-vector-ref to 1)))] + [from-x (piece-info-x from)] + [from-y (piece-info-y from)] + [from-color (piece-info-color from)] + [from-king? (piece-info-king? from)] + [to-king? (or from-king? (= to-y (if (eq? 'red from-color) 7 0)))] + [direction (if (eq? turn 'red) 1 -1)]) + (when (and (eq? turn from-color) + (<= 0 to-x 7) + (<= 0 to-y 7) + (not (array-ref board to-x to-y))) + (cond [(and (null? (get-jump-moves)) (or (single-move-ok? direction from-x from-y to-x to-y) (and from-king? - (single-move-ok? (- direction) from-x from-y to-x to-y)))) + (single-move-ok? (- direction) from-x from-y + to-x to-y)))) (move-piece from to-x to-y) (set! turn (other-color from-color)) (array-set! board to-x to-y (cons from-color to-king?)) @@ -447,8 +429,9 @@ (when (and to-king? (not from-king?)) (remove-piece (make-piece-info to-x to-y from-color from-king?)) (add-piece (make-piece-info to-x to-y from-color to-king?))) - (set-turn turn (get-moves))) - ((or (get-jumped-piece from-color direction from-x from-y to-x to-y) + (set-turn turn (get-moves))] + [(or (get-jumped-piece from-color direction from-x from-y + to-x to-y) (and from-king? (get-jumped-piece from-color (- direction) from-x from-y to-x to-y))) => @@ -462,25 +445,24 @@ (remove-piece (make-piece-info to-x to-y from-color from-king?)) (add-piece (make-piece-info to-x to-y from-color to-king?))) (cond - ((or (can-jump? direction from-color to-x to-y) + [(or (can-jump? direction from-color to-x to-y) (and from-king? (can-jump? (- direction) from-color to-x to-y))) - (set-turn turn (make-moves (list (make-piece-info to-x to-y from-color to-king?)) #t))) - (else + (set-turn turn + (make-moves (list (make-piece-info + to-x to-y from-color to-king?)) + #t))] + [else (set! turn (other-color from-color)) - (set-turn turn (get-moves)))))))))) + (set-turn turn (get-moves))]))])))) - (set-turn turn (get-moves)) - ) - - (define-unit show@ - (import view^) - (export) - (show)) - - (define game@ - (compound-unit/infer - (import) - (export) - (link view@ model@ show@))) + (set-turn turn (get-moves)) ) + +(define-unit show@ + (import view^) + (export) + (show)) + +(define game@ + (compound-unit/infer (import) (export) (link view@ model@ show@))) diff --git a/collects/games/crazy8s/crazy8s.ss b/collects/games/crazy8s/crazy8s.ss index d8288d4017..ff6302c7b0 100644 --- a/collects/games/crazy8s/crazy8s.ss +++ b/collects/games/crazy8s/crazy8s.ss @@ -1,692 +1,645 @@ -(module crazy8s mzscheme - (require (lib "cards.ss" "games" "cards") - (lib "mred.ss" "mred") - (lib "class.ss") - (lib "unit.ss") - (lib "etc.ss") - (lib "list.ss") - (lib "async-channel.ss") - (lib "file.ss")) +#lang mzscheme - ;; Player record - (define-struct player (r hand-r ; region +(require (lib "cards.ss" "games" "cards") + (lib "mred.ss" "mred") + (lib "class.ss") + (lib "unit.ss") + (lib "etc.ss") + (lib "list.ss") + (lib "async-channel.ss") + (lib "file.ss")) + +;; Player record +(define-struct player (r hand-r ; region hand)) ; cards - - ;; Messages - (define YOUR-NAME "You") - (define OPPONENT-X-NAME "Opponent ~a") - (define OPPONENT-NAME "Opponent") - (define YOUR-TURN-MESSAGE "Your turn - discard a ~a or crazy 8, or else ~a") - (define PICK-A-SUIT "Pick a suit") - (define GAME-OVER-YOU-WIN "Game over - you win!") - (define GAME-OVER-STUCK "Game over - no one wins") - (define GAME-OVER "Game over - opponent wins") - (define NEW-GAME "New Game") - - ;; Region layout constants - (define MARGIN 10) - (define SUBMARGIN 10) - (define LABEL-H 15) - (define BUTTON-HEIGHT 18) - (define PASS-W 40) - (define NEW-GAME-W 80) - (define SEL-WIDTH 32) - (define SEL-HEIGHT 32) - - (provide game@) - (define-signature configuration^ - (opponents-count - init-hand-size - drag-mode? - new-game)) - - ;; This unit drives multiple Crazy 8 instances: - (define game@ - (unit - (import) - (export) +;; Messages +(define YOUR-NAME "You") +(define OPPONENT-X-NAME "Opponent ~a") +(define OPPONENT-NAME "Opponent") +(define YOUR-TURN-MESSAGE "Your turn - discard a ~a or crazy 8, or else ~a") +(define PICK-A-SUIT "Pick a suit") +(define GAME-OVER-YOU-WIN "Game over - you win!") +(define GAME-OVER-STUCK "Game over - no one wins") +(define GAME-OVER "Game over - opponent wins") +(define NEW-GAME "New Game") - ;; Configuration - (define opponents-count (get-preference 'crazy8s:num-opponents (lambda () 1))) - (define init-hand-size (get-preference 'crazy8s:hand-size (lambda () 7))) - (define drag-mode? (get-preference 'crazy8s:drag-mode (lambda () #f))) - - (define (start-new-game opponents-count init-hand-size drag-mode?) - (define orig-eventspace (current-eventspace)) - ;; Procedure for a game to use to start a sibling game - (define (new-game oc ihs dm?) - (parameterize ([current-eventspace orig-eventspace]) - (queue-callback - (lambda () - (start-new-game oc ihs dm?))))) - ;; Start a new game as a child process: - (parameterize ([current-custodian (make-custodian)]) - (parameterize ([exit-handler (lambda (v) - (custodian-shutdown-all (current-custodian)))]) - (parameterize ([current-eventspace (make-eventspace)]) - (queue-callback - (lambda () - (invoke-unit configured-game@ (import configuration^)))))))) +;; Region layout constants +(define MARGIN 10) +(define SUBMARGIN 10) +(define LABEL-H 15) +(define BUTTON-HEIGHT 18) +(define PASS-W 40) +(define NEW-GAME-W 80) +(define SEL-WIDTH 32) +(define SEL-HEIGHT 32) - ;; Start the initial child game: - (start-new-game opponents-count init-hand-size drag-mode?))) - - ;; This unit is for a particular Crazy 8 instance: - (define configured-game@ - (unit - (import configuration^) - (export) +(provide game@) - ;; Randomize - (random-seed (modulo (current-milliseconds) 10000)) - - ;; ========== GUI ======================================== +(define-signature configuration^ + (opponents-count init-hand-size drag-mode? new-game)) - ;; Set up the table - (define t (make-table "Crazy 8s" 8 5.5)) +;; This unit drives multiple Crazy 8 instances: +(define game@ + (unit (import) (export) - ;; Add status line and buttons: - (define status-pane (send t create-status-pane)) - (new button% - (parent status-pane) - (label "Options...") - (callback (lambda (b e) (configure-dialog)))) - (send t add-help-button status-pane (list "games" "crazy8s") "Crazy 8s Help" #f) + ;; Configuration + (define opponents-count (get-preference 'crazy8s:num-opponents (lambda () 1))) + (define init-hand-size (get-preference 'crazy8s:hand-size (lambda () 7))) + (define drag-mode? (get-preference 'crazy8s:drag-mode (lambda () #f))) - ;; The "Options.." button opens a configuration dialog that - ;; starts a new game: - (define (configure-dialog) - (define d (new dialog% - [parent t] - [label "Crazy 8 Options"])) - (define kinds (new radio-box% - [label #f] - [choices '("1 opponent, 10 cards" - "1 opponent, 7 cards" - "2 opponents, 7 cards" - "3 opponents, 7 cards")] - [parent (new group-box-panel% - [parent d] - [label "Players and Cards"])] - [callback void])) - (define drag-mode-check - (new check-box% - [parent d] - [label "Drag cards instead of single-click"] - [callback void])) - (define button-panel (new horizontal-pane% - [parent d] - [alignment '(right center)])) - (new button% - [label "Close"] - [parent button-panel] - [callback (lambda (b e) - (send d show #f))]) - (new button% - [label "New Game"] - [parent button-panel] - [callback (lambda (b e) - (let-values ([(oc ihs) - (case (send kinds get-selection) - [(0) (values 1 10)] - [(1) (values 1 7)] - [(2) (values 2 7)] - [(3) (values 3 7)])] - [(dm?) (send drag-mode-check get-value)]) - (put-preferences - '(crazy8s:num-opponents crazy8s:hand-size crazy8s:drag-mode) - (list oc ihs dm?) - void) - (new-game oc ihs dm?) - (send d show #f)))] - [style '(border)]) - (send kinds set-selection - (case opponents-count - [(1) (if (= init-hand-size 7) 1 0)] - [(2) 2] - [(3) 3])) - (send drag-mode-check set-value drag-mode?) - (send d show #t)) + (define (start-new-game opponents-count init-hand-size drag-mode?) + (define orig-eventspace (current-eventspace)) + ;; Procedure for a game to use to start a sibling game + (define (new-game oc ihs dm?) + (parameterize ([current-eventspace orig-eventspace]) + (queue-callback + (lambda () + (start-new-game oc ihs dm?))))) + ;; Start a new game as a child process: + (parameterize* ([current-custodian (make-custodian)] + [exit-handler + (lambda (v) + (custodian-shutdown-all (current-custodian)))] + [current-eventspace (make-eventspace)]) + (queue-callback + (lambda () (invoke-unit configured-game@ (import configuration^)))))) - ;; Show the table - (send t show #t) + ;; Start the initial child game: + (start-new-game opponents-count init-hand-size drag-mode?))) - ;; ========== Cards setup ======================================== +;; This unit is for a particular Crazy 8 instance: +(define configured-game@ + (unit (import configuration^) (export) - ;; Set the default card actions: - (send t set-double-click-action #f) - (send t set-button-action 'left 'drag-raise/one) - (send t set-button-action 'right 'drag/above) - - ;; Get table width & height - (define w (send t table-width)) - (define h (send t table-height)) - - ;; Set up the cards - (define all-cards (shuffle-list (make-deck) 7)) - (define deck all-cards) - (define discards null) - (for-each - (lambda (card) - (send card user-can-flip #f)) - deck) + ;; Randomize + (random-seed (modulo (current-milliseconds) 10000)) - ;; We'll need an 8 of each suit for substitutions later - (define (find-8 suit) - (ormap (lambda (c) - (and (= 8 (send c get-value)) - (eq? suit (send c get-suit)) - (send c copy))) - deck)) - (define 8-hearts (find-8 'hearts)) - (define 8-spades (find-8 'spades)) - (define 8-clubs (find-8 'clubs)) - (define 8-diamonds (find-8 'diamonds)) - - ;; Function for dealing or drawing cards - (define (deal n) - (let loop ([n n][d deck]) - (if (zero? n) - (begin - (set! deck d) - null) - (cons (car d) (loop (sub1 n) (cdr d)))))) - - ;; Card width & height - (define cw (send (car deck) card-width)) - (define ch (send (car deck) card-height)) - - ;; Make regions for deck and descard - (define deck-region - (make-region (- (/ (- w cw) 2) (/ (+ cw MARGIN) 2)) - (/ (- h ch) 2) - cw ch - #f #f)) - (define discard-region - (make-region (+ (region-x deck-region) cw MARGIN) - (region-y deck-region) - cw ch - #f #f)) - (define discard-target-region - (make-region (- (region-x discard-region) (/ MARGIN 2)) - (- (region-y discard-region) (/ MARGIN 2)) - (+ cw MARGIN) (+ ch MARGIN) - "" #f)) - (when drag-mode? - (send t add-region discard-target-region)) + ;; ========== GUI ======================================== - ;; Put the cards on the table - (send t add-cards-to-region deck deck-region) - - ;; Make regions for choosing a suit - (define (make-suit-region x y label card) - (let ([bm (make-object bitmap% - (build-path (collection-path "games" "crazy8s") - "images" - (format "~a.png" label)) - 'unknown/mask)]) - (make-button-region x y - SEL-WIDTH SEL-HEIGHT - bm - ;; The callback for the region sends - ;; a clonable card to the game driver - (lambda () - (async-channel-put msg card))))) - (define hearts-region - (make-suit-region (+ (region-x discard-target-region) cw (* 2 MARGIN)) - (+ (region-y discard-target-region) - (/ (- ch (* 2 SEL-HEIGHT) (/ MARGIN 2)) 2)) - "heart" 8-hearts)) - (define spades-region - (make-suit-region (+ (region-x hearts-region) SEL-WIDTH (/ MARGIN 2)) - (region-y hearts-region) - "spade" 8-spades)) - (define clubs-region - (make-suit-region (region-x hearts-region) - (+ (region-y hearts-region) SEL-HEIGHT (/ MARGIN 2)) - "club" 8-clubs)) - (define diamonds-region - (make-suit-region (region-x spades-region) - (region-y clubs-region) - "diamond" 8-diamonds)) + ;; Set up the table + (define t (make-table "Crazy 8s" 8 5.5)) - ;; Make the "Pass" button: - (define pass-button - (make-button-region (+ (region-x deck-region) - (/ (- cw PASS-W) 2)) - (+ (region-y deck-region) - (/ (- ch BUTTON-HEIGHT) 2)) - PASS-W BUTTON-HEIGHT - "Pass" (lambda () - (async-channel-put msg 'pass)))) + ;; Add status line and buttons: + (define status-pane (send t create-status-pane)) + (new button% + [parent status-pane] + [label "Options..."] + [callback (lambda (b e) (configure-dialog))]) + (send t add-help-button status-pane + (list "games" "crazy8s") "Crazy 8s Help" #f) - ;; Player region size - (define pw (/ (- w (* opponents-count MARGIN)) opponents-count)) - (define ph (- (/ (- h ch) 2) (* 2 MARGIN))) - - ;; Define the players with their regions - (define (make-a-player x y w h lbl) - (let ([r (make-region x y w h lbl #f)]) - (send t add-region r) - (make-player - r - (make-region (+ x SUBMARGIN) (+ y SUBMARGIN LABEL-H) - (- w (* 2 SUBMARGIN)) - (- h (* 2 SUBMARGIN) LABEL-H) - #f #f) - null))) - (define players - (cons - ;; You - (make-a-player - (/ MARGIN 2) (- h ph (/ MARGIN 2)) - (- w MARGIN) ph - YOUR-NAME) - (build-list - opponents-count - (lambda (delta) - (make-a-player - (+ (* (+ pw MARGIN) delta) (/ MARGIN 2)) (/ MARGIN 2) - pw ph - (if (= opponents-count 1) - OPPONENT-NAME - (format OPPONENT-X-NAME (+ 1 delta)))))))) - (define you (car players)) - (define opponents (cdr players)) + ;; The "Options.." button opens a configuration dialog that + ;; starts a new game: + (define (configure-dialog) + (define d (new dialog% + [parent t] + [label "Crazy 8 Options"])) + (define kinds (new radio-box% + [label #f] + [choices '("1 opponent, 10 cards" + "1 opponent, 7 cards" + "2 opponents, 7 cards" + "3 opponents, 7 cards")] + [parent (new group-box-panel% + [parent d] + [label "Players and Cards"])] + [callback void])) + (define drag-mode-check + (new check-box% + [parent d] + [label "Drag cards instead of single-click"] + [callback void])) + (define button-panel (new horizontal-pane% + [parent d] + [alignment '(right center)])) + (new button% + [label "Close"] + [parent button-panel] + [callback (lambda (b e) (send d show #f))]) + (new button% + [label "New Game"] + [parent button-panel] + [callback (lambda (b e) + (let-values ([(oc ihs) + (case (send kinds get-selection) + [(0) (values 1 10)] + [(1) (values 1 7)] + [(2) (values 2 7)] + [(3) (values 3 7)])] + [(dm?) (send drag-mode-check get-value)]) + (put-preferences + '(crazy8s:num-opponents crazy8s:hand-size crazy8s:drag-mode) + (list oc ihs dm?) + void) + (new-game oc ihs dm?) + (send d show #f)))] + [style '(border)]) + (send kinds set-selection + (case opponents-count + [(1) (if (= init-hand-size 7) 1 0)] + [(2) 2] + [(3) 3])) + (send drag-mode-check set-value drag-mode?) + (send d show #t)) - ;; Add the "Clean" and "Sort" buttons: - (define (sort-hand! card<) - (let ([sorted (sort (player-hand you) card<)]) - (set-player-hand! you sorted) - (send t stack-cards sorted) - (send t move-cards-to-region sorted (player-hand-r you)))) - (define clean-button - (make-button-region (region-x (player-r you)) - (- (region-y (player-r you)) - (+ BUTTON-HEIGHT MARGIN)) - PASS-W BUTTON-HEIGHT - "Clean" (lambda () - (sort-hand! - (lambda (a b) - (let-values ([(ax ay) (send t card-location a)] - [(bx by) (send t card-location b)]) - (> ax bx))))))) - (send t add-region clean-button) - (define (remap v) - ;; So that black and red suits are interleaved - (case v [(2) 1][(1) 2][else v])) - (define (card< a b) - (cond - [(= 8 (send a get-value)) - (or (not (= 8 (send b get-value))) - (< (remap (send a get-suit-id)) - (remap (send b get-suit-id))))] - [(= 8 (send b get-value)) - #f] - [(= (send a get-suit-id) - (send b get-suit-id)) - (< (send a get-value) - (send b get-value))] - [else - (< (remap (send a get-suit-id)) - (remap (send b get-suit-id)))])) - (when drag-mode? - (send t add-region - (make-button-region (+ (region-x clean-button) PASS-W MARGIN) - (region-y clean-button) - PASS-W BUTTON-HEIGHT - "Sort" (lambda () (sort-hand! card<))))) - - ;; ========== Game engine ======================================== + ;; Show the table + (send t show #t) - ;; Callbacks communicate back to the main loop - (define msg (make-async-channel)) - - ;; Utility: Determine whether a list of cards corresponds to a - ;; valid discard; return one card or #f - (define (get-discard-card cs) - (and (= 1 (length cs)) - (let ([c (car cs)]) - (and (memq c (player-hand you)) - (or (= (send (car discards) get-value) - (send c get-value)) - (= (send (car discards) get-suit-id) - (send c get-suit-id)) - (= (send c get-value) 8)) - c)))) + ;; ========== Cards setup ======================================== - ;; Utility: detect a stuck game - (define (stuck-game?) - (and (null? deck) - (not (ormap (lambda (p) - (and (pair? (player-hand p)) - (ormap (lambda (c) - (get-discard-card (list c))) - (player-hand p)))) - players)))) - - ;; Auto-player strategy: Choose which valid card to discard - (define (pick-to-discard cards) - (let ([non-8s (filter (lambda (c) - (not (= 8 (send c get-value)))) - cards)]) - (if (null? non-8s) - (car cards) - (car non-8s)))) - - ;; Auto-player: take a turn - (define (play-opponent p) - (let ([suit-id (send (car discards) get-suit-id)] - [value (send (car discards) get-value)]) - ;; Which cards can we discard? - (let ([matches (filter (lambda (c) - (or (= suit-id (send c get-suit-id)) - (= value (send c get-value)) - (= 8 (send c get-value)))) - (player-hand p))]) - (if (null? matches) - ;; Can't discard, so draw or pass - (if (pair? deck) - ;; Draw - (begin - (send t card-to-front (car deck)) - (set-player-hand! p (append (deal 1) (player-hand p))) - (send t move-cards-to-region (player-hand p) (player-hand-r p)) - (play-opponent p)) - ;; Pass - (begin - (send t hilite-region (player-r p)) - (send t pause 0.25) - (send t unhilite-region (player-r p)) - #t)) - ;; Discard - (let ([c (pick-to-discard matches)]) - (set-player-hand! p (remq c (player-hand p))) - (send t flip-card c) - (send t card-to-front c) - (send t move-cards-to-region (list c) discard-region) - (send t move-cards-to-region (player-hand p) (player-hand-r p)) - (set! discards (cons c discards)) - ;; Did we just discard an 8? (And we still have cards?) - (when (and (= 8 (send (car discards) get-value)) - (pair? (player-hand p))) - ;; Pick a suit based on our hand - (let ([counts (map (lambda (v) - (cons v - (length (filter (lambda (c) - (and (= v (send c get-suit-id)) - (not (= 8 (send c get-value))))) - (player-hand p))))) - '(1 2 3 4))]) - (let ([suit-id - ;; Sort based on counts, then pick the first one: - (sub1 (caar (sort counts (lambda (a b) (> (cdr a) (cdr b))))))]) - ;; Find the clonable 8 for the chosen suit, and reset the discard - (reset-8 - (list-ref - (list 8-clubs 8-diamonds 8-hearts 8-spades) - suit-id))))) - ;; Return #f if this player has just won: - (pair? (player-hand p))))))) - - ;; Utility: disables cards for "you" - (define (allow-cards on?) - (when (pair? deck) - (send (car deck) user-can-move (and drag-mode? on?))) - (for-each (lambda (c) - (send c user-can-move (and drag-mode? on?))) - (player-hand you)) - (send t set-single-click-action (if (and on? (not drag-mode?)) - click-card - (if drag-mode? - void - (lambda (x) (bell))))) - (when (null? deck) - (if on? - (send t add-region pass-button) - (send t remove-region pass-button)))) - - ;; Utility: replaces the top discard, which is an 8, with an 8 - ;; of a particular suit (possibly the same). - (define (reset-8 got-8) - (unless (eq? (send (car discards) get-suit) - (send got-8 get-suit)) - (let ([c (send got-8 copy)]) - (send c user-can-move #f) - (send t flip-card (car discards)) - (send t add-cards-to-region (list c) discard-region) - (send t card-to-front c) - (send t remove-card (car discards)) - (set! discards (cons c (cdr discards))) - (send t flip-card c)))) - - ;; Sub-game: the user just discarded an 8, so pick a suit: - (define (pick-suit) - (allow-cards #f) - (send t add-region hearts-region) - (send t add-region spades-region) - (send t add-region clubs-region) - (send t add-region diamonds-region) - (send t set-status PICK-A-SUIT) - ;; Clicking one of these regions returns a clonable 8 card: - (let ([got-8 (yield msg)]) - (reset-8 got-8)) - (send t remove-region hearts-region) - (send t remove-region spades-region) - (send t remove-region clubs-region) - (send t remove-region diamonds-region) - (allow-cards #t)) + ;; Set the default card actions: + (send t set-double-click-action #f) + (send t set-button-action 'left 'drag-raise/one) + (send t set-button-action 'right 'drag/above) - ;; Install interactive callback for discard: accept the card - ;; (from the player's hand) and release it from its home: - (set-region-interactive-callback! - discard-target-region - (lambda (in? cs) - (let ([c (get-discard-card cs)]) - (when c - (send c home-region (if in? #f (player-r you))))))) + ;; Get table width & height + (define w (send t table-width)) + (define h (send t table-height)) - ;; Install final callback for discard: perform the discard - (set-region-callback! - discard-target-region - (lambda (cs) - (let ([c (get-discard-card cs)]) - (when c - (you-discard c))))) - - (define (you-discard c) - (send c home-region #f) - (set! discards (cons c discards)) - (set-player-hand! you (remq c (player-hand you))) - (send t card-to-front c) - (send t move-cards-to-region (list c) discard-region) - (send c user-can-move #f) - (async-channel-put msg 'discard)) + ;; Set up the cards + (define all-cards (shuffle-list (make-deck) 7)) + (define deck all-cards) + (define discards null) + (for-each (lambda (card) (send card user-can-flip #f)) deck) - ;; Install interactive callback for hand: accept the card - ;; (from the deck) and release it from its home: - (set-region-interactive-callback! - (player-r you) - (lambda (in? cs) - (send (car cs) home-region - (if in? (player-r you) deck-region)))) + ;; We'll need an 8 of each suit for substitutions later + (define (find-8 suit) + (ormap (lambda (c) + (and (= 8 (send c get-value)) + (eq? suit (send c get-suit)) + (send c copy))) + deck)) + (define 8-hearts (find-8 'hearts)) + (define 8-spades (find-8 'spades)) + (define 8-clubs (find-8 'clubs)) + (define 8-diamonds (find-8 'diamonds)) - ;; Install final callback for hand: draw the card: - (set-region-callback! - (player-r you) - (lambda (cs) - (let ([c (car cs)]) - (you-draw c)))) - - (define (you-draw c) - (send t flip-card c) - (send c home-region (player-r you)) - (set-player-hand! you (let loop ([l (player-hand you)]) - (cond - [(null? l) (list c)] - [(card< c (car l)) (cons c l)] - [else (cons (car l) (loop (cdr l)))]))) - (deal 1) - (unless drag-mode? - (send t stack-cards (player-hand you)) - (send t move-cards-to-region (player-hand you) (player-hand-r you))) - (async-channel-put msg 'draw)) - - (define (click-card c) - (cond - [(memq c deck) (you-draw c)] - [(memq c (player-hand you)) - (if (get-discard-card (list c)) - (you-discard c) - (bell))] - [else (bell)])) - + ;; Function for dealing or drawing cards + (define (deal n) + (let loop ([n n][d deck]) + (if (zero? n) + (begin (set! deck d) null) + (cons (car d) (loop (sub1 n) (cdr d)))))) + + ;; Card width & height + (define cw (send (car deck) card-width)) + (define ch (send (car deck) card-height)) + + ;; Make regions for deck and descard + (define deck-region + (make-region (- (/ (- w cw) 2) (/ (+ cw MARGIN) 2)) + (/ (- h ch) 2) + cw ch + #f #f)) + (define discard-region + (make-region (+ (region-x deck-region) cw MARGIN) + (region-y deck-region) + cw ch + #f #f)) + (define discard-target-region + (make-region (- (region-x discard-region) (/ MARGIN 2)) + (- (region-y discard-region) (/ MARGIN 2)) + (+ cw MARGIN) (+ ch MARGIN) + "" #f)) + (when drag-mode? + (send t add-region discard-target-region)) + + ;; Put the cards on the table + (send t add-cards-to-region deck deck-region) + + ;; Make regions for choosing a suit + (define (make-suit-region x y label card) + (let ([bm (make-object bitmap% + (build-path (collection-path "games" "crazy8s") + "images" + (format "~a.png" label)) + 'unknown/mask)]) + (make-button-region x y + SEL-WIDTH SEL-HEIGHT + bm + ;; The callback for the region sends + ;; a clonable card to the game driver + (lambda () (async-channel-put msg card))))) + (define hearts-region + (make-suit-region (+ (region-x discard-target-region) cw (* 2 MARGIN)) + (+ (region-y discard-target-region) + (/ (- ch (* 2 SEL-HEIGHT) (/ MARGIN 2)) 2)) + "heart" 8-hearts)) + (define spades-region + (make-suit-region (+ (region-x hearts-region) SEL-WIDTH (/ MARGIN 2)) + (region-y hearts-region) + "spade" 8-spades)) + (define clubs-region + (make-suit-region (region-x hearts-region) + (+ (region-y hearts-region) SEL-HEIGHT (/ MARGIN 2)) + "club" 8-clubs)) + (define diamonds-region + (make-suit-region (region-x spades-region) + (region-y clubs-region) + "diamond" 8-diamonds)) + + ;; Make the "Pass" button: + (define pass-button + (make-button-region (+ (region-x deck-region) + (/ (- cw PASS-W) 2)) + (+ (region-y deck-region) + (/ (- ch BUTTON-HEIGHT) 2)) + PASS-W BUTTON-HEIGHT + "Pass" (lambda () + (async-channel-put msg 'pass)))) + + ;; Player region size + (define pw (/ (- w (* opponents-count MARGIN)) opponents-count)) + (define ph (- (/ (- h ch) 2) (* 2 MARGIN))) + + ;; Define the players with their regions + (define (make-a-player x y w h lbl) + (let ([r (make-region x y w h lbl #f)]) + (send t add-region r) + (make-player + r + (make-region (+ x SUBMARGIN) (+ y SUBMARGIN LABEL-H) + (- w (* 2 SUBMARGIN)) + (- h (* 2 SUBMARGIN) LABEL-H) + #f #f) + null))) + (define players + (cons + ;; You + (make-a-player + (/ MARGIN 2) (- h ph (/ MARGIN 2)) + (- w MARGIN) ph + YOUR-NAME) + (build-list + opponents-count + (lambda (delta) + (make-a-player + (+ (* (+ pw MARGIN) delta) (/ MARGIN 2)) (/ MARGIN 2) + pw ph + (if (= opponents-count 1) + OPPONENT-NAME + (format OPPONENT-X-NAME (+ 1 delta)))))))) + (define you (car players)) + (define opponents (cdr players)) + + ;; Add the "Clean" and "Sort" buttons: + (define (sort-hand! card<) + (let ([sorted (sort (player-hand you) card<)]) + (set-player-hand! you sorted) + (send t stack-cards sorted) + (send t move-cards-to-region sorted (player-hand-r you)))) + (define clean-button + (make-button-region + (region-x (player-r you)) + (- (region-y (player-r you)) + (+ BUTTON-HEIGHT MARGIN)) + PASS-W BUTTON-HEIGHT + "Clean" (lambda () + (sort-hand! + (lambda (a b) + (let-values ([(ax ay) (send t card-location a)] + [(bx by) (send t card-location b)]) + (> ax bx))))))) + (send t add-region clean-button) + (define (remap v) + ;; So that black and red suits are interleaved + (case v [(2) 1][(1) 2][else v])) + (define (card< a b) + (cond + [(= 8 (send a get-value)) + (or (not (= 8 (send b get-value))) + (< (remap (send a get-suit-id)) (remap (send b get-suit-id))))] + [(= 8 (send b get-value)) + #f] + [(= (send a get-suit-id) (send b get-suit-id)) + (< (send a get-value) (send b get-value))] + [else + (< (remap (send a get-suit-id)) (remap (send b get-suit-id)))])) + (when drag-mode? + (send t add-region + (make-button-region (+ (region-x clean-button) PASS-W MARGIN) + (region-y clean-button) + PASS-W BUTTON-HEIGHT + "Sort" (lambda () (sort-hand! card<))))) + + ;; ========== Game engine ======================================== + + ;; Callbacks communicate back to the main loop + (define msg (make-async-channel)) + + ;; Utility: Determine whether a list of cards corresponds to a + ;; valid discard; return one card or #f + (define (get-discard-card cs) + (and (= 1 (length cs)) + (let ([c (car cs)]) + (and (memq c (player-hand you)) + (or (= (send (car discards) get-value) (send c get-value)) + (= (send (car discards) get-suit-id) (send c get-suit-id)) + (= (send c get-value) 8)) + c)))) + + ;; Utility: detect a stuck game + (define (stuck-game?) + (and (null? deck) + (not (ormap (lambda (p) + (and (pair? (player-hand p)) + (ormap (lambda (c) (get-discard-card (list c))) + (player-hand p)))) + players)))) + + ;; Auto-player strategy: Choose which valid card to discard + (define (pick-to-discard cards) + (let ([non-8s (filter (lambda (c) (not (= 8 (send c get-value)))) cards)]) + (car (if (null? non-8s) cards non-8s)))) + + ;; Auto-player: take a turn + (define (play-opponent p) + (let ([suit-id (send (car discards) get-suit-id)] + [value (send (car discards) get-value)]) + ;; Which cards can we discard? + (let ([matches (filter (lambda (c) + (or (= suit-id (send c get-suit-id)) + (= value (send c get-value)) + (= 8 (send c get-value)))) + (player-hand p))]) + (if (null? matches) + ;; Can't discard, so draw or pass + (if (pair? deck) + ;; Draw + (begin + (send t card-to-front (car deck)) + (set-player-hand! p (append (deal 1) (player-hand p))) + (send t move-cards-to-region (player-hand p) (player-hand-r p)) + (play-opponent p)) + ;; Pass + (begin + (send t hilite-region (player-r p)) + (send t pause 0.25) + (send t unhilite-region (player-r p)) + #t)) + ;; Discard + (let ([c (pick-to-discard matches)]) + (set-player-hand! p (remq c (player-hand p))) + (send t flip-card c) + (send t card-to-front c) + (send t move-cards-to-region (list c) discard-region) + (send t move-cards-to-region (player-hand p) (player-hand-r p)) + (set! discards (cons c discards)) + ;; Did we just discard an 8? (And we still have cards?) + (when (and (= 8 (send (car discards) get-value)) + (pair? (player-hand p))) + ;; Pick a suit based on our hand + (let ([counts + (map (lambda (v) + (cons v + (length + (filter + (lambda (c) + (and (= v (send c get-suit-id)) + (not (= 8 (send c get-value))))) + (player-hand p))))) + '(1 2 3 4))]) + (let ([suit-id + ;; Sort based on counts, then pick the first one: + (sub1 (caar (sort counts (lambda (a b) + (> (cdr a) (cdr b))))))]) + ;; Find the clonable 8 for the chosen suit, and + ;; reset the discard + (reset-8 + (list-ref + (list 8-clubs 8-diamonds 8-hearts 8-spades) + suit-id))))) + ;; Return #f if this player has just won: + (pair? (player-hand p))))))) + + ;; Utility: disables cards for "you" + (define (allow-cards on?) + (when (pair? deck) + (send (car deck) user-can-move (and drag-mode? on?))) + (for-each (lambda (c) (send c user-can-move (and drag-mode? on?))) + (player-hand you)) + (send t set-single-click-action + (cond [(and on? (not drag-mode?)) click-card] + [drag-mode? void] + [else (lambda (x) (bell))])) + (when (null? deck) + (if on? + (send t add-region pass-button) + (send t remove-region pass-button)))) + + ;; Utility: replaces the top discard, which is an 8, with an 8 + ;; of a particular suit (possibly the same). + (define (reset-8 got-8) + (unless (eq? (send (car discards) get-suit) (send got-8 get-suit)) + (let ([c (send got-8 copy)]) + (send c user-can-move #f) + (send t flip-card (car discards)) + (send t add-cards-to-region (list c) discard-region) + (send t card-to-front c) + (send t remove-card (car discards)) + (set! discards (cons c (cdr discards))) + (send t flip-card c)))) + + ;; Sub-game: the user just discarded an 8, so pick a suit: + (define (pick-suit) + (allow-cards #f) + (send t add-region hearts-region) + (send t add-region spades-region) + (send t add-region clubs-region) + (send t add-region diamonds-region) + (send t set-status PICK-A-SUIT) + ;; Clicking one of these regions returns a clonable 8 card: + (let ([got-8 (yield msg)]) (reset-8 got-8)) + (send t remove-region hearts-region) + (send t remove-region spades-region) + (send t remove-region clubs-region) + (send t remove-region diamonds-region) + (allow-cards #t)) + + ;; Install interactive callback for discard: accept the card + ;; (from the player's hand) and release it from its home: + (set-region-interactive-callback! + discard-target-region + (lambda (in? cs) + (let ([c (get-discard-card cs)]) + (when c + (send c home-region (if in? #f (player-r you))))))) + + ;; Install final callback for discard: perform the discard + (set-region-callback! + discard-target-region + (lambda (cs) + (let ([c (get-discard-card cs)]) + (when c (you-discard c))))) + + (define (you-discard c) + (send c home-region #f) + (set! discards (cons c discards)) + (set-player-hand! you (remq c (player-hand you))) + (send t card-to-front c) + (send t move-cards-to-region (list c) discard-region) + (send c user-can-move #f) + (async-channel-put msg 'discard)) + + ;; Install interactive callback for hand: accept the card + ;; (from the deck) and release it from its home: + (set-region-interactive-callback! + (player-r you) + (lambda (in? cs) + (send (car cs) home-region (if in? (player-r you) deck-region)))) + + ;; Install final callback for hand: draw the card: + (set-region-callback! + (player-r you) + (lambda (cs) (let ([c (car cs)]) (you-draw c)))) + + (define (you-draw c) + (send t flip-card c) + (send c home-region (player-r you)) + (set-player-hand! you (let loop ([l (player-hand you)]) + (cond [(null? l) (list c)] + [(card< c (car l)) (cons c l)] + [else (cons (car l) (loop (cdr l)))]))) + (deal 1) (unless drag-mode? - (send t set-single-click-action click-card)) + (send t stack-cards (player-hand you)) + (send t move-cards-to-region (player-hand you) (player-hand-r you))) + (async-channel-put msg 'draw)) - ;; Run a loop for multiple games - (let gloop () + (define (click-card c) + (cond [(memq c deck) (you-draw c)] + [(memq c (player-hand you)) + (if (get-discard-card (list c)) (you-discard c) (bell))] + [else (bell)])) - ;; Card setup: Deal the cards - (for-each (lambda (player) - (set-player-hand! player (sort (deal init-hand-size) card<)) - (send t stack-cards (player-hand player)) - (send t move-cards-to-region - (player-hand player) - (player-hand-r player))) - players) + (unless drag-mode? + (send t set-single-click-action click-card)) - ;; Opponents's cards and deck initally can't be moved - (for-each - (lambda (card) (send card user-can-move #f)) - (append - (apply append - (map player-hand (if drag-mode? opponents players))) - deck)) - ;; Your cards stay home: - (for-each (lambda (c) - (send c home-region (player-r you)) - (send c user-can-move drag-mode?)) - (player-hand you)) - - ;; Initial discard - ;; If it's an eight, then shuffle and try again - (let loop () - (when (= 8 (send (car deck) get-value)) - (set! deck (shuffle-list deck 1)) - (send t stack-cards deck) - (loop))) - (set! discards (deal 1)) - (send t flip-cards discards) - (send t move-cards-to-region discards discard-region) - - ;; Show your cards - (send t flip-cards (player-hand you)) - - ;; Run a single-game loop - (let loop () - ;; Ready deck and/or pass button: - (when (pair? deck) - (when drag-mode? - (send (car deck) user-can-move #t)) - (send (car deck) home-region deck-region)) - (when (null? deck) - (send t add-region pass-button)) - ;; Tell the player what to do: - (send t set-status (format YOUR-TURN-MESSAGE - (let ([v (send (car discards) get-value)] - [suit (case (send (car discards) get-suit) - [(hearts) "heart"] - [(spades) "spade"] - [(diamonds) "diamond"] - [(clubs) "club"])]) - (if (= v 8) - suit - (format "~a, ~a," - suit - (case v - [(1) "ace"] - [(11) "jack"] - [(12) "queen"] - [(13) "king"] - [else v])))) - (if (null? deck) "pass" "draw"))) - ;; What for something to happen: - (let ([what (yield msg)]) - ;; Discarded a crazy 8? (And not as our last card?) - (when (and (eq? what 'discard) - (= 8 (send (car discards) get-value)) - (pair? (player-hand you))) - ;; Yes, so pick suit before continuing - (pick-suit)) - ;; What did we do? - (case what - [(draw) - ;; Go again - (loop)] - [(discard pass) - ;; Hide pass button... - (when (null? deck) - (send t remove-region pass-button)) - ;; ... and run opponents - (send t set-status "Opponent's turn...") - (unless (null? (player-hand you)) - (let oloop ([l opponents]) - (cond - [(null? l) - ;; Check for a stuck game here: - (unless (stuck-game?) - (loop))] - [else (when (play-opponent (car l)) - (oloop (cdr l)))])))]))) - - ;; Game over: disable player: - (allow-cards #f) - - ;; Report result: - (send t set-status (cond - [(null? (player-hand you)) - GAME-OVER-YOU-WIN] - [(stuck-game?) - GAME-OVER-STUCK] - [else - GAME-OVER])) + ;; Run a loop for multiple games + (let gloop () - (let ([button - (make-button-region - (+ (region-x discard-region) cw (* 2 MARGIN)) - (+ (region-y discard-region) (/ (- ch LABEL-H) 2)) - NEW-GAME-W LABEL-H - NEW-GAME (lambda () - (async-channel-put msg 'new-game)))]) - (send t add-region button) - (yield msg) - (send t remove-region button)) + ;; Card setup: Deal the cards + (for-each (lambda (player) + (set-player-hand! player (sort (deal init-hand-size) card<)) + (send t stack-cards (player-hand player)) + (send t move-cards-to-region + (player-hand player) + (player-hand-r player))) + players) - (let ([all (send t all-cards)]) - ;; Gather up cards, with animation - (let ([flip (filter - (lambda (c) - (not (send c face-down?))) - all)]) - (send t flip-cards flip) - (send t move-cards-to-region all deck-region)) - ;; Reset all cards (no animation) - (send t begin-card-sequence) - (send t remove-cards all) - (send t add-cards-to-region all-cards deck-region) - (set! deck (shuffle-list all-cards 7)) - (for-each (lambda (c) - (unless (send c face-down?) - (send c flip))) - deck) - (send t stack-cards deck) - (send t end-card-sequence)) + ;; Opponents's cards and deck initally can't be moved + (for-each (lambda (card) (send card user-can-move #f)) + (append + (apply append + (map player-hand (if drag-mode? opponents players))) + deck)) + ;; Your cards stay home: + (for-each (lambda (c) + (send c home-region (player-r you)) + (send c user-can-move drag-mode?)) + (player-hand you)) - ;; Re-enable player: - (allow-cards #t) + ;; Initial discard + ;; If it's an eight, then shuffle and try again + (let loop () + (when (= 8 (send (car deck) get-value)) + (set! deck (shuffle-list deck 1)) + (send t stack-cards deck) + (loop))) + (set! discards (deal 1)) + (send t flip-cards discards) + (send t move-cards-to-region discards discard-region) - (gloop))))) + ;; Show your cards + (send t flip-cards (player-hand you)) + ;; Run a single-game loop + (let loop () + ;; Ready deck and/or pass button: + (when (pair? deck) + (when drag-mode? (send (car deck) user-can-move #t)) + (send (car deck) home-region deck-region)) + (when (null? deck) (send t add-region pass-button)) + ;; Tell the player what to do: + (send t set-status + (format YOUR-TURN-MESSAGE + (let ([v (send (car discards) get-value)] + [suit (case (send (car discards) get-suit) + [(hearts) "heart"] + [(spades) "spade"] + [(diamonds) "diamond"] + [(clubs) "club"])]) + (if (= v 8) + suit + (format "~a, ~a," + suit + (case v + [(1) "ace"] + [(11) "jack"] + [(12) "queen"] + [(13) "king"] + [else v])))) + (if (null? deck) "pass" "draw"))) + ;; What for something to happen: + (let ([what (yield msg)]) + ;; Discarded a crazy 8? (And not as our last card?) + (when (and (eq? what 'discard) + (= 8 (send (car discards) get-value)) + (pair? (player-hand you))) + ;; Yes, so pick suit before continuing + (pick-suit)) + ;; What did we do? + (case what + [(draw) + ;; Go again + (loop)] + [(discard pass) + ;; Hide pass button... + (when (null? deck) (send t remove-region pass-button)) + ;; ... and run opponents + (send t set-status "Opponent's turn...") + (unless (null? (player-hand you)) + (let oloop ([l opponents]) + (if (null? l) + ;; Check for a stuck game here: + (unless (stuck-game?) (loop)) + (when (play-opponent (car l)) (oloop (cdr l))))))]))) + + ;; Game over: disable player: + (allow-cards #f) + + ;; Report result: + (send t set-status (cond [(null? (player-hand you)) GAME-OVER-YOU-WIN] + [(stuck-game?) GAME-OVER-STUCK] + [else GAME-OVER])) + + (let ([button + (make-button-region + (+ (region-x discard-region) cw (* 2 MARGIN)) + (+ (region-y discard-region) (/ (- ch LABEL-H) 2)) + NEW-GAME-W LABEL-H + NEW-GAME (lambda () (async-channel-put msg 'new-game)))]) + (send t add-region button) + (yield msg) + (send t remove-region button)) + + (let ([all (send t all-cards)]) + ;; Gather up cards, with animation + (let ([flip (filter (lambda (c) (not (send c face-down?))) all)]) + (send t flip-cards flip) + (send t move-cards-to-region all deck-region)) + ;; Reset all cards (no animation) + (send t begin-card-sequence) + (send t remove-cards all) + (send t add-cards-to-region all-cards deck-region) + (set! deck (shuffle-list all-cards 7)) + (for-each (lambda (c) (unless (send c face-down?) (send c flip))) deck) + (send t stack-cards deck) + (send t end-card-sequence)) + + ;; Re-enable player: + (allow-cards #t) + + (gloop)))) diff --git a/collects/games/crazy8s/doc.txt b/collects/games/crazy8s/doc.txt index fbe63a91ad..87bae164ca 100644 --- a/collects/games/crazy8s/doc.txt +++ b/collects/games/crazy8s/doc.txt @@ -1,24 +1,24 @@ -** To play _Crazy 8s_, run the "Games" application. ** +** To play Crazy 8s, run the "PLT Games" application. Try to get rid of all you cards by matching the value or suit of the -top card in the discard pile. In the default mode, click a card to +top card in the discard pile. In the default mode, click a card to discard it; you can adjust the options so that you discard by dragging a card from your hand to the discard pile. An 8 can be discarded at any time, and in that case, the player who discarded the 8 gets to pick any suit for it (hence the craziness of -8s). When you discard an 8, a panel of buttons appears to the right of -the discard pile, so you can pick the suit. +8s). When you discard an 8, a panel of buttons appears to the right +of the discard pile, so you can pick the suit. A player can choose to draw a card instead of discarding, as long as -cards are left in the draw pile. A player's turn continues after +cards are left in the draw pile. A player's turn continues after drawing, so a player can continue drawing to find something to -discard. In the default mode, click the face-down draw pile in the +discard. In the default mode, click the face-down draw pile in the middle of the table; you can adjust the options to that you draw by dragging it from the draw pile to your hand. If no cards are left in the deck, a player may pass instead of -discarding. To pass, click the "Pass" button. +discarding. To pass, click the "Pass" button. The status line at the bottom of the window provides instructions as you go. diff --git a/collects/games/doors/doc.txt b/collects/games/doors/doc.txt index 2bef5c9be2..a5104bba43 100644 --- a/collects/games/doors/doc.txt +++ b/collects/games/doors/doc.txt @@ -1,4 +1,3 @@ - _doors.ss_ The "doors.ss" library builds on "gl-board.ss" to support simple diff --git a/collects/games/games.ss b/collects/games/games.ss index cee8a5c8f3..9cbdb7e1f1 100644 --- a/collects/games/games.ss +++ b/collects/games/games.ss @@ -1,114 +1,97 @@ -(module games mzscheme - (require (lib "mred.ss" "mred") - (lib "class.ss") - (lib "unit.ss") - (lib "list.ss") - (lib "getinfo.ss" "setup") - (lib "bitmap-label.ss" "mrlib") - "show-help.ss") +#lang scheme/gui - (define game-mapping - (let ([games (let ([d (collection-path "games")]) - (filter (lambda (f) - (let ([p (build-path d f)]) - (and (directory-exists? p) - (with-handlers ([exn:fail? (lambda (x) #f)]) - ((get-info (list (string->path "games") f)) 'game (lambda () #f)))))) - (directory-list d)))]) - (map (lambda (g) - (let ([info (get-info `(,(string->path "games") ,g))]) - (list (path->string g) - (info 'game (lambda () "wrong.ss")) - (info 'name (lambda () g)) - (info 'game-set (lambda () "Other Games")) - (info 'game-icon (lambda () (build-path (collection-path "games" g) - (format "~a.png" g))))))) - games))) - - (define f (new (class frame% - (augment* - [on-close (lambda () (exit))]) - (super-new)) - [label "PLT Games"] - [style '(metal no-resize-border)])) - (define hp (make-object horizontal-panel% f)) - (define main (make-object vertical-panel% hp)) - (send f set-alignment 'left 'top) - (send f stretchable-width #f) - (send f stretchable-height #f) +(require setup/getinfo mrlib/bitmap-label "show-help.ss") - (define main-horizontal-panel (make-object horizontal-panel% main)) +(define-struct game (file name set icon)) - (define (game-button p desc) - (let* ([collect (car desc)] - [file (cadr desc)] - [name (caddr desc)] - [dir (with-handlers ([void (lambda (x) #f)]) - (collection-path "games" collect))]) - (when dir - (make-object button% - ((bitmap-label-maker name (list-ref desc 4)) - p) - p - (lambda (b e) - (let ([game@ (dynamic-wind - begin-busy-cursor - (lambda () (dynamic-require (build-path dir file) 'game@)) - end-busy-cursor)]) - (let ([c (make-custodian)]) - (parameterize ([current-custodian c]) - (parameterize ([current-eventspace (make-eventspace)]) - (queue-callback - (lambda () - (exit-handler (lambda (v) - (custodian-shutdown-all c))) - (invoke-unit game@)))))))))))) - - (let ([game-mapping (sort game-mapping - (lambda (a b) - (string l1 l2) #t] - [(= l1 l2) (string-cistring game)] + [info (with-handlers ([exn:fail? (lambda (x) #f)]) + (get-info (list "games" game)))] + [main (and info (info 'game (lambda () #f)))] + [gamefile (lambda (f) (build-path gamedir game f))]) + (and main + (make-game + (gamefile main) + (info 'name (lambda () (string-titlecase game))) + (info 'game-set (lambda () "Other Games")) + (info 'game-icon (lambda () (gamefile (format "~a.png" game)))))))) - (define show-games-help - (show-help '("games") "About PLT Games")) +(define (run-game game) + (define c (make-custodian)) + (define run + (dynamic-wind + begin-busy-cursor + (lambda () + (with-handlers ([exn? (lambda (e) (lambda () (raise e)))]) + (let ([u (dynamic-require (game-file game) 'game@)]) + (lambda () (invoke-unit u))))) + end-busy-cursor)) + (parameterize* ([current-custodian c] + [current-namespace (make-gui-empty-namespace)] + [current-eventspace (make-eventspace)]) + (queue-callback + (lambda () + (exit-handler (lambda (v) (custodian-shutdown-all c))) + (with-handlers ([exn? (lambda (e) + (message-box (format "Error in \"~a\"" + (game-name game)) + (exn-message e) f '(ok)))]) + (run)))))) - (application-about-handler show-games-help) - (application-preferences-handler (lambda () - (message-box - "Oops" - "There aren't actually any preferences. This is just a test for Mac OS X" - f - '(ok)))) - - (send f show #t)) +(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 (stringdisplay-region r) - (define m MARGIN) - (make-region - (+ m (region-x r)) (+ m (region-y r)) - (- (region-w r) (* 2 m)) (- (region-h r) (* 2 m)) - #f #f)) - - ;; Place cards nicely - (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 you-hand (region->display-region you-region)) - - ;; All cards in your hand are movable, but must stay in your region - (for-each - (lambda (card) - (send card home-region you-region) - (send card user-can-move #t)) - you-hand) - - ;; More card setup: Show your cards - (send t cards-face-up you-hand) - - ;; Start the discard pile - (define discards (deal 1)) - (send t card-face-up (car discards)) - (send t move-card (car discards) discard-x discard-y) - - ;; ;;;;;;;;;;;;; Finding Rummy and The Machine Player Strategy ;;;;;;;; - - ;; Check whether a group of (at least 3) cards forms a set (building - ;; up to gin). - (define (set? cards) - (let ([values (map (lambda (c) (send c get-value)) cards)] - [suits (map (lambda (c) (send c get-suit-id)) cards)]) - ;; All same value? ... or - (or (apply = values) - ;; ... All same suit and a straight? - (and (apply = suits) - (let ([sorted (sort values <)] - [try (lambda (l) - (let loop ([l l]) - (or (null? (cdr l)) - (and (= (car l) (sub1 (cadr l))) - (loop (cdr l))))))]) - ;; Try with Ace at end and at beginning - (or (try sorted) - (and (= 1 (car sorted)) - (try (append (cdr sorted) (list 14)))))))))) - - ;; Check how close a hand comes to winning by returning the maximum - ;; number of cards that can be arranged into sets. This function is - ;; used both to detect gin for the end-of-game condition, and also - ;; as part of the machine player's strategy. - (define (gin-size cards) - (if (<= (length cards) 2) - 0 - (let* ([sort (lambda (get) - (sort cards (lambda (a b) (< (get a) (get b)))))] - - ;; It's not reasonable to test every combination of 10 cards, - ;; but we can cut down the search space a lot by starting - ;; with two different sorts on the card list. - - ;; We sort by value, to find 3-of-a-kind sets, and by - ;; suit-then-value, to find straights. Whatever the - ;; best allocation of cards to sets, one of the sets - ;; must show up as three cards together in one of the - ;; sorted lists. Also, if an extension to that set - ;; leads to an optimal allocation, the extended set - ;; corresponds to an extended section of the list. - [value-sorted (sort (lambda (c) (send c get-value)))] - [suit-sorted (sort (lambda (c) (+ (* 20 (send c get-suit-id)) (send c get-value))))] - - ;; Procedure to find a set allocation given one of the sorted - ;; lists. It picks each group of three consecutive items - ;; from the list and see how that choice works out. - ;; (We're still performing a lot of redundant work here, - ;; but it's fast enough.) - [find-set - (lambda (l) - ;; 3loop tries each group of three items - (let 3loop ([pre null] ; prefix we've tried already - [group (list (car l) (cadr l) (caddr l))] ; the group to try - [post (cdddr l)]) ; suffix we haven't tried yet - (max (if (set? group) - ;; We have a start; try to extend or not, and - ;; make gin with the rest, then try the next 3-set - (max (let exloop ([set group][post post]) - (cond - [(null? post) - ;; No more items? Can't extend the set. Does the - ;; set we found work out in the long run? - (+ (length set) - (if (null? pre) - 0 - (gin-size pre)))] - ;; Try to extend the set... - [(set? (cons (car post) set)) - ;; The set can be extended. - ;; Maybe this extension works in the long run... - (max (exloop (cons (car post) set) (cdr post)) - ;; or maybe without extension works in the long run... - (+ (length set) (gin-size (append pre post))))] - ;; Can't extend the set, so try without extension - [else (+ (length set) - (gin-size (append pre post)))]))) - 0) - ;; Try next three, if possible - (if (null? post) - 0 - ;; Rotate the group, pulling a new last item in from post - ;; and kicking the first item out to pre. - (3loop (cons (car group) pre) - (list (cadr group) (caddr group) (car post)) - (cdr post))))))]) - ;; Try the value-sorted list, the the suit-sorted list, then... - (max (find-set value-sorted) - (find-set suit-sorted) - ;; the suit-sorted list with with Aces at the end instead of the beginning - (let ace-loop ([pre null][l suit-sorted]) - (cond - [(null? l) - ;; No more aces to find - (find-set (reverse pre))] - [(null? (cdr l)) - ;; No more aces to find - (find-set (reverse (cons (car l) pre)))] - ;; Is the front card an ace (before something else of the same suit)? - [(and (= 1 (send (car l) get-value)) - (= (send (car l) get-suit-id) (send (cadr l) get-suit-id))) - ;; Ace is at beginning; move it to the end - (let* ([ace (car l)] - [ace-suit (send ace get-suit-id)]) - (let loop ([pre (cons (cadr l) pre)][l (cddr l)]) - ;; At end of this suit? - (if (or (null? l) - (> (send (car l) get-suit-id) ace-suit)) - ;; At the end; add Ace here - (ace-loop (cons ace pre) l) - ;; still looking for new spot for Ace - (loop (cons (car l) pre) (cdr l)))))] - [else - ;; Didn't find an ace; keep looking - (ace-loop (cons (car l) pre) (cdr l))])))))) - - ;; A hand wins if the biggest gin configuration includes all the cards - (define (gin? cards) - (= (gin-size cards) (length cards))) - - ;; This procedure is the second part of the machine's strategy. If - ;; the machine sees two choices that are equally good according to - ;; gin-size, then it computes a rating based on pairs, i.e., cards - ;; that might eventually go together in a set. - (define (pair-rating cards gone-cards) - (let ([suits (map (lambda (card) (send card get-suit-id)) cards)] - [values (map (lambda (card) (send card get-value)) cards)]) - ;; Its O(n*n), but n is always 10 or 11 - (apply + - (map (lambda (suit value) - (apply + - (map (lambda (suit2 value2) - (cond - [(= value value2) - (- 2 (count-gone value gone-cards))] - [(= suit suit2) - (rate-straight suit value value2 gone-cards)] - [else 0])) - suits values))) - suits values)))) +(define (region->display-region r) + (define m MARGIN) + (make-region (+ m (region-x r)) (+ m (region-y r)) + (- (region-w r) (* 2 m)) (- (region-h r) (* 2 m)) + #f #f)) - ;; count-gone checks how many of a given value are known - ;; to be permanently discarded - (define (count-gone value gone-cards) - (cond - [(null? gone-cards) 0] - [(= value (send (car gone-cards) get-value)) - (+ 1 (count-gone value (cdr gone-cards)))] - [else (count-gone value (cdr gone-cards))])) +;; Place cards nicely +(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 you-hand (region->display-region you-region)) - ;; count-avail checks whether a given value/suit is - ;; known to be discarded (returns 0) or not (returns 1) - (define (count-avail value suit gone-cards) - (cond - [(null? gone-cards) 1] - [(and (= value (send (car gone-cards) get-value)) - (= suit (send (car gone-cards) get-suit-id))) - 0] - [else (count-avail value suit (cdr gone-cards))])) +;; All cards in your hand are movable, but must stay in your region +(for-each (lambda (card) + (send card home-region you-region) + (send card user-can-move #t)) + you-hand) - ;; rates the possibility for forming a straight given - ;; two card values in a particular suit, and taking - ;; into account cards known to be discarded; the - ;; rating is the number of non-discarded cards that - ;; would form a straight with the given values - (define (rate-straight suit value value2 gone-cards) - (let ([v1 (if (= value 1) - (if (value2 . > . 6) - 14 - 1) - value)] - [v2 (if (= value2 1) - (if (value . > . 6) - 14 - 1) - value2)]) - (let ([delta (abs (- v1 v2))]) - (cond - [(= delta 1) - (cond - [(or (= v1 1) (= v2 1)) - ;; Might get the 3? - (count-avail 3 suit gone-cards)] - [(or (= v1 14) (= v2 14)) - ;; Might get the queen? - (count-avail 12 suit gone-cards)] - [(or (= v1 13) (= v2 13)) - ;; Might get the jack or ace? - (+ (count-avail 11 suit gone-cards) - (count-avail 1 suit gone-cards))] - [else - ;; Might get top or bottom? - (+ (count-avail (sub1 (min v1 v2)) suit gone-cards) - (count-avail (add1 (max v1 v2)) suit gone-cards))])] - [(= delta 2) - ;; Might get the middle one? - (let ([middle (quotient (+ v1 v2) 2)]) - (count-avail middle suit gone-cards))] - [else 0])))) - - ;; The procedure implements the machine's card-drawing choice - (define (machine-wants-card? machine-hand card gone-cards) - ;; Simple strategy: the machine wants the card if taking it will - ;; make the gin-size of its hand increase, or if taking it will not - ;; make the gin-size decrease but will increase the pair rating. - (let* ([orig-size (gin-size machine-hand)] - [new-hand (remq (machine-discard (cons card machine-hand) gone-cards) - (cons card machine-hand))] - [new-size (gin-size new-hand)]) - (or (> new-size orig-size) - (and (= new-size orig-size) - (> (pair-rating new-hand gone-cards) - (pair-rating machine-hand gone-cards)))))) - - ;; The procedure implements the machine's discard choice - (define (machine-discard machine-hand gone-cards) - ;; Discard the card that leaves the hand with the largest - ;; gin-size. If multiple cards leave the same largest gin size, - ;; pick card leaving the best pair rating. - (let* ([gin-size-card-pairs - (map (lambda (card) (cons (gin-size (remq card machine-hand)) - card)) - machine-hand)] - [most (apply max (map car gin-size-card-pairs))] - [best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)] - [best-cards (map cdr best)] - [rating-card-pairs - (map (lambda (card) (cons (pair-rating (remq card machine-hand) gone-cards) - card)) - best-cards)] - [most (apply max (map car rating-card-pairs))] - [best (filter (lambda (x) (= most (car x))) rating-card-pairs)]) - (cdar best))) - - ;; ;;;;;; Game Loop ;;;;;;;; - - ;; This procedure finalizes the display when the game is over - (define (end-of-game why) - (send t set-status-text - (format "~aGame over. ~a." - why - (cond - [(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal - [(gin? you-hand) "You win"] - [else "Opponent wins"]))) - (send t cards-face-up machine-hand)) - - ;; Deck empty? Shuffle the discard pile (preserving the top discard) - (define (check-empty-deck) - (when (null? deck) - (set! deck (shuffle-list (cdr discards) 7)) - (set! discards (list (car discards))) - (send t cards-face-down deck) - (send t stack-cards deck) - (send t move-cards deck draw-x draw-y))) - - ;; Check for starge start... - (if (or (gin? you-hand) (gin? machine-hand)) - ;; Someone was delt gin - game over - (end-of-game "Dealt gin. ") - - ;; This is the main game loop - (let loop () - (check-empty-deck) - - ;; Your turn; you can select the top card on the deck or on the discard pile - (send (car discards) user-can-move #t) - (send (car discards) snap-back-after-move #t) - (send (car deck) user-can-move #t) - (send (car deck) snap-back-after-move #t) - (send t set-status-text YOUR-TURN-MESSAGE) - (let ([something-happened (make-semaphore 0)]) - ;; Set callback in your region to receive the deck/discard card - (set-region-callback! - you-region - (lambda (cards) - (let ([card (car cards)]) - ;; Adjust the deck, discard pile, and your hand - (if (eq? card (car discards)) - (set! discards (cdr discards)) - (set! deck (cdr deck))) - (set! you-hand (cons card you-hand)) - (send t card-face-up card)) - - ;; Action done - clean up and move on - (semaphore-post something-happened) - (unless (null? deck) - (send (car deck) user-can-move #f) - (send (car deck) home-region #f)) - (unless (null? discards) - (send (car discards) user-can-move #f) - (send (car discards) home-region #f)) - (set-region-callback! you-region #f) - (set-region-interactive-callback! you-region #f))) - ;; Interactive callback: change home of card if region is hilited. - ;; As a result, the card snaps to where you put it instead of back - ;; to its original position. - (set-region-interactive-callback! - you-region - (lambda (on? cards) - (send (car cards) snap-back-after-move (not on?)) - (send (car cards) home-region (and on? you-region)))) - ;; Wait for action (the action itself is handled by the callback - ;; for you-region) - (yield something-happened)) - - ;; Time for you to discard something - (send t set-status-text DISCARD-MESSAGE) - (let ([something-happened (make-semaphore 0)]) - ;; This time, the discard pile is the active region - (set-region-callback! - discard-region - (lambda (cards) - (let ([card (car cards)]) - ;; Adjust the discard pile and your hand - (set! you-hand (remq card you-hand)) - (set! discards (cons card discards)) - (send t card-to-front card) - (send t move-card card discard-x discard-y) - - ;; Discarded card is now relatively immobile - (send card user-can-move #t) - (send card home-region #f)) - - ;; Action done - clean up and move on - (semaphore-post something-happened) - (set-region-callback! discard-region #f) - (set-region-interactive-callback! discard-region #f))) - ;; Interactive callback: change home of card if region is hilited, - ;; so the card you drag snaps to the discard pile. - (set-region-interactive-callback! - discard-region - (lambda (on? cards) - (send (car cards) home-region - (if on? discard-region you-region)))) - ;; Wait for action - (yield something-happened)) - - (if (gin? you-hand) - ;; Game over - (end-of-game "") - - ;; Keep going; machine's turn - (begin - (check-empty-deck) - ;; Machine picks a card - (if (machine-wants-card? machine-hand (car discards) (cdr discards)) - (let ([card (car discards)]) - (set! discards (cdr discards)) - (send t card-face-down card) - (send card user-can-move #f) - (set! machine-hand (cons card machine-hand))) - (let ([card (car deck)]) - (send t card-to-front card) - (set! deck (cdr deck)) - (send card user-can-move #f) - (set! machine-hand (cons card machine-hand)))) - (send t move-cards-to-region machine-hand machine-display-region) - - ;; Machine discards - (let ([card (machine-discard machine-hand discards)]) - (send t card-face-up card) - (send t card-to-front card) - (send t move-card card discard-x discard-y) - (set! discards (cons card discards)) - (set! machine-hand (remq card machine-hand)) - (send t move-cards-to-region machine-hand machine-display-region)) - - (if (gin? machine-hand) - ;; Game over - (end-of-game "") - - ;; Next turn - (loop))))))))) - +;; More card setup: Show your cards +(send t cards-face-up you-hand) + +;; Start the discard pile +(define discards (deal 1)) +(send t card-face-up (car discards)) +(send t move-card (car discards) discard-x discard-y) + +;; ;;;;;;;;;;;;; Finding Rummy and The Machine Player Strategy ;;;;;;;; + +;; Check whether a group of (at least 3) cards forms a set (building +;; up to gin). +(define (set? cards) + (let ([values (map (lambda (c) (send c get-value)) cards)] + [suits (map (lambda (c) (send c get-suit-id)) cards)]) + ;; All same value? ... or + (or (apply = values) + ;; ... All same suit and a straight? + (and (apply = suits) + (let ([sorted (sort values <)] + [try (lambda (l) + (let loop ([l l]) + (or (null? (cdr l)) + (and (= (car l) (sub1 (cadr l))) + (loop (cdr l))))))]) + ;; Try with Ace at end and at beginning + (or (try sorted) + (and (= 1 (car sorted)) + (try (append (cdr sorted) (list 14)))))))))) + +;; Check how close a hand comes to winning by returning the maximum number of +;; cards that can be arranged into sets. This function is used both to detect +;; gin for the end-of-game condition, and also as part of the machine player's +;; strategy. +(define (gin-size cards) + (if (<= (length cards) 2) + 0 + (let* ([sort (lambda (get) + (sort cards (lambda (a b) (< (get a) (get b)))))] + + ;; It's not reasonable to test every combination of 10 cards, but we + ;; can cut down the search space a lot by starting with two + ;; different sorts on the card list. + + ;; We sort by value, to find 3-of-a-kind sets, and by + ;; suit-then-value, to find straights. Whatever the best allocation + ;; of cards to sets, one of the sets must show up as three cards + ;; together in one of the sorted lists. Also, if an extension to + ;; that set leads to an optimal allocation, the extended set + ;; corresponds to an extended section of the list. + [value-sorted (sort (lambda (c) (send c get-value)))] + [suit-sorted (sort (lambda (c) (+ (* 20 (send c get-suit-id)) (send c get-value))))] + + ;; Procedure to find a set allocation given one of the sorted + ;; lists. It picks each group of three consecutive items from the + ;; list and see how that choice works out. (We're still performing + ;; a lot of redundant work here, but it's fast enough.) + [find-set + (lambda (l) + ;; 3loop tries each group of three items + (let 3loop ([pre null] ; prefix we've tried already + [group (list (car l) (cadr l) (caddr l))] ; the group to try + [post (cdddr l)]) ; suffix we haven't tried yet + (max (if (set? group) + ;; We have a start; try to extend or not, and + ;; make gin with the rest, then try the next 3-set + (max (let exloop ([set group][post post]) + (cond + [(null? post) + ;; No more items? Can't extend the set. Does the + ;; set we found work out in the long run? + (+ (length set) + (if (null? pre) 0 (gin-size pre)))] + ;; Try to extend the set... + [(set? (cons (car post) set)) + ;; The set can be extended. Maybe this + ;; extension works in the long run... + (max (exloop (cons (car post) set) (cdr post)) + ;; or maybe without extension works in + ;; the long run... + (+ (length set) (gin-size (append pre post))))] + ;; Can't extend the set, so try without + ;; extension + [else (+ (length set) + (gin-size (append pre post)))]))) + 0) + ;; Try next three, if possible + (if (null? post) + 0 + ;; Rotate the group, pulling a new last item in from + ;; post and kicking the first item out to pre. + (3loop (cons (car group) pre) + (list (cadr group) (caddr group) (car post)) + (cdr post))))))]) + ;; Try the value-sorted list, the the suit-sorted list, then... + (max (find-set value-sorted) + (find-set suit-sorted) + ;; the suit-sorted list with with Aces at the end instead of the + ;; beginning + (let ace-loop ([pre null][l suit-sorted]) + (cond + [(null? l) + ;; No more aces to find + (find-set (reverse pre))] + [(null? (cdr l)) + ;; No more aces to find + (find-set (reverse (cons (car l) pre)))] + ;; Is the front card an ace (before something else of the same + ;; suit)? + [(and (= 1 (send (car l) get-value)) + (= (send (car l) get-suit-id) (send (cadr l) get-suit-id))) + ;; Ace is at beginning; move it to the end + (let* ([ace (car l)] + [ace-suit (send ace get-suit-id)]) + (let loop ([pre (cons (cadr l) pre)][l (cddr l)]) + ;; At end of this suit? + (if (or (null? l) (> (send (car l) get-suit-id) ace-suit)) + ;; At the end; add Ace here + (ace-loop (cons ace pre) l) + ;; still looking for new spot for Ace + (loop (cons (car l) pre) (cdr l)))))] + [else + ;; Didn't find an ace; keep looking + (ace-loop (cons (car l) pre) (cdr l))])))))) + +;; A hand wins if the biggest gin configuration includes all the cards +(define (gin? cards) + (= (gin-size cards) (length cards))) + +;; This procedure is the second part of the machine's strategy. If the machine +;; sees two choices that are equally good according to gin-size, then it +;; computes a rating based on pairs, i.e., cards that might eventually go +;; together in a set. +(define (pair-rating cards gone-cards) + (let ([suits (map (lambda (card) (send card get-suit-id)) cards)] + [values (map (lambda (card) (send card get-value)) cards)]) + ;; Its O(n*n), but n is always 10 or 11 + (apply + + (map (lambda (suit value) + (apply + + (map (lambda (suit2 value2) + (cond [(= value value2) + (- 2 (count-gone value gone-cards))] + [(= suit suit2) + (rate-straight suit value value2 gone-cards)] + [else 0])) + suits values))) + suits values)))) + +;; count-gone checks how many of a given value are known to be permanently +;; discarded +(define (count-gone value gone-cards) + (cond [(null? gone-cards) 0] + [(= value (send (car gone-cards) get-value)) + (+ 1 (count-gone value (cdr gone-cards)))] + [else (count-gone value (cdr gone-cards))])) + +;; count-avail checks whether a given value/suit is +;; known to be discarded (returns 0) or not (returns 1) +(define (count-avail value suit gone-cards) + (cond [(null? gone-cards) 1] + [(and (= value (send (car gone-cards) get-value)) + (= suit (send (car gone-cards) get-suit-id))) + 0] + [else (count-avail value suit (cdr gone-cards))])) + +;; rates the possibility for forming a straight given two card values in a +;; particular suit, and taking into account cards known to be discarded; the +;; rating is the number of non-discarded cards that would form a straight with +;; the given values +(define (rate-straight suit value value2 gone-cards) + (let ([v1 (if (= value 1) + (if (value2 . > . 6) 14 1) + value)] + [v2 (if (= value2 1) + (if (value . > . 6) 14 1) + value2)]) + (let ([delta (abs (- v1 v2))]) + (cond [(= delta 1) + (cond [(or (= v1 1) (= v2 1)) + ;; Might get the 3? + (count-avail 3 suit gone-cards)] + [(or (= v1 14) (= v2 14)) + ;; Might get the queen? + (count-avail 12 suit gone-cards)] + [(or (= v1 13) (= v2 13)) + ;; Might get the jack or ace? + (+ (count-avail 11 suit gone-cards) + (count-avail 1 suit gone-cards))] + [else + ;; Might get top or bottom? + (+ (count-avail (sub1 (min v1 v2)) suit gone-cards) + (count-avail (add1 (max v1 v2)) suit gone-cards))])] + [(= delta 2) + ;; Might get the middle one? + (let ([middle (quotient (+ v1 v2) 2)]) + (count-avail middle suit gone-cards))] + [else 0])))) + +;; The procedure implements the machine's card-drawing choice +(define (machine-wants-card? machine-hand card gone-cards) + ;; Simple strategy: the machine wants the card if taking it will make the + ;; gin-size of its hand increase, or if taking it will not make the gin-size + ;; decrease but will increase the pair rating. + (let* ([orig-size (gin-size machine-hand)] + [new-hand (remq (machine-discard (cons card machine-hand) gone-cards) + (cons card machine-hand))] + [new-size (gin-size new-hand)]) + (or (> new-size orig-size) + (and (= new-size orig-size) + (> (pair-rating new-hand gone-cards) + (pair-rating machine-hand gone-cards)))))) + +;; The procedure implements the machine's discard choice +(define (machine-discard machine-hand gone-cards) + ;; Discard the card that leaves the hand with the largest gin-size. If + ;; multiple cards leave the same largest gin size, pick card leaving the best + ;; pair rating. + (let* ([gin-size-card-pairs + (map (lambda (card) (cons (gin-size (remq card machine-hand)) card)) + machine-hand)] + [most (apply max (map car gin-size-card-pairs))] + [best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)] + [best-cards (map cdr best)] + [rating-card-pairs + (map (lambda (card) + (cons (pair-rating (remq card machine-hand) gone-cards) card)) + best-cards)] + [most (apply max (map car rating-card-pairs))] + [best (filter (lambda (x) (= most (car x))) rating-card-pairs)]) + (cdar best))) + +;; ;;;;;; Game Loop ;;;;;;;; + +;; This procedure finalizes the display when the game is over +(define (end-of-game why) + (send t set-status-text + (format + "~aGame over. ~a." + why + (cond [(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal + [(gin? you-hand) "You win"] + [else "Opponent wins"]))) + (send t cards-face-up machine-hand)) + +;; Deck empty? Shuffle the discard pile (preserving the top discard) +(define (check-empty-deck) + (when (null? deck) + (set! deck (shuffle-list (cdr discards) 7)) + (set! discards (list (car discards))) + (send t cards-face-down deck) + (send t stack-cards deck) + (send t move-cards deck draw-x draw-y))) + +;; Check for starge start... +(if (or (gin? you-hand) (gin? machine-hand)) + ;; Someone was delt gin - game over + (end-of-game "Dealt gin. ") + + ;; This is the main game loop + (let loop () + (check-empty-deck) + + ;; Your turn; you can select the top card on the deck or on the discard + ;; pile + (send (car discards) user-can-move #t) + (send (car discards) snap-back-after-move #t) + (send (car deck) user-can-move #t) + (send (car deck) snap-back-after-move #t) + (send t set-status-text YOUR-TURN-MESSAGE) + (let ([something-happened (make-semaphore 0)]) + ;; Set callback in your region to receive the deck/discard card + (set-region-callback! + you-region + (lambda (cards) + (let ([card (car cards)]) + ;; Adjust the deck, discard pile, and your hand + (if (eq? card (car discards)) + (set! discards (cdr discards)) + (set! deck (cdr deck))) + (set! you-hand (cons card you-hand)) + (send t card-face-up card)) + + ;; Action done - clean up and move on + (semaphore-post something-happened) + (unless (null? deck) + (send (car deck) user-can-move #f) + (send (car deck) home-region #f)) + (unless (null? discards) + (send (car discards) user-can-move #f) + (send (car discards) home-region #f)) + (set-region-callback! you-region #f) + (set-region-interactive-callback! you-region #f))) + ;; Interactive callback: change home of card if region is hilited. As a + ;; result, the card snaps to where you put it instead of back to its + ;; original position. + (set-region-interactive-callback! + you-region + (lambda (on? cards) + (send (car cards) snap-back-after-move (not on?)) + (send (car cards) home-region (and on? you-region)))) + ;; Wait for action (the action itself is handled by the callback + ;; for you-region) + (yield something-happened)) + + ;; Time for you to discard something + (send t set-status-text DISCARD-MESSAGE) + (let ([something-happened (make-semaphore 0)]) + ;; This time, the discard pile is the active region + (set-region-callback! + discard-region + (lambda (cards) + (let ([card (car cards)]) + ;; Adjust the discard pile and your hand + (set! you-hand (remq card you-hand)) + (set! discards (cons card discards)) + (send t card-to-front card) + (send t move-card card discard-x discard-y) + + ;; Discarded card is now relatively immobile + (send card user-can-move #t) + (send card home-region #f)) + + ;; Action done - clean up and move on + (semaphore-post something-happened) + (set-region-callback! discard-region #f) + (set-region-interactive-callback! discard-region #f))) + ;; Interactive callback: change home of card if region is hilited, + ;; so the card you drag snaps to the discard pile. + (set-region-interactive-callback! + discard-region + (lambda (on? cards) + (send (car cards) home-region (if on? discard-region you-region)))) + ;; Wait for action + (yield something-happened)) + + (if (gin? you-hand) + ;; Game over + (end-of-game "") + + ;; Keep going; machine's turn + (begin + (check-empty-deck) + ;; Machine picks a card + (if (machine-wants-card? machine-hand (car discards) (cdr discards)) + (let ([card (car discards)]) + (set! discards (cdr discards)) + (send t card-face-down card) + (send card user-can-move #f) + (set! machine-hand (cons card machine-hand))) + (let ([card (car deck)]) + (send t card-to-front card) + (set! deck (cdr deck)) + (send card user-can-move #f) + (set! machine-hand (cons card machine-hand)))) + (send t move-cards-to-region machine-hand machine-display-region) + + ;; Machine discards + (let ([card (machine-discard machine-hand discards)]) + (send t card-face-up card) + (send t card-to-front card) + (send t move-card card discard-x discard-y) + (set! discards (cons card discards)) + (set! machine-hand (remq card machine-hand)) + (send t move-cards-to-region machine-hand machine-display-region)) + + (if (gin? machine-hand) + ;; Game over + (end-of-game "") + + ;; Next turn + (loop)))))) + +)) diff --git a/collects/games/gobblet/doc.txt b/collects/games/gobblet/doc.txt index 0eb40be1d7..9ad911f932 100644 --- a/collects/games/gobblet/doc.txt +++ b/collects/games/gobblet/doc.txt @@ -1,4 +1,4 @@ -** To play _Goblet_, run the "Games" application. ** +** To play Goblet, run the "PLT Games" application. "Gobblet!" is a board game from Blue Orange Games: http://www.blueorangegames.com/ @@ -16,7 +16,7 @@ Game Rules The 3x3 game is a generalization of tic-tac-toe: * The object of the game is to get three in a row of your color, - vertically, horizontally, or diagonally. Size doesn't matter for + vertically, horizontally, or diagonally. Size doesn't matter for determining a winner. * Each player (red or yellow) starts with 6 pieces: two large, two @@ -28,14 +28,14 @@ The 3x3 game is a generalization of tic-tac-toe: * A piece can be placed (or moved to) an empty space, or it can be placed/moved on top of a smaller piece already on the board, - "gobbling" the smaller piece. The smaller piece does not have to be - an opponent's piece, and the smaller piece may itself have gobbled - another piece previously. + "gobbling" the smaller piece. The smaller piece does not have to + be an opponent's piece, and the smaller piece may itself have + gobbled another piece previously. * Only visible pieces can be moved, and only visible pieces count - toward winning. Gobbled pieces stay on the board, however, and when - a piece is moved, any piece that it gobbled stays put and becomes - visible. + toward winning. Gobbled pieces stay on the board, however, and + when a piece is moved, any piece that it gobbled stays put and + becomes visible. * If moving a piece exposes a winning sequence for the opponent, and if the destination for the move does not cover up one of the other @@ -43,10 +43,10 @@ The 3x3 game is a generalization of tic-tac-toe: makes a winning sequence for the moving player. * Technically, if a player touches a piece, then the piece must be - moved on that turn. In other words, you're not allowed to peek - under a piece to remind yourself whether it gobbled anything. If - the piece can't be moved, the player forfeits. This particular rule - is not enforced by our version --- in part because our version + moved on that turn. In other words, you're not allowed to peek + under a piece to remind yourself whether it gobbled anything. If + the piece can't be moved, the player forfeits. This particular + rule is not enforced by our version --- in part because our version supports a rewind button, which is also not in the official game. The 4x4 game has a few changes: @@ -72,36 +72,36 @@ The 4x4 game has a few changes: Controls -------- -Click and drag pieces in the obvious way to take a turn. The shadow +Click and drag pieces in the obvious way to take a turn. The shadow under a piece shows where it will land when you drop it. -Use the arrow keys on your keyboard to rotate the board. Use the "-" -and "=" keys to zoom in and out. Use "_" and "+" to make the game -smaller and larger. (Changing the size adjusts perspective in a -slightly different way than zooming.) Depending on how keyboard focus +Use the arrow keys on your keyboard to rotate the board. Use the "-" +and "=" keys to zoom in and out. Use "_" and "+" to make the game +smaller and larger. (Changing the size adjusts perspective in a +slightly different way than zooming.) Depending on how keyboard focus works on your machine, you may have to click the board area to make these controls work. -The button labeled "<" at the bottom of the window rewinds the game -by one turn. The button labeled ">" re-plays one turn in a rewound -game. An alternate move can be made at any point in a rewound game, +The button labeled "<" at the bottom of the window rewinds the game by +one turn. The button labeled ">" re-plays one turn in a rewound game. +An alternate move can be made at any point in a rewound game, replacing the old game from that point on. Auto-Play --------- Turn on a computer player at any time by checking the "Auto-Play Red" -or "Auto-Play Yellow" checkbox. If you rewind the game, you can choose -an alternate move for yourself or for the auto-player to find out what -would have happened. The auto-player is not always deterministic, so -replying the same move might lead to a different result. You can -disable an auto-player at any point by unchecking the corresponding -"Auto-Play" checkbox. +or "Auto-Play Yellow" checkbox. If you rewind the game, you can +choose an alternate move for yourself or for the auto-player to find +out what would have happened. The auto-player is not always +deterministic, so replying the same move might lead to a different +result. You can disable an auto-player at any point by unchecking the +corresponding "Auto-Play" checkbox. Important: In the 3x3 game, you CANNOT win as yellow against the smart auto-player (if the auto-player is allowed to play red from the start -of the game). In other words, red has a forced win in the 3x3 game, -and the smart auto-player knows the path to victory. You might have a +of the game). In other words, red has a forced win in the 3x3 game, +and the smart auto-player knows the path to victory. You might have a chance to beat the red player in the default mode, though, which is represented by the "Ok" choice (instead of "Smart") in the "Auto-Play Options" dialog. diff --git a/collects/games/gobblet/gobblet.ss b/collects/games/gobblet/gobblet.ss index dad97ffcb6..e0de9a72f6 100644 --- a/collects/games/gobblet/gobblet.ss +++ b/collects/games/gobblet/gobblet.ss @@ -1,62 +1,60 @@ -(module gobblet mzscheme - (require (lib "unitsig.ss") - (only (lib "unit.ss") unit import export) - (lib "file.ss") - (lib "mred.ss" "mred") - "sig.ss" - "model.ss" - "gui.ss" - "heuristics.ss" - "explore.ss" - "../show-help.ss") +#lang mzscheme +(require (lib "unitsig.ss") + (only (lib "unit.ss") unit import export) + (lib "file.ss") + (lib "mred.ss" "mred") + "sig.ss" + "model.ss" + "gui.ss" + "heuristics.ss" + "explore.ss" + "../show-help.ss") - (provide game@) +(provide game@) - (define game@ - (unit - (import) - (export) +(define game@ + (unit (import) (export) - (define (make-gobblet-unit size) - (compound-unit/sig - (import) - (link [CONFIG : config^ ((unit/sig config^ - (import) - (define BOARD-SIZE size)))] - [RESTART : restart^ ((unit/sig restart^ - (import) - (define (new-game n) - (put-preferences '(gobblet:board-size) (list n) void) - (parameterize ([current-eventspace orig-eventspace]) - (queue-callback - (lambda () - (start-gobblet n))))) - (define (show-gobblet-help) - (parameterize ([current-eventspace orig-eventspace]) - (queue-callback - (lambda () - (unless help - (set! help (show-help (list "games" "gobblet") - "Gobblet Help" #f))) - (help)))))))] - [MODEL : model^ (model-unit CONFIG)] - [HEURISTICS : heuristics^ (heuristics-unit CONFIG MODEL EXPLORE)] - [EXPLORE : explore^ (explore-unit CONFIG MODEL)] - [GUI : () (gui-unit CONFIG MODEL RESTART HEURISTICS EXPLORE)]) - (export))) + (define (make-gobblet-unit size) + (compound-unit/sig + (import) + (link [CONFIG : config^ + ((unit/sig config^ (import) + (define BOARD-SIZE size)))] + [RESTART : restart^ + ((unit/sig restart^ (import) + (define (new-game n) + (put-preferences '(gobblet:board-size) (list n) void) + (parameterize ([current-eventspace orig-eventspace]) + (queue-callback + (lambda () + (start-gobblet n))))) + (define (show-gobblet-help) + (parameterize ([current-eventspace orig-eventspace]) + (queue-callback + (lambda () + (unless help + (set! help (show-help (list "games" "gobblet") + "Gobblet Help" #f))) + (help)))))))] + [MODEL : model^ (model-unit CONFIG)] + [HEURISTICS : heuristics^ (heuristics-unit CONFIG MODEL EXPLORE)] + [EXPLORE : explore^ (explore-unit CONFIG MODEL)] + [GUI : () (gui-unit CONFIG MODEL RESTART HEURISTICS EXPLORE)]) + (export))) - (define help #f) + (define help #f) - (define orig-eventspace (current-eventspace)) - - (define (start-gobblet board-size) - ;; Start a new game as a child process: - (parameterize ([current-custodian (make-custodian)]) - (parameterize ([exit-handler (lambda (v) - (custodian-shutdown-all (current-custodian)))]) - (parameterize ([current-eventspace (make-eventspace)]) - (queue-callback - (lambda () - (invoke-unit/sig (make-gobblet-unit board-size)))))))) - - (start-gobblet (get-preference 'gobblet:board-size (lambda () 3)))))) + (define orig-eventspace (current-eventspace)) + + (define (start-gobblet board-size) + ;; Start a new game as a child process: + (parameterize* ([current-custodian (make-custodian)] + [exit-handler + (lambda (v) + (custodian-shutdown-all (current-custodian)))] + [current-eventspace (make-eventspace)]) + (queue-callback + (lambda () (invoke-unit/sig (make-gobblet-unit board-size)))))) + + (start-gobblet (get-preference 'gobblet:board-size (lambda () 3))))) diff --git a/collects/games/gofish/doc.txt b/collects/games/gofish/doc.txt index ba54e931d6..b5f545827f 100644 --- a/collects/games/gofish/doc.txt +++ b/collects/games/gofish/doc.txt @@ -1,7 +1,7 @@ -** To play _Go Fish_, run the "Games" application. ** +** To play Go Fish, run the "PLT Games" application. Go Fish is the children's card game where you try to get rid of all -you cards by forming pairs. You play against two computer players. +you cards by forming pairs. You play against two computer players. On Each turn, if you have a match in your hand, drag one of the matching cards to your numbered box, and the match will move into the @@ -12,17 +12,17 @@ opponent's area to ask the opponent for a matching card: * If the opponent has a card with the same value as the card that you drag, the opponent will give you the card, and they'll go into your - match area. Drag another card to an opponent. + match area. Drag another card to an opponent. * If the opponent has no matching card, the top card on draw pile - will move, indicating that you must "Go Fish!". Draw a card by - dragging it from the draw pile to your hand. If the drawn card + will move, indicating that you must "Go Fish!". Draw a card by + dragging it from the draw pile to your hand. If the drawn card gives you a match, then the match will automatically move into your match area, and it's still your turn (so drag another card to one of the opponents). -The game is over when one player runs out of cards. The winner is the +The game is over when one player runs out of cards. The winner is the one with the most matches. The status line at the bottom of the window provides instructions as -you go. The computer players are not particularly smart. +you go. The computer players are not particularly smart. diff --git a/collects/games/gofish/gofish.ss b/collects/games/gofish/gofish.ss index 49cfb6b7f7..450a258d79 100644 --- a/collects/games/gofish/gofish.ss +++ b/collects/games/gofish/gofish.ss @@ -1,359 +1,329 @@ +#lang mzscheme +(require (lib "cards.ss" "games" "cards") + (lib "mred.ss" "mred") + (lib "class.ss") + (lib "unit.ss") + (lib "list.ss")) -(module gofish mzscheme - (require (lib "cards.ss" "games" "cards") - (lib "mred.ss" "mred") - (lib "class.ss") - (lib "unit.ss") - (lib "list.ss")) - - (provide game@) - - (define game@ - (unit - (import) - (export) - - ;; Player record - (define-struct player (r hand-r discard-r count-r ; regions - hand discarded ; cards - tried)) ; memory for simulating players - - ;; Player names - (define PLAYER-1-NAME "Opponent 1") - (define PLAYER-2-NAME "Opponent 2") - (define YOUR-NAME "You") - - ;; Initial card count - (define DEAL-COUNT 7) - - ;; Messages - (define YOUR-TURN-MESSAGE "Your turn. (Drag a match to your discard box or drag a card to an opponent.)") - (define GO-FISH-MESSAGE "Go Fish! (Drag a card from the center deck to your box.)") - (define MATCH-MESSAGE "Match!") - (define GAME-OVER-MESSAGE "GAME OVER") - - ;; Region layout constants - (define MARGIN 10) - (define SUBMARGIN 10) - (define LABEL-H 15) - - ;; Randomize - (random-seed (modulo (current-milliseconds) 10000)) - - ;; Set up the table - (define t (make-table "Go Fish" 8 4.5)) - (define status-pane (send t create-status-pane)) - (send t add-help-button status-pane '("games" "gofish") "Go Fish 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/one) - - ;; Get table width & height - (define w (send t table-width)) - (define h (send t table-height)) - - ;; Set up the cards - (define deck (shuffle-list (make-deck) 7)) - (for-each - (lambda (card) - (send card snap-back-after-move #t) - (send card user-can-flip #f)) - deck) - - ;; Function for dealing or drawing cards - (define (deal n) - (let loop ([n n][d deck]) - (if (zero? n) +(provide game@) +(define game@ (unit (import) (export) + +;; Player record +(define-struct player (r hand-r discard-r count-r ; regions + hand discarded ; cards + tried)) ; memory for simulating players + +;; Player names +(define PLAYER-1-NAME "Opponent 1") +(define PLAYER-2-NAME "Opponent 2") +(define YOUR-NAME "You") + +;; Initial card count +(define DEAL-COUNT 7) + +;; Messages +(define YOUR-TURN-MESSAGE + "Your turn. (Drag a match to your discard box or drag a card to an opponent.)") +(define GO-FISH-MESSAGE + "Go Fish! (Drag a card from the center deck to your box.)") +(define MATCH-MESSAGE "Match!") +(define GAME-OVER-MESSAGE "GAME OVER") + +;; Region layout constants +(define MARGIN 10) +(define SUBMARGIN 10) +(define LABEL-H 15) + +;; Randomize +(random-seed (modulo (current-milliseconds) 10000)) + +;; Set up the table +(define t (make-table "Go Fish" 8 4.5)) +(define status-pane (send t create-status-pane)) +(send t add-help-button status-pane '("games" "gofish") "Go Fish 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/one) + +;; Get table width & height +(define w (send t table-width)) +(define h (send t table-height)) + +;; Set up the cards +(define deck (shuffle-list (make-deck) 7)) +(for-each (lambda (card) + (send card snap-back-after-move #t) + (send card user-can-flip #f)) + deck) + +;; Function for dealing or drawing cards +(define (deal n) + (let loop ([n n][d deck]) + (if (zero? n) + (begin (set! deck d) null) + (cons (car d) (loop (sub1 n) (cdr d)))))) + +;; Card width & height +(define cw (send (car deck) card-width)) +(define ch (send (car deck) card-height)) + +;; Put the cards on the table +(send t add-cards deck (/ (- w cw) 2) (- (/ (- h ch) 2) (/ ch 3))) + +;; Player region size +(define pw (- (/ (- w cw) 2) (* 2 MARGIN))) +(define ph (- (/ (- h (/ ch 3)) 2) (* 2 MARGIN))) + +;; Region-makers +(define (make-hand-region r) + (define m SUBMARGIN) + (make-region (+ m (region-x r)) (+ LABEL-H m (region-y r)) + (- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m)) + #f #f)) +(define (make-discard-region r) + (make-region (- (+ (region-x r) (region-w r)) SUBMARGIN cw) + (- (+ (region-y r) (region-h r)) SUBMARGIN ch) + cw ch + #f #f)) +(define (make-discard-count-region r c cb) + (make-region + (- (+ (region-x r) (region-w r)) SUBMARGIN cw (/ SUBMARGIN 2)) + (- (+ (region-y r) (region-h r)) SUBMARGIN ch LABEL-H (/ SUBMARGIN 2)) + (+ cw SUBMARGIN) (+ ch LABEL-H SUBMARGIN) + (number->string c) + cb)) + +;; Define the initial regions +(define player-1-region + (make-region MARGIN MARGIN pw ph PLAYER-1-NAME void)) +(define player-2-region + (make-region (- w MARGIN pw) MARGIN pw ph PLAYER-2-NAME void)) +(define you-region + (make-region MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph YOUR-NAME void)) + +;; Player setup +(define (create-player r discard-callback) + (let ([p (make-player + r + (make-hand-region r) + (make-discard-region r) + (make-discard-count-region r 0 discard-callback) + (deal DEAL-COUNT) + null + null)]) + (send t add-region r) + (send t add-region (player-count-r p)) + (for-each (lambda (card) + (send t card-to-front card)) (reverse (player-hand p))) + (send t move-cards-to-region (player-hand p) (player-hand-r p)) + p)) + +(define player-1 (create-player player-1-region #f)) +(define player-2 (create-player player-2-region #f)) +(define you (create-player you-region + ;; Dragging to your discard pile checks to see if + ;; the card makes a match: + (lambda (cards) + (check-hand you (car cards)) + (send t set-status YOUR-TURN-MESSAGE)))) + +;; More card setup: Opponents's cards and deck initally can't be moved +(for-each (lambda (card) (send card user-can-move #f)) + (append (player-hand player-1) (player-hand player-2) deck)) + +;; More card setup: Show your cards +(send t flip-cards (player-hand you)) + +;; Function to update the display for a player record +(define (rearrange-cards p) + ;; Stack cards in 3D first-to-last + (send t stack-cards (player-discarded p)) + (send t stack-cards (player-hand p)) + ;; Move them to their regions + (send t move-cards-to-region (player-discarded p) (player-discard-r p)) + (send t move-cards-to-region (player-hand p) (player-hand-r p)) + ;; Recreate the counter region to reset the count + (send t begin-card-sequence) + (send t remove-region (player-count-r p)) + (set-player-count-r! p (make-discard-count-region + (player-r p) (/ (length (player-discarded p)) 2) + (region-callback (player-count-r p)))) + (send t add-region (player-count-r p)) + (send t end-card-sequence)) + +;; Function to search for an equivalent card +(define (find-equiv card hand) + (ormap (lambda (c) + (and (not (eq? c card)) + (= (send card get-value) (send c get-value)) + c)) + hand)) + +;; Function to check for a match involving `card' already in the player's hand +(define (check-hand player card) + (let* ([h (player-hand player)] + [found (find-equiv card h)]) + (if found + (begin + ;; Make sure the matching cards are face-up and pause for the user + (send t cards-face-up (list found card)) + (send t set-status MATCH-MESSAGE) + ;; The players has a match! Move the card from the player's hand + ;; to his discard pile + (set-player-hand! player (remove* (list card found) h)) + (set-player-discarded! player + (list* found card (player-discarded player))) + ;; The dicarded cards can no longer be moved + (send card user-can-move #f) + (send found user-can-move #f) + ;; Move the cards to their new places + (rearrange-cards player) + ;; Slower + #t) + #f))) + +;; Function to enable/disable moving your cards +(define (enable-your-cards on?) + (for-each (lambda (c) (send c user-can-move on?)) (player-hand you))) + +;; Callbacks communicate back to the main loop via these +(define something-happened (make-semaphore 1)) +(define go-fish? #f) + +;; Function for trying to get a card from another player +(define (ask-player-for-match getter giver card) + (let* ([h (player-hand giver)] + [found (find-equiv card h)]) + (if found + (begin + ;; The giver player has a matching card - give it to the getter + (set-player-hand! giver (remq found h)) + (set-player-hand! getter (cons found (player-hand getter))) + ;; Make sure the matching cards are face-up and pause for the user + (send t cards-face-up (list found card)) + ;; Move the cards around + (check-hand getter card) + (rearrange-cards giver) + #t) + ;; The giver player doesn't have it - Go Fish! + #f))) + +;; Callback for dragging a card to an opponent +(define (player-callback player) + (lambda (cards) + (set! go-fish? (not (ask-player-for-match you player (car cards)))) + (semaphore-post something-happened))) + +;; Visual info to go fish +(define wiggle-top-card + (lambda () + (let ([top (car deck)] + [x (/ (- w cw) 2)] + [y (- (/ (- h ch) 2) (/ ch 3))]) + (send t move-card top (- x 10) y) + (send t move-card top (+ x 10) y) + (send t move-card top x y)))) + +;; Callback for going fishing +(define fishing + (lambda (cards) + (send t flip-card (car deck)) + (set-player-hand! you (append (deal 1) (player-hand you))) + (rearrange-cards you) + (semaphore-post something-happened))) + +;; Function to simulate a player +(define (simulate-player player other-player k) + ;; Try cards in the players hand that haven't been tried + (let ([cards-to-try (remq* (player-tried player) (player-hand player))]) + (if (null? cards-to-try) + (begin + ;; No cards to try. Reset the history and start over + (set-player-tried! player null) + (simulate-player player other-player k)) + ;; Pick a random card and a random opponent + (let ([c (list-ref cards-to-try (random (length cards-to-try)))] + [o (list-ref (list you other-player) (random 2))]) + (set-player-tried! player (cons c (player-tried player))) + ;; Show you the card-to-ask + (send t flip-card c) + ;; Hilight player-to-ask + (send t hilite-region (player-r o)) + ;; Wait a moment + (sleep 0.3) + ;; Unhilight player-to-ask + (send t unhilite-region (player-r o)) + (if (ask-player-for-match player o c) + ;; Got it - go again + (check-done + (lambda () + (simulate-player player other-player k))) + ;; Go fish + (begin + ;; Wait a bit, then turn the asked-for card back over + (sleep 0.3) + (send t flip-card c) + (if (null? deck) + ;; No more cards; pass + (k) (begin - (set! deck d) - null) - (cons (car d) (loop (sub1 n) (cdr d)))))) - - ;; Card width & height - (define cw (send (car deck) card-width)) - (define ch (send (car deck) card-height)) - - ;; Put the cards on the table - (send t add-cards - deck - (/ (- w cw) 2) - (- (/ (- h ch) 2) (/ ch 3))) - - ;; Player region size - (define pw (- (/ (- w cw) 2) (* 2 MARGIN))) - (define ph (- (/ (- h (/ ch 3)) 2) (* 2 MARGIN))) - - ;; Region-makers - (define (make-hand-region r) - (define m SUBMARGIN) - (make-region - (+ m (region-x r)) (+ LABEL-H m (region-y r)) - (- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m)) - #f #f)) - (define (make-discard-region r) - (make-region - (- (+ (region-x r) (region-w r)) SUBMARGIN cw) - (- (+ (region-y r) (region-h r)) SUBMARGIN ch) - cw ch - #f #f)) - (define (make-discard-count-region r c cb) - (make-region - (- (+ (region-x r) (region-w r)) SUBMARGIN cw (/ SUBMARGIN 2)) - (- (+ (region-y r) (region-h r)) SUBMARGIN ch LABEL-H (/ SUBMARGIN 2)) - (+ cw SUBMARGIN) (+ ch LABEL-H SUBMARGIN) - (number->string c) - cb)) - - ;; Define the initial regions - (define player-1-region - (make-region - MARGIN MARGIN pw ph - PLAYER-1-NAME - void)) - (define player-2-region - (make-region - (- w MARGIN pw) MARGIN pw ph - PLAYER-2-NAME - void)) - (define you-region - (make-region - MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph - YOUR-NAME - void)) - - ;; Player setup - (define (create-player r discard-callback) - (let ([p (make-player - r - (make-hand-region r) - (make-discard-region r) - (make-discard-count-region r 0 discard-callback) - (deal DEAL-COUNT) - null - null)]) - (send t add-region r) - (send t add-region (player-count-r p)) - (for-each (lambda (card) (send t card-to-front card)) (reverse (player-hand p))) - (send t move-cards-to-region (player-hand p) (player-hand-r p)) - p)) - - (define player-1 (create-player player-1-region #f)) - (define player-2 (create-player player-2-region #f)) - (define you (create-player you-region - ;; Dragging to your discard pile checks to see if the card - ;; makes a match: - (lambda (cards) - (check-hand you (car cards)) - (send t set-status YOUR-TURN-MESSAGE)))) - - ;; More card setup: Opponents's cards and deck initally can't be moved - (for-each - (lambda (card) (send card user-can-move #f)) - (append - (player-hand player-1) - (player-hand player-2) - deck)) - - ;; More card setup: Show your cards - (send t flip-cards (player-hand you)) - - ;; Function to update the display for a player record - (define (rearrange-cards p) - ;; Stack cards in 3D first-to-last - (send t stack-cards (player-discarded p)) - (send t stack-cards (player-hand p)) - ;; Move them to their regions - (send t move-cards-to-region (player-discarded p) (player-discard-r p)) - (send t move-cards-to-region (player-hand p) (player-hand-r p)) - ;; Recreate the counter region to reset the count - (send t begin-card-sequence) - (send t remove-region (player-count-r p)) - (set-player-count-r! p (make-discard-count-region - (player-r p) (/ (length (player-discarded p)) 2) - (region-callback (player-count-r p)))) - (send t add-region (player-count-r p)) - (send t end-card-sequence)) - - ;; Function to search for an equivalent card - (define (find-equiv card hand) - (ormap (lambda (c) - (and (not (eq? c card)) - (= (send card get-value) (send c get-value)) - c)) - hand)) - - ;; Function to check for a match involving `card' already in the player's hand - (define (check-hand player card) - (let* ([h (player-hand player)] - [found (find-equiv card h)]) - (if found - (begin - ;; Make sure the matching cards are face-up and pause for the user - (send t cards-face-up (list found card)) - (send t set-status MATCH-MESSAGE) - ;; The players has a match! Move the card from the player's hand - ;; to his discard pile - (set-player-hand! player (remove* (list card found) h)) - (set-player-discarded! player (cons found - (cons card - (player-discarded player)))) - ;; The dicarded cards can no longer be moved - (send card user-can-move #f) - (send found user-can-move #f) - ;; Move the cards to their new places + ;; Draw a card + (set-player-hand! player (append (deal 1) (player-hand player))) (rearrange-cards player) - ;; Slower - #t) - #f))) - - ;; Function to enable/disable moving your cards - (define (enable-your-cards on?) - (for-each (lambda (c) (send c user-can-move on?)) - (player-hand you))) - - ;; Callbacks communicate back to the main loop via these - (define something-happened (make-semaphore 1)) - (define go-fish? #f) - - ;; Function for trying to get a card from another player - (define (ask-player-for-match getter giver card) - (let* ([h (player-hand giver)] - [found (find-equiv card h)]) - (if found - (begin - ;; The giver player has a matching card - give it to the getter - (set-player-hand! giver (remq found h)) - (set-player-hand! getter (cons found (player-hand getter))) - ;; Make sure the matching cards are face-up and pause for the user - (send t cards-face-up (list found card)) - ;; Move the cards around - (check-hand getter card) - (rearrange-cards giver) - #t) - ;; The giver player doesn't have it - Go Fish! - #f))) - - ;; Callback for dragging a card to an opponent - (define (player-callback player) - (lambda (cards) - (set! go-fish? (not (ask-player-for-match you player (car cards)))) - (semaphore-post something-happened))) - - ;; Visual info to go fish - (define wiggle-top-card - (lambda () - (let ([top (car deck)] - [x (/ (- w cw) 2)] - [y (- (/ (- h ch) 2) (/ ch 3))]) - (send t move-card top (- x 10) y) - (send t move-card top (+ x 10) y) - (send t move-card top x y)))) - - ;; Callback for going fishing - (define fishing - (lambda (cards) - (send t flip-card (car deck)) - (set-player-hand! you (append (deal 1) (player-hand you))) - (rearrange-cards you) - (semaphore-post something-happened))) - - ;; Function to simulate a player - (define (simulate-player player other-player k) - ;; Try cards in the players hand that haven't been tried - (let ([cards-to-try (remq* (player-tried player) (player-hand player))]) - (if (null? cards-to-try) - (begin - ;; No cards to try. Reset the history and start over - (set-player-tried! player null) - (simulate-player player other-player k)) - ;; Pick a random card and a random opponent - (let ([c (list-ref cards-to-try (random (length cards-to-try)))] - [o (list-ref (list you other-player) (random 2))]) - (set-player-tried! player (cons c (player-tried player))) - ;; Show you the card-to-ask - (send t flip-card c) - ;; Hilight player-to-ask - (send t hilite-region (player-r o)) - ;; Wait a moment - (sleep 0.3) - ;; Unhilight player-to-ask - (send t unhilite-region (player-r o)) - (if (ask-player-for-match player o c) - ;; Got it - go again - (check-done - (lambda () - (simulate-player player other-player k))) - ;; Go fish - (begin - ;; Wait a bit, then turn the asked-for card back over - (sleep 0.3) - (send t flip-card c) - (if (null? deck) - ;; No more cards; pass - (k) - (begin - ;; Draw a card - (set-player-hand! player (append (deal 1) (player-hand player))) - (rearrange-cards player) - (if (check-hand player (car (player-hand player))) - ;; Drew a good card - keep going - (check-done - (lambda () - (simulate-player player other-player k))) - ;; End of our turn - (k)))))))))) - - ;; Function to check for end-of-game - (define (check-done k) - (if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you)) - (begin - (enable-your-cards #f) - (send t set-status GAME-OVER-MESSAGE)) - (k))) - - ;; Look in opponents' initial hands for matches - ;; (Since each player gets 7 cards, it's impossible to run out of cards this way) - (define (find-initial-matches player) - (when (ormap (lambda (card) (check-hand player card)) (player-hand player)) - ;; Found a match in the hand - (find-initial-matches player))) - (find-initial-matches player-1) - (find-initial-matches player-2) - - ;; Run the game loop - (let loop () - (set-region-callback! (player-r you) #f) - (set-region-callback! (player-r player-1) (player-callback player-1)) - (set-region-callback! (player-r player-2) (player-callback player-2)) - (send t set-status YOUR-TURN-MESSAGE) - (yield something-happened) - (if go-fish? - (begin - (if (if (null? deck) - ;; No more cards; pass - #f - ;; Draw a card (wait for the user to drag it) - (begin - (send t set-status GO-FISH-MESSAGE) - (wiggle-top-card) - (enable-your-cards #f) - (set-region-callback! (player-r player-1) #f) - (set-region-callback! (player-r player-2) #f) - (set-region-callback! (player-r you) fishing) - (send (car deck) user-can-move #t) - (yield something-happened) - (enable-your-cards #t) - (check-hand you (car (player-hand you))))) - (check-done loop) - (begin - (send t set-status PLAYER-1-NAME) - (simulate-player - player-1 player-2 - (lambda () - (send t set-status PLAYER-2-NAME) - (simulate-player player-2 player-1 loop)))))) - (check-done loop)))))) - - + (if (check-hand player (car (player-hand player))) + ;; Drew a good card - keep going + (check-done + (lambda () + (simulate-player player other-player k))) + ;; End of our turn + (k)))))))))) + +;; Function to check for end-of-game +(define (check-done k) + (if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you)) + (begin (enable-your-cards #f) + (send t set-status GAME-OVER-MESSAGE)) + (k))) + +;; Look in opponents' initial hands for matches (Since each player gets 7 +;; cards, it's impossible to run out of cards this way) +(define (find-initial-matches player) + (when (ormap (lambda (card) (check-hand player card)) (player-hand player)) + ;; Found a match in the hand + (find-initial-matches player))) +(find-initial-matches player-1) +(find-initial-matches player-2) + +;; Run the game loop +(let loop () + (set-region-callback! (player-r you) #f) + (set-region-callback! (player-r player-1) (player-callback player-1)) + (set-region-callback! (player-r player-2) (player-callback player-2)) + (send t set-status YOUR-TURN-MESSAGE) + (yield something-happened) + (if go-fish? + (begin + (if (if (null? deck) + ;; No more cards; pass + #f + ;; Draw a card (wait for the user to drag it) + (begin (send t set-status GO-FISH-MESSAGE) + (wiggle-top-card) + (enable-your-cards #f) + (set-region-callback! (player-r player-1) #f) + (set-region-callback! (player-r player-2) #f) + (set-region-callback! (player-r you) fishing) + (send (car deck) user-can-move #t) + (yield something-happened) + (enable-your-cards #t) + (check-hand you (car (player-hand you))))) + (check-done loop) + (begin (send t set-status PLAYER-1-NAME) + (simulate-player + player-1 player-2 + (lambda () + (send t set-status PLAYER-2-NAME) + (simulate-player player-2 player-1 loop)))))) + (check-done loop))))) diff --git a/collects/games/jewel/doc.txt b/collects/games/jewel/doc.txt index f6052bf809..4d10c07f1d 100644 --- a/collects/games/jewel/doc.txt +++ b/collects/games/jewel/doc.txt @@ -1,30 +1,29 @@ -** To play _Jewel_, run the "Games" application. ** +** To play Jewel, run the "PLT Games" application. The board is an 8x8 array of jewels of 7 types. You need to get 3 or -more in a row horizontally or vertically in order to score points. You -can swap any two jewels that are next to each other up and down or -left and right. The mechanic is to either: +more in a row horizontally or vertically in order to score points. +You can swap any two jewels that are next to each other up and down or +left and right. The mechanic is to either: * Click the mouse on the first one, then drag in the direction for the swap. * Move a bubble using the arrow keys, lock the bubble to a jewel with the space bar, and the swap the locked jewel with another by using - the arrow keys. Space unlocks a locked bubble without swapping. + the arrow keys. Space unlocks a locked bubble without swapping. Jewels can only be swapped if after the swap there are at least 3 or -more same shape or color in a row or column. Otherwise the jewels -return to their original position. There is a clock shown on the -left. When it counts down to 0 the game is over. Getting 3 in a row +more same shape or color in a row or column. Otherwise the jewels +return to their original position. There is a clock shown on the +left. When it counts down to 0 the game is over. Getting 3 in a row adds time to the clock. Hit spacebar to start a new game then select the difficulty number by -pressing '0', '1', '2', '3' or '4'. You can always press 'ESC' to exit. -During playing press 'p' to pause the game. +pressing '0', '1', '2', '3' or '4'. You can always press 'ESC' to +exit. During playing press 'p' to pause the game. -The code is released under the LGPL. -The code is a conversion of Dave Ashley's C program to Scheme with some -modifications and enhancements. +The code is released under the LGPL. The code is a conversion of Dave +Ashley's C program to Scheme with some modifications and enhancements. Enjoy. diff --git a/collects/games/lights-out/doc.txt b/collects/games/lights-out/doc.txt index 60167628eb..66e11b0d83 100644 --- a/collects/games/lights-out/doc.txt +++ b/collects/games/lights-out/doc.txt @@ -1,7 +1,7 @@ -_Lights Out_ +** To play Lights Out, run the "PLT Games" application. -The object of this game is to turn all of the lights off. Click on a button -to turn that light off, but beware it will also toggle the lights above, -below to the left and to the right of that button. +The object of this game is to turn all of the lights off. Click on a +button to turn that light off, but beware it will also toggle the +lights above, below to the left and to the right of that button. -Good luck. \ No newline at end of file +Good luck. diff --git a/collects/games/lights-out/lights-out.ss b/collects/games/lights-out/lights-out.ss index b067fac565..a917d2886c 100644 --- a/collects/games/lights-out/lights-out.ss +++ b/collects/games/lights-out/lights-out.ss @@ -1,212 +1,186 @@ -(module lights-out mzscheme - (require "board.ss" - "../show-help.ss" - (lib "mred.ss" "mred") - (lib "class.ss") - (lib "unit.ss")) - - (provide game@ - lights-out^) - - (define-signature lights-out^ - (init-board)) +#lang mzscheme +(require "board.ss" + "../show-help.ss" + (lib "mred.ss" "mred") + (lib "class.ss") + (lib "unit.ss")) - (define game@ - (unit - (import) - (export lights-out^) ;; : (board -> void) resets the window(s) - - (define frame (make-object frame% "Lights Out")) - - (define label-size 30) - - (define orange (make-object color% 255 165 0)) - (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-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-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-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-brush (send the-brush-list find-or-create-brush "DARK GRAY" 'solid)) - - (define (flip-one i j) +(provide game@ lights-out^) + +(define-signature lights-out^ (init-board)) + +(define game@ (unit (import) +(export lights-out^) ;; : (board -> void) resets the window(s) + +(define frame (make-object frame% "Lights Out")) + +(define label-size 30) + +(define orange (make-object color% 255 165 0)) +(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-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-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-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-brush (send the-brush-list find-or-create-brush "DARK GRAY" 'solid)) + +(define (flip-one i j) + (when (and (<= 0 i (- (vector-length current-board) 1)) + (<= 0 j (- (vector-length current-board) 1))) + (vector-set! + (vector-ref current-board j) + i + (case (vector-ref (vector-ref current-board j) i) + [(x) 'o] + [(o) 'x])))) + +(define (flip-surrounding i j) + (flip-one i j) + (flip-one (- i 1) j) + (flip-one i (- j 1)) + (flip-one (+ i 1) j) + (flip-one i (+ j 1))) + +(define current-board #f) +(define original-board #f) + +(define board-canvas% + (class canvas% + (inherit get-dc get-client-size) + + (define/private (get-width) (let-values ([(w h) (get-client-size)]) w)) + (define/private (get-height) (let-values ([(w h) (get-client-size)]) h)) + + [define dull-i 1] + [define dull-j 1] + [define/private tile->screen + (lambda (i j) + (let ([x (inexact->exact (floor (* (/ i (vector-length current-board)) (- (get-width) 2))))] + [y (inexact->exact (floor (* (/ j (vector-length current-board)) (- (get-height) 2))))] + [w (inexact->exact (floor (* (/ (- (get-width) 2) (vector-length current-board)))))] + [h (inexact->exact (floor (* (/ (- (get-height) 2) (vector-length current-board)))))]) + (values (+ x 2) + (+ y 2) + (max 0 (- w 2)) + (max 0 (- h 2)))))] + [define/private screen->tile + (lambda (x y) + (values (inexact->exact (floor (* (/ x (get-width)) (vector-length current-board)))) + (inexact->exact (floor (* (/ y (get-height)) (vector-length current-board))))))] + [define/private draw-tile + (lambda (dc i j) (when (and (<= 0 i (- (vector-length current-board) 1)) (<= 0 j (- (vector-length current-board) 1))) - (vector-set! - (vector-ref current-board j) - i - (case (vector-ref (vector-ref current-board j) i) - [(x) 'o] - [(o) 'x])))) - - (define (flip-surrounding i j) - (flip-one i j) - (flip-one (- i 1) j) - (flip-one i (- j 1)) - (flip-one (+ i 1) j) - (flip-one i (+ j 1))) - - (define current-board #f) - (define original-board #f) - - (define board-canvas% - (class canvas% - (inherit get-dc get-client-size) - - (define/private (get-width) (let-values ([(w h) (get-client-size)]) w)) - (define/private (get-height) (let-values ([(w h) (get-client-size)]) h)) - - [define dull-i 1] - [define dull-j 1] - [define/private tile->screen - (lambda (i j) - (let ([x (inexact->exact (floor (* (/ i (vector-length current-board)) (- (get-width) 2))))] - [y (inexact->exact (floor (* (/ j (vector-length current-board)) (- (get-height) 2))))] - [w (inexact->exact (floor (* (/ (- (get-width) 2) (vector-length current-board)))))] - [h (inexact->exact (floor (* (/ (- (get-height) 2) (vector-length current-board)))))]) - (values (+ x 2) - (+ y 2) - (max 0 (- w 2)) - (max 0 (- h 2)))))] - [define/private screen->tile - (lambda (x y) - (values (inexact->exact (floor (* (/ x (get-width)) (vector-length current-board)))) - (inexact->exact (floor (* (/ y (get-height)) (vector-length current-board))))))] - [define/private draw-tile - (lambda (dc i j) - (when (and (<= 0 i (- (vector-length current-board) 1)) - (<= 0 j (- (vector-length current-board) 1))) - (let ([ent (vector-ref (vector-ref current-board j) i)] - [dull? (and dull-i - dull-j - (or (and (= i dull-i) - (= j dull-j)) - (and (= i (- dull-i 1)) - (= j dull-j)) - (and (= i (+ dull-i 1)) - (= j dull-j)) - (and (= i dull-i) - (= j (- dull-j 1))) - (and (= i dull-i) - (= j (+ dull-j 1)))))]) - (if dull? - (if (eq? ent 'x) - (begin - (send dc set-pen dull-off-pen) - (send dc set-brush dull-off-brush)) - (begin - (send dc set-pen dull-on-pen) - (send dc set-brush dull-on-brush))) - (if (eq? ent 'x) - (begin - (send dc set-pen on-pen) - (send dc set-brush on-brush)) - (begin - (send dc set-pen off-pen) - (send dc set-brush off-brush))))) - (let-values ([(x y w h) (tile->screen i j)]) - (send dc draw-rectangle x y w h))))] - [define/private get-changed - (lambda (x y) - (if (and x y) - (list (cons x y) - (cons (+ x 1) y) - (cons (- x 1) y) - (cons x (- y 1)) - (cons x (+ y 1))) - null))] - [define/public redraw - (lambda () - (let* ([dc (get-dc)]) - (let loop ([j (vector-length current-board)]) - (cond - [(zero? j) (void)] - [else - (let loop ([i (vector-length current-board)]) - (cond - [(zero? i) (void)] - [else - (draw-tile dc - (- i 1) - (- j 1)) - (loop (- i 1))])) - (loop (- j 1))]))))] - - [define/override on-event - (lambda (evt) - (cond - [(send evt button-up?) - (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))]) - (flip-surrounding x y) - (redraw))] - [(send evt leaving?) - (let ([changed (get-changed dull-i dull-j)]) - (set! dull-i #f) - (set! dull-j #f) - (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair))) - changed))] - [(send evt moving?) - (let ([changed-one (get-changed dull-i dull-j)]) - (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))]) - (set! dull-i x) - (set! dull-j y)) - (let ([changed-two (get-changed dull-i dull-j)]) - (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair))) - (append changed-one changed-two))))] - [else (void)]))] - [define/override on-paint - (lambda () - (send (get-dc) clear) - (redraw))] - (super-instantiate () - (parent frame)))) - - (define board-canvas (make-object board-canvas%)) - (send board-canvas min-width 100) - (send board-canvas min-height 100) - - (define (copy-board board) - (list->vector - (map (lambda (x) (list->vector (vector->list x))) - (vector->list board)))) - - (define (init-board new-board) - (set! current-board new-board) - (set! original-board (copy-board new-board)) - (send board-canvas on-paint)) - - (define button-panel (make-object horizontal-panel% frame)) - - (make-object button% "New" button-panel - (lambda x - (let ([res (new-board)]) - (when res - (init-board res))))) - - (make-object button% "Reset" button-panel - (lambda x - (init-board original-board))) - - (let ([help (show-help - (list "games" "lights-out") - "Lights Out Help")]) - (make-object button% "Help" button-panel - (lambda x - (help)))) - - (make-object grow-box-spacer-pane% button-panel) - (send button-panel stretchable-height #f) - - (init-board (random-board (+ 3 - (random 2) - (random 2) - (random 2) - (random 2) - (random 2)))) - ;(send frame stretchable-width #f) - ;(send frame stretchable-height #f) - (send frame show #t)))) + (let ([ent (vector-ref (vector-ref current-board j) i)] + [dull? (and dull-i + dull-j + (or (and (= i dull-i) (= j dull-j)) + (and (= i (- dull-i 1)) (= j dull-j)) + (and (= i (+ dull-i 1)) (= j dull-j)) + (and (= i dull-i) (= j (- dull-j 1))) + (and (= i dull-i) (= j (+ dull-j 1)))))]) + (if dull? + (if (eq? ent 'x) + (begin (send dc set-pen dull-off-pen) + (send dc set-brush dull-off-brush)) + (begin (send dc set-pen dull-on-pen) + (send dc set-brush dull-on-brush))) + (if (eq? ent 'x) + (begin (send dc set-pen on-pen) + (send dc set-brush on-brush)) + (begin (send dc set-pen off-pen) + (send dc set-brush off-brush))))) + (let-values ([(x y w h) (tile->screen i j)]) + (send dc draw-rectangle x y w h))))] + [define/private get-changed + (lambda (x y) + (if (and x y) + (list (cons x y) + (cons (+ x 1) y) + (cons (- x 1) y) + (cons x (- y 1)) + (cons x (+ y 1))) + null))] + [define/public redraw + (lambda () + (let* ([dc (get-dc)]) + (let loop ([j (vector-length current-board)]) + (if (zero? j) + (void) + (begin (let loop ([i (vector-length current-board)]) + (if (zero? i) + (void) + (begin (draw-tile dc (- i 1) (- j 1)) + (loop (- i 1))))) + (loop (- j 1)))))))] + + [define/override on-event + (lambda (evt) + (cond + [(send evt button-up?) + (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))]) + (flip-surrounding x y) + (redraw))] + [(send evt leaving?) + (let ([changed (get-changed dull-i dull-j)]) + (set! dull-i #f) + (set! dull-j #f) + (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair))) + changed))] + [(send evt moving?) + (let ([changed-one (get-changed dull-i dull-j)]) + (let-values ([(x y) (screen->tile (send evt get-x) (send evt get-y))]) + (set! dull-i x) + (set! dull-j y)) + (let ([changed-two (get-changed dull-i dull-j)]) + (for-each (lambda (pair) (draw-tile (get-dc) (car pair) (cdr pair))) + (append changed-one changed-two))))] + [else (void)]))] + [define/override on-paint + (lambda () + (send (get-dc) clear) + (redraw))] + (super-instantiate () (parent frame)))) + +(define board-canvas (make-object board-canvas%)) +(send board-canvas min-width 100) +(send board-canvas min-height 100) + +(define (copy-board board) + (list->vector + (map (lambda (x) (list->vector (vector->list x))) + (vector->list board)))) + +(define (init-board new-board) + (set! current-board new-board) + (set! original-board (copy-board new-board)) + (send board-canvas on-paint)) + +(define button-panel (make-object horizontal-panel% frame)) + +(make-object button% "New" button-panel + (lambda x + (let ([res (new-board)]) + (when res + (init-board res))))) + +(make-object button% "Reset" button-panel + (lambda x + (init-board original-board))) + +(let ([help (show-help (list "games" "lights-out") "Lights Out Help")]) + (make-object button% "Help" button-panel (lambda x (help)))) + +(make-object grow-box-spacer-pane% button-panel) +(send button-panel stretchable-height #f) + +(init-board (random-board + (+ 3 (random 2) (random 2) (random 2) (random 2) (random 2)))) +;; (send frame stretchable-width #f) +;; (send frame stretchable-height #f) +(send frame show #t))) diff --git a/collects/games/memory/memory.ss b/collects/games/memory/memory.ss index a034565468..6cc165c3a0 100644 --- a/collects/games/memory/memory.ss +++ b/collects/games/memory/memory.ss @@ -1,176 +1,164 @@ +#lang mzscheme +(require (lib "cards.ss" "games" "cards") + (lib "mred.ss" "mred") + (lib "class.ss") + (lib "unit.ss") + (lib "list.ss")) -(module memory mzscheme - (require (lib "cards.ss" "games" "cards") - (lib "mred.ss" "mred") - (lib "class.ss") - (lib "unit.ss") - (lib "list.ss")) - - (provide game@) - - (define game@ - (unit - (import) - (export) +(provide game@) - ;; Layout width and height: - (define WIDTH 5) - (define HEIGHT 4) - (define MAX-MATCHES (/ (* WIDTH HEIGHT) 2)) - - ;; Randomize - (random-seed (modulo (current-milliseconds) 10000)) - - ;; Set up the table - (define t (make-table "Memory" (+ 2 WIDTH) (+ 1 HEIGHT))) - (send t show #t) - (send t set-double-click-action #f) - - ;; Get table width & height - (define w (send t table-width)) - (define h (send t table-height)) - - ;; Set up the cards - (define deck - (let ([cards (map (lambda (name value) - (let ([bm (make-object bitmap% - (build-path - (collection-path "games" "memory" "images") - (format "~a.png" name)))]) - (make-card bm #f 0 value))) - '("club" "heart" "spade" "diamond" - "happy" "unhappy" - "fish" "two-fish" - "jack" "star") - '(1 2 3 4 5 6 7 8 9 10))]) - (append cards (map (lambda (c) (send c copy)) cards)))) - (for-each - (lambda (card) - (send card user-can-move #f) - (send card user-can-flip #t)) - deck) +(define game@ (unit (import) (export) - ;; Card width & height - (define cw (send (car deck) card-width)) - (define ch (send (car deck) card-height)) - - (define dx (/ cw (+ 2 WIDTH))) - (define dy (/ ch (+ 1 HEIGHT))) - - (define match-x (- w cw dx)) - (define match-y dy) +;; Layout width and height: +(define WIDTH 5) +(define HEIGHT 4) +(define MAX-MATCHES (/ (* WIDTH HEIGHT) 2)) - (define time-h (+ 12 5 5)) - (define time-x match-x) - (define time-y (+ ch dy dy)) +;; Randomize +(random-seed (modulo (current-milliseconds) 10000)) - ;; Put the cards on the table - (send t add-cards deck match-x match-y) +;; Set up the table +(define t (make-table "Memory" (+ 2 WIDTH) (+ 1 HEIGHT))) +(send t show #t) +(send t set-double-click-action #f) - ;; Setup - (define (setup) - (reset-timer) - (set! deck (shuffle-list deck 7)) - (send t stack-cards deck) - (send t move-cards deck 0 0 - (lambda (pos) - (let ([i (modulo pos WIDTH)] - [j (quotient pos WIDTH)]) - (values (+ dx (* i (+ cw dx))) - (+ dy (* j (+ ch dy)))))))) +;; Get table width & height +(define w (send t table-width)) +(define h (send t table-height)) - ;; Number of matches found so far: - (define matches 0) +;; Set up the cards +(define deck + (let ([cards (map (lambda (name value) + (let ([bm (make-object + bitmap% + (build-path + (collection-path "games" "memory" "images") + (format "~a.png" name)))]) + (make-card bm #f 0 value))) + '("club" "heart" "spade" "diamond" + "happy" "unhappy" + "fish" "two-fish" + "jack" "star") + '(1 2 3 4 5 6 7 8 9 10))]) + (append cards (map (lambda (c) (send c copy)) cards)))) +(for-each (lambda (card) + (send card user-can-move #f) + (send card user-can-flip #t)) + deck) - ;; First card flipped, or #f if non flipped, yet - (define card-1 #f) +;; Card width & height +(define cw (send (car deck) card-width)) +(define ch (send (car deck) card-height)) - (define (flip-and-match c) - (cond - [(eq? c card-1) - ;; Cancel first card - (send t flip-card c) - (set! card-1 #f)] - [(not (send c face-down?)) - ;; Can't click a matched card, unless the game is over, - ;; in which case we reset the game - (when (= matches MAX-MATCHES) - (send t flip-cards deck) - (set! matches 0) - (setup))] - [else - ;; Flip over a card... - (send t flip-card c) - (send t card-to-front c) - (run-timer) - (cond - [(not card-1) - ;; That was the first card - (set! card-1 c)] - [(and (equal? (send card-1 get-value) - (send c get-value)) - (equal? (send card-1 get-suit) - (send c get-suit))) - ;; Match - (send t pause 0.5) - (send t move-cards (list card-1 c) match-x match-y) - (set! card-1 #f) - (set! matches (add1 matches))] - [else - ;; Not a match - (send t pause 0.5) - (send t flip-cards (list card-1 c)) - (set! card-1 #f)])])) - (send t set-single-click-action flip-and-match) - - ;; The timer turns out to be the most difficult part: - (define (make-time-region secs) - (make-region time-x time-y cw time-h - (if (>= secs 6000) - "XX:XX" - (format - "~a:~a" - (substring (number->string (+ 100 (quotient secs 60))) 1) - (substring (number->string (+ 100 (modulo secs 60))) 1))) - #f)) - (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 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 - (define (show-time n) - ;; Compute new time to show: - (set! shown-seconds n) - ;; Update the time by removing the old region and adding a new one: - (send t begin-card-sequence) - (send t remove-region time-region) - (set! time-region (make-time-region shown-seconds)) - (send t add-region time-region) - (send t end-card-sequence)) - (define (get-update-delta) - ;; Figure out how many milliseconds to sleep before the next update - (max 0 - (inexact->exact - (floor - (- (+ start-time (* 1000 shown-seconds) 1000) - (current-inexact-milliseconds)))))) - (define time-timer - (make-object timer% (lambda () - (unless (= matches MAX-MATCHES) - (show-time - (inexact->exact - (floor (/ (- (current-inexact-milliseconds) - start-time) - 1000)))) - (send time-timer start (get-update-delta) #t))))) - (define (reset-timer) - (send time-timer stop) - (set! start-time #f) - (show-time 0)) - (define (run-timer) - (unless start-time - (set! start-time (current-inexact-milliseconds)) - (send time-timer start 1000 #t))) +(define dx (/ cw (+ 2 WIDTH))) +(define dy (/ ch (+ 1 HEIGHT))) - ;; Start the game: - (send t pause 0.25) - (setup)))) +(define match-x (- w cw dx)) +(define match-y dy) + +(define time-h (+ 12 5 5)) +(define time-x match-x) +(define time-y (+ ch dy dy)) + +;; Put the cards on the table +(send t add-cards deck match-x match-y) + +;; Setup +(define (setup) + (reset-timer) + (set! deck (shuffle-list deck 7)) + (send t stack-cards deck) + (send t move-cards deck 0 0 + (lambda (pos) + (let ([i (modulo pos WIDTH)] + [j (quotient pos WIDTH)]) + (values (+ dx (* i (+ cw dx))) + (+ dy (* j (+ ch dy)))))))) + +;; Number of matches found so far: +(define matches 0) + +;; First card flipped, or #f if non flipped, yet +(define card-1 #f) + +(define (flip-and-match c) + (cond [(eq? c card-1) + ;; Cancel first card + (send t flip-card c) + (set! card-1 #f)] + [(not (send c face-down?)) + ;; Can't click a matched card, unless the game is over, + ;; in which case we reset the game + (when (= matches MAX-MATCHES) + (send t flip-cards deck) + (set! matches 0) + (setup))] + [else + ;; Flip over a card... + (send t flip-card c) + (send t card-to-front c) + (run-timer) + (cond [(not card-1) + ;; That was the first card + (set! card-1 c)] + [(and (equal? (send card-1 get-value) (send c get-value)) + (equal? (send card-1 get-suit) (send c get-suit))) + ;; Match + (send t pause 0.5) + (send t move-cards (list card-1 c) match-x match-y) + (set! card-1 #f) + (set! matches (add1 matches))] + [else + ;; Not a match + (send t pause 0.5) + (send t flip-cards (list card-1 c)) + (set! card-1 #f)])])) +(send t set-single-click-action flip-and-match) + +;; The timer turns out to be the most difficult part: +(define (make-time-region secs) + (make-region time-x time-y cw time-h + (if (>= secs 6000) + "XX:XX" + (format + "~a:~a" + (substring (number->string (+ 100 (quotient secs 60))) 1) + (substring (number->string (+ 100 (modulo secs 60))) 1))) + #f)) +(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 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 +(define (show-time n) + ;; Compute new time to show: + (set! shown-seconds n) + ;; Update the time by removing the old region and adding a new one: + (send t begin-card-sequence) + (send t remove-region time-region) + (set! time-region (make-time-region shown-seconds)) + (send t add-region time-region) + (send t end-card-sequence)) +(define (get-update-delta) + ;; Figure out how many milliseconds to sleep before the next update + (max 0 (inexact->exact (floor (- (+ start-time (* 1000 shown-seconds) 1000) + (current-inexact-milliseconds)))))) +(define time-timer + (make-object timer% + (lambda () + (unless (= matches MAX-MATCHES) + (show-time + (inexact->exact + (floor (/ (- (current-inexact-milliseconds) start-time) 1000)))) + (send time-timer start (get-update-delta) #t))))) +(define (reset-timer) + (send time-timer stop) + (set! start-time #f) + (show-time 0)) +(define (run-timer) + (unless start-time + (set! start-time (current-inexact-milliseconds)) + (send time-timer start 1000 #t))) + +;; Start the game: +(send t pause 0.25) +(setup))) diff --git a/collects/games/mines/mines.ss b/collects/games/mines/mines.ss index 1744f989c0..bed9c356ce 100644 --- a/collects/games/mines/mines.ss +++ b/collects/games/mines/mines.ss @@ -3,507 +3,475 @@ ;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;; -(module mines mzscheme - - (require (lib "etc.ss") ; defines build-vector - (lib "class.ss") - (lib "unit.ss") - (lib "mred.ss" "mred") - (lib "include-bitmap.ss" "mrlib")) - - (provide game@) +#lang mzscheme - ;; Layout constants - (define TILE-HW 24) ; height/width of a tile - (define B-WIDTH 16) ; number of tiles across - (define B-HEIGHT 16) ; number of tiles down - (define THE-BOMB-COUNT 30) ; number of bombs to hide - - ;; Bitmap constants - (define tile-bm (include-bitmap "images/tile.png")) - (define lclick-bm (include-bitmap "images/lclick-tile.png")) - (define rclick-bm (include-bitmap "images/rclick-tile.png")) - (define local-bm (include-bitmap "images/local-tile.png")) - (define near-bm (include-bitmap "images/near-tile.png")) - (define bomb-bm (include-bitmap "images/bomb.png")) - (define explode-bm (include-bitmap "images/explode.png")) - (define flag-bm (include-bitmap "images/flag.png")) +(require (lib "etc.ss") ; defines build-vector + (lib "class.ss") + (lib "unit.ss") + (lib "mred.ss" "mred") + (lib "include-bitmap.ss" "mrlib")) - (define DIGIT-COLOR-NAMES - ;; 0th is background; 8th is foreground - (vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE" - "ORANGE" "YELLOW" "BROWN" "BLACK")) - - (define DIGIT-COLORS - (build-vector 9 (lambda (i) - (send the-color-database find-color - (vector-ref DIGIT-COLOR-NAMES i))))) - - (define BG-COLOR (vector-ref DIGIT-COLORS 0)) - (define FG-COLOR (vector-ref DIGIT-COLORS 8)) +(provide game@) - (define BLACK-COLOR (send the-color-database find-color "BLACK")) - - (define BG-PEN (make-object pen% BG-COLOR 1 'solid)) - (define FG-PEN (make-object pen% FG-COLOR 1 'solid)) - - ;; A function for looping over numbers: - (define (step-while first test until f accum init) - (let loop ([n first][a init]) - (if (test n until) - (loop (add1 n) (accum a (f n))) - a))) - - ;; The rest of the game is implemented in a unit so it can be started multiple times - (define game@ - (unit - (import) - (export) - - ;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;; - - ;; Class for a tile object - (define tile:plain% - (class object% - (define state 'covered) ; 'covered, 'flagged, 'semi-flagged, or 'uncovered - (define neighbor-bomb-count 0) ; 0 to 8 - (define area-hilite 'none) ; 'none, 'local, 'near - - (public* - [set-state - (lambda (newstate) - (set! state newstate))] - [get-state - (lambda () - state)] - [set-neighbor-bomb-count - (lambda (c) - (set! neighbor-bomb-count c))] - [get-neighbor-bomb-count - (lambda () - neighbor-bomb-count)] - [set-area-hilite - (lambda (mode) - (set! area-hilite mode))] - [draw-text-tile - (lambda (dc x y w h hilite border? str color) - (if border? - (send dc draw-bitmap - (case hilite - [(left) lclick-bm] - [(right) rclick-bm] - [else (case area-hilite - [(near) near-bm] - [(local) local-bm] - [else tile-bm])]) - x y) - (begin - (send dc set-pen BG-PEN) - (send dc draw-rectangle x y w h))) - (when str - (cond - [(string? str) - (send dc set-text-foreground (or color FG-COLOR)) - ;; Draw text centered in the tile's box: - (let-values ([(tw th d a) (send dc get-text-extent str)]) - (send dc draw-text str - (+ x (/ (- w tw) 2)) - (+ y (/ (- h (- th d)) 2))))] - [else - (send dc draw-bitmap str x y 'solid BLACK-COLOR - (send str get-loaded-mask))])))] - [draw - (lambda (dc x y w h hilite) - (case state - [(covered) (draw-text-tile dc x y w h hilite #t #f #f)] - [(flagged) (draw-text-tile dc x y w h hilite #t flag-bm #f)] - [(semi-flagged) (draw-text-tile dc x y w h hilite #t "?" #f)] - [(uncovered) (draw-text-tile - dc x y w h #f #f - (if (zero? neighbor-bomb-count) - #f - (number->string neighbor-bomb-count)) - (vector-ref DIGIT-COLORS neighbor-bomb-count))]))]) - - (super-instantiate ()))) - - ;; Class for a tile with a bomb underneath - (define tile:bomb% - (class tile:plain% - (inherit get-state draw-text-tile) - (define explode-source? #f) ; draw this bomb as the one that exploded? - - (public* - [set-explode-source - (lambda (s?) - (set! explode-source? s?))]) - - (override* - [draw - (lambda (dc x y w h hilite) - (if (eq? (get-state) 'uncovered) - (draw-text-tile dc x y w h #f #f - (if explode-source? explode-bm bomb-bm) #f) - (super draw dc x y w h hilite)))]) - - (super-instantiate ()))) - - (define (is-bomb? x) - (is-a? x tile:bomb%)) - - ;; ;;;;;;;;;;;;;;; Board Operations ;;;;;;;;;;;;;;;;;; - ;; A board is a vector of vectors of tiles - - (define board #f) ; initialized by calling make-board! - - (define (get-tile x y) - (vector-ref (vector-ref board x) y)) - - (define (set-tile! x y t) - (vector-set! (vector-ref board x) y t)) - - (define (do-surrounding x y accum start default f) - (step-while -1 <= 1 - (lambda (dx) - (step-while -1 <= 1 - (lambda (dy) - (if (and (not (and (zero? dx) (zero? dy))) - (< -1 (+ x dx) B-WIDTH) - (< -1 (+ y dy) B-HEIGHT)) - (f dx dy) - default)) - accum start)) - accum start)) - - (define (count-surrounding-bombs x y) - (do-surrounding - x y + 0 0 - (lambda (dx dy) - (if (is-bomb? (get-tile (+ x dx) (+ y dy))) - 1 - 0)))) - - (define (for-each-tile f) - (step-while 0 < B-WIDTH - (lambda (x) - (step-while 0 < B-HEIGHT - (lambda (y) - (f (get-tile x y) x y)) - void (void))) - void (void))) - - (define (make-board!) - ;; Create the board - (set! board - (build-vector B-WIDTH - (lambda (i) - (build-vector B-HEIGHT - (lambda (j) - (make-object tile:plain%)))))) - ;; Randomly insert bombs - (let loop ([n THE-BOMB-COUNT]) - (unless (zero? n) - (let rloop () - (let* ([x (random B-WIDTH)] - [y (random B-HEIGHT)] - [t (get-tile x y)]) - (if (is-a? t tile:bomb%) - (rloop) - (begin - (set-tile! x y (make-object tile:bomb%)) - (loop (sub1 n)))))))) - ;; Set surrounding-bomb counts for each tile: +;; Layout constants +(define TILE-HW 24) ; height/width of a tile +(define B-WIDTH 16) ; number of tiles across +(define B-HEIGHT 16) ; number of tiles down +(define THE-BOMB-COUNT 30) ; number of bombs to hide + +;; Bitmap constants +(define tile-bm (include-bitmap "images/tile.png")) +(define lclick-bm (include-bitmap "images/lclick-tile.png")) +(define rclick-bm (include-bitmap "images/rclick-tile.png")) +(define local-bm (include-bitmap "images/local-tile.png")) +(define near-bm (include-bitmap "images/near-tile.png")) +(define bomb-bm (include-bitmap "images/bomb.png")) +(define explode-bm (include-bitmap "images/explode.png")) +(define flag-bm (include-bitmap "images/flag.png")) + +(define DIGIT-COLOR-NAMES + ;; 0th is background; 8th is foreground + (vector "WHITE" "BLUE" "FORESTGREEN" "RED" "PURPLE" + "ORANGE" "YELLOW" "BROWN" "BLACK")) + +(define DIGIT-COLORS + (build-vector 9 (lambda (i) + (send the-color-database find-color + (vector-ref DIGIT-COLOR-NAMES i))))) + +(define BG-COLOR (vector-ref DIGIT-COLORS 0)) +(define FG-COLOR (vector-ref DIGIT-COLORS 8)) + +(define BLACK-COLOR (send the-color-database find-color "BLACK")) + +(define BG-PEN (make-object pen% BG-COLOR 1 'solid)) +(define FG-PEN (make-object pen% FG-COLOR 1 'solid)) + +;; A function for looping over numbers: +(define (step-while first test until f accum init) + (let loop ([n first][a init]) + (if (test n until) + (loop (add1 n) (accum a (f n))) + a))) + +;; The rest of the game is implemented in a unit so it can be started +;; multiple times +(define game@ (unit (import) (export) + +;; ;;;;;;;;;;;;;;; Tiles ;;;;;;;;;;;;;;;;;; + +;; Class for a tile object +(define tile:plain% + (class object% + (define state 'covered) ; 'covered, 'flagged, 'semi-flagged, or 'uncovered + (define neighbor-bomb-count 0) ; 0 to 8 + (define area-hilite 'none) ; 'none, 'local, 'near + + (public* + [set-state (lambda (newstate) (set! state newstate))] + [get-state (lambda () state)] + [set-neighbor-bomb-count (lambda (c) (set! neighbor-bomb-count c))] + [get-neighbor-bomb-count (lambda () neighbor-bomb-count)] + [set-area-hilite (lambda (mode) (set! area-hilite mode))] + [draw-text-tile + (lambda (dc x y w h hilite border? str color) + (if border? + (send dc draw-bitmap + (case hilite + [(left) lclick-bm] + [(right) rclick-bm] + [else (case area-hilite + [(near) near-bm] + [(local) local-bm] + [else tile-bm])]) + x y) + (begin (send dc set-pen BG-PEN) + (send dc draw-rectangle x y w h))) + (when str + (cond [(string? str) + (send dc set-text-foreground (or color FG-COLOR)) + ;; Draw text centered in the tile's box: + (let-values ([(tw th d a) (send dc get-text-extent str)]) + (send dc draw-text str + (+ x (/ (- w tw) 2)) + (+ y (/ (- h (- th d)) 2))))] + [else + (send dc draw-bitmap str x y 'solid BLACK-COLOR + (send str get-loaded-mask))])))] + [draw + (lambda (dc x y w h hilite) + (case state + [(covered) (draw-text-tile dc x y w h hilite #t #f #f)] + [(flagged) (draw-text-tile dc x y w h hilite #t flag-bm #f)] + [(semi-flagged) (draw-text-tile dc x y w h hilite #t "?" #f)] + [(uncovered) + (draw-text-tile + dc x y w h #f #f + (if (zero? neighbor-bomb-count) + #f + (number->string neighbor-bomb-count)) + (vector-ref DIGIT-COLORS neighbor-bomb-count))]))]) + + (super-instantiate ()))) + +;; Class for a tile with a bomb underneath +(define tile:bomb% + (class tile:plain% + (inherit get-state draw-text-tile) + (define explode-source? #f) ; draw this bomb as the one that exploded? + + (public* + [set-explode-source (lambda (s?) (set! explode-source? s?))]) + + (override* + [draw + (lambda (dc x y w h hilite) + (if (eq? (get-state) 'uncovered) + (draw-text-tile dc x y w h #f #f + (if explode-source? explode-bm bomb-bm) #f) + (super draw dc x y w h hilite)))]) + + (super-instantiate ()))) + +(define (is-bomb? x) + (is-a? x tile:bomb%)) + +;; ;;;;;;;;;;;;;;; Board Operations ;;;;;;;;;;;;;;;;;; +;; A board is a vector of vectors of tiles + +(define board #f) ; initialized by calling make-board! + +(define (get-tile x y) + (vector-ref (vector-ref board x) y)) + +(define (set-tile! x y t) + (vector-set! (vector-ref board x) y t)) + +(define (do-surrounding x y accum start default f) + (step-while -1 <= 1 + (lambda (dx) + (step-while -1 <= 1 + (lambda (dy) + (if (and (not (and (zero? dx) (zero? dy))) + (< -1 (+ x dx) B-WIDTH) + (< -1 (+ y dy) B-HEIGHT)) + (f dx dy) + default)) + accum start)) + accum start)) + +(define (count-surrounding-bombs x y) + (do-surrounding + x y + 0 0 + (lambda (dx dy) (if (is-bomb? (get-tile (+ x dx) (+ y dy))) 1 0)))) + +(define (for-each-tile f) + (step-while 0 < B-WIDTH + (lambda (x) + (step-while 0 < B-HEIGHT (lambda (y) (f (get-tile x y) x y)) + void (void))) + void (void))) + +(define (make-board!) + ;; Create the board + (set! board + (build-vector B-WIDTH + (lambda (i) + (build-vector B-HEIGHT + (lambda (j) (make-object tile:plain%)))))) + ;; Randomly insert bombs + (let loop ([n THE-BOMB-COUNT]) + (unless (zero? n) + (let rloop () + (let* ([x (random B-WIDTH)] + [y (random B-HEIGHT)] + [t (get-tile x y)]) + (if (is-a? t tile:bomb%) + (rloop) + (begin + (set-tile! x y (make-object tile:bomb%)) + (loop (sub1 n)))))))) + ;; Set surrounding-bomb counts for each tile: + (for-each-tile (lambda (t x y) + (send t + set-neighbor-bomb-count + (count-surrounding-bombs x y))))) + +;; ;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;; + +;; Make a frame: +(define frame + (instantiate + (class frame% + (augment* + [on-close ; stop the timer, in case it's running + (lambda () + (send board-canvas stop-timer) + (inner () on-close))]) + (super-instantiate ())) + ("Minesweeper") + [style '(no-resize-border metal)])) + +;; Make the row of controls at the top of the frame: +(define panel (make-object horizontal-panel% frame)) +(send panel stretchable-height #f) +(define (make-centering-pane parent) + (let ([p (make-object vertical-pane% parent)]) + (send p set-alignment 'center 'center) + p)) + +(define time-display + (make-object message% "Time: 00000" (make-centering-pane panel))) +(make-object button% "Reset" (make-centering-pane panel) + (lambda (b e) (send board-canvas reset))) +(define count-display + (make-object message% "Count: 000" (make-centering-pane panel))) + +(define (set-time t) + (send time-display set-label (string-append "Time: " (number->string t)))) +(define (set-count 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 +;; class for drawing the Minesweeper board and handling clicks. +(define board-canvas% + (class canvas% + (init frame) + (inherit get-dc min-client-width min-client-height + stretchable-width stretchable-height) + + (define clicking #f) ; #t => click in progress + (define clicking-x 0) ; x position of click in progress + (define clicking-y 0) ; y position of click in progress + (define clicking-right? #f) ; #t => right-click in progress + (define area-hilite #f) ; tile with mouse pointer over it + (define area-hilites null) ; tiles+locs hilited due to mouse-over + (define ready? #t) ; #t => accept clicks + (define start-time #f) ; time of first click + (define elapsed-time 0) ; seconds since first click + (define timer #f) ; a timer that updates elapsed-time + (define bomb-count THE-BOMB-COUNT) ; number of bombs minus the number of flags + (define cover-count (* B-HEIGHT B-WIDTH)) ; number of uncovered tiles + + (public* + [stop-timer ; stop the clock + (lambda () + (when timer + (send timer stop) + (set! timer #f)))] + [start-timer ; start the clock + (lambda () + (set! start-time (current-seconds)) + (set! timer + (make-object + (class timer% () + (override* + [notify + (lambda () + (let ([e (- (current-seconds) start-time)]) + (when (> e elapsed-time) + (set! elapsed-time e) + (set-time e))))]) + (super-instantiate ())))) + (send timer start 100 #f))] ; check time roughly every .1 secs + [end-of-game ; stop the game + (lambda (win?) + (stop-timer) + (set! ready? #f) + (set! start-time #f) + (unless win? (show-all-bombs)) + (set-count THE-BOMB-COUNT))] + [explode ; stop the game because the player hit a bomb + (lambda () (end-of-game #f))] + [win ; stop the game because the player won + (lambda () (end-of-game #t))] + [reset ; quit the current game and reset the board + (lambda () + (stop-timer) + (set! ready? #t) + (set! start-time #f) + (set! elapsed-time 0) + (set! cover-count (* B-HEIGHT B-WIDTH)) + (send dc clear) + (set-time 0) + (set! bomb-count THE-BOMB-COUNT) + (set-count THE-BOMB-COUNT) + (make-board!) + (on-paint))] + [show-all-bombs ; show the location of each bomb (after end-of-game) + (lambda () (for-each-tile (lambda (t x y) - (send t - set-neighbor-bomb-count - (count-surrounding-bombs x y))))) - - ;; ;;;;;;;;;;;;;;; Graphic Interface ;;;;;;;;;;;;;;;;;; - - ;; Make a frame: - (define frame (instantiate - (class frame% - (augment* - [on-close ; stop the timer, in case it's running - (lambda () - (send board-canvas stop-timer) - (inner () on-close))]) - (super-instantiate ())) - ("Minesweeper") - [style '(no-resize-border metal)])) - - ;; Make the row of controls at the top of the frame: - (define panel (make-object horizontal-panel% frame)) - (send panel stretchable-height #f) - (define (make-centering-pane parent) - (let ([p (make-object vertical-pane% parent)]) - (send p set-alignment 'center 'center) - p)) - - (define time-display (make-object message% "Time: 00000" (make-centering-pane panel))) - (make-object button% "Reset" (make-centering-pane panel) - (lambda (b e) (send board-canvas reset))) - (define count-display (make-object message% "Count: 000" (make-centering-pane panel))) - - (define (set-time t) - (send time-display set-label (string-append "Time: " (number->string t)))) - (define (set-count 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 - ;; class for drawing the Minesweeper board and handling clicks. - (define board-canvas% - (class canvas% - (init frame) - (inherit get-dc min-client-width min-client-height - stretchable-width stretchable-height) - - (define clicking #f) ; #t => click in progress - (define clicking-x 0) ; x position of click in progress - (define clicking-y 0) ; y position of click in progress - (define clicking-right? #f) ; #t => right-click in progress - (define area-hilite #f) ; tile with mouse pointer over it - (define area-hilites null) ; tiles+locs hilited due to mouse-over - (define ready? #t) ; #t => accept clicks - (define start-time #f) ; time of first click - (define elapsed-time 0) ; seconds since first click - (define timer #f) ; a timer that updates elapsed-time - (define bomb-count THE-BOMB-COUNT) ; number of bombs minus the number of flags - (define cover-count (* B-HEIGHT B-WIDTH)) ; number of uncovered tiles - - (public* - [stop-timer ; stop the clock - (lambda () - (when timer - (send timer stop) - (set! timer #f)))] - [start-timer ; start the clock - (lambda () - (set! start-time (current-seconds)) - (set! timer - (make-object - (class timer% () - (override* - [notify - (lambda () - (let ([e (- (current-seconds) start-time)]) - (when (> e elapsed-time) - (set! elapsed-time e) - (set-time e))))]) - (super-instantiate ())))) - (send timer start 100 #f))] ; check time roughly every .1 secs - [end-of-game ; stop the game - (lambda (win?) - (stop-timer) - (set! ready? #f) - (set! start-time #f) - (unless win? - (show-all-bombs)) - (set-count THE-BOMB-COUNT))] - [explode ; stop the game because the player hit a bomb - (lambda () - (end-of-game #f))] - [win ; stop the game because the player won - (lambda () - (end-of-game #t))] - [reset ; quit the current game and reset the board - (lambda () - (stop-timer) - (set! ready? #t) - (set! start-time #f) - (set! elapsed-time 0) - (set! cover-count (* B-HEIGHT B-WIDTH)) - (send dc clear) - (set-time 0) - (set! bomb-count THE-BOMB-COUNT) - (set-count THE-BOMB-COUNT) - (make-board!) - (on-paint))] - [show-all-bombs ; show the location of each bomb (after end-of-game) - (lambda () - (for-each-tile (lambda (t x y) - (when (is-bomb? t) - (change-state t (send t get-state) 'uncovered #f) - (paint-one t x y)))))] - [autoclick-surrounding ; autoclick tiles (after a 0 tile is uncovered) - (lambda (x y) - (do-surrounding - x y void (void) (void) + (when (is-bomb? t) + (change-state t (send t get-state) 'uncovered #f) + (paint-one t x y)))))] + [autoclick-surrounding ; autoclick tiles (after a 0 tile is uncovered) + (lambda (x y) + (do-surrounding + x y void (void) (void) + (lambda (dx dy) + (let* ([x2 (+ x dx)] + [y2 (+ y dy)] + [t (get-tile x2 y2)] + [state (send t get-state)] + [nc (send t get-neighbor-bomb-count)]) + (unless (eq? state 'uncovered) + (change-state t state 'uncovered #t) + (paint-one t x2 y2) + (when (zero? nc) (autoclick-surrounding x2 y2)))))))] + [change-state ; update counters after a tile changes + (lambda (t old-state new-state update-count?) + (send t set-state new-state) + (when (and update-count? (not (eq? new-state old-state))) + (when (eq? new-state 'uncovered) + (set! cover-count (sub1 cover-count))) + (when (eq? old-state 'uncovered) + (set! cover-count (add1 cover-count))) + (when (eq? new-state 'flagged) + (set! bomb-count (sub1 bomb-count)) + (set-count bomb-count)) + (when (eq? old-state 'flagged) + (set! bomb-count (add1 bomb-count)) + (set-count bomb-count))))] + [do-select ; handle a click on a tile + (lambda (x y flag?) + (let* ([t (get-tile x y)] + [state (send t get-state)] + [new-state (case state + [(covered) (if flag? 'flagged 'uncovered)] + [(flagged) (if flag? 'semi-flagged state)] + [(semi-flagged) (if flag? 'covered 'uncovered)] + [else state])] + [nc (send t get-neighbor-bomb-count)] + [new-uncover? (and (eq? new-state 'uncovered) + (not (eq? state 'uncovered)))] + [bomb? (is-bomb? t)]) + (change-state t state new-state #t) + (when (and new-uncover? bomb?) (send t set-explode-source #t)) + (paint-one t x y) + (when new-uncover? + (if bomb? + (explode) + (begin + (if (zero? nc) + (autoclick-surrounding x y) + (set-near-hilite t x y)))) + (when (and ready? (= cover-count THE-BOMB-COUNT)) (win)))))] + [paint-one ; draw one tile + (lambda (t x y) + (let ([xloc (* x TILE-HW)] + [yloc (* y TILE-HW)]) + (send t draw dc xloc yloc TILE-HW TILE-HW + (and (eq? t clicking) (if clicking-right? 'right 'left)))))] + [set-near-hilite + (lambda (t x y) + (set! area-hilite t) + (set! area-hilites + (do-surrounding + x y append null null (lambda (dx dy) - (let* ([x2 (+ x dx)] - [y2 (+ y dy)] - [t (get-tile x2 y2)] - [state (send t get-state)] - [nc (send t get-neighbor-bomb-count)]) - (unless (eq? state 'uncovered) - (change-state t state 'uncovered #t) - (paint-one t x2 y2) - (when (zero? nc) - (autoclick-surrounding x2 y2)))))))] - [change-state ; update counters after a tile changes - (lambda (t old-state new-state update-count?) - (send t set-state new-state) - (when (and update-count? (not (eq? new-state old-state))) - (when (eq? new-state 'uncovered) - (set! cover-count (sub1 cover-count))) - (when (eq? old-state 'uncovered) - (set! cover-count (add1 cover-count))) - (when (eq? new-state 'flagged) - (set! bomb-count (sub1 bomb-count)) - (set-count bomb-count)) - (when (eq? old-state 'flagged) - (set! bomb-count (add1 bomb-count)) - (set-count bomb-count))))] - [do-select ; handle a click on a tile - (lambda (x y flag?) - (let* ([t (get-tile x y)] - [state (send t get-state)] - [new-state - (case state - [(covered) - (if flag? 'flagged 'uncovered)] - [(flagged) - (if flag? 'semi-flagged state)] - [(semi-flagged) - (if flag? 'covered 'uncovered)] - [else state])] - [nc (send t get-neighbor-bomb-count)] - [new-uncover? (and (eq? new-state 'uncovered) - (not (eq? state 'uncovered)))] - [bomb? (is-bomb? t)]) - (change-state t state new-state #t) - (when (and new-uncover? bomb?) - (send t set-explode-source #t)) - (paint-one t x y) - (when new-uncover? - (if bomb? - (explode) - (begin - (if (zero? nc) - (autoclick-surrounding x y) - (set-near-hilite t x y)))) - (when (and ready? (= cover-count THE-BOMB-COUNT)) - (win)))))] - [paint-one ; draw one tile - (lambda (t x y) - (let ([xloc (* x TILE-HW)] - [yloc (* y TILE-HW)]) - (send t draw dc xloc yloc TILE-HW TILE-HW - (and (eq? t clicking) - (if clicking-right? 'right 'left)))))] - [set-near-hilite - (lambda (t x y) - (set! area-hilite t) - (set! area-hilites - (do-surrounding x y append null null - (lambda (dx dy) - (let* ([x (+ x dx)] - [y (+ y dy)] - [t (get-tile x y)]) - (if (not (eq? (send t get-state) 'uncovered)) - (begin - (send t set-area-hilite 'near) - (paint-one t x y) - (list (list t x y))) - null))))))] - [clear-area-hilite - (lambda () - (when area-hilite - (set! area-hilite #f) - (for-each (lambda (p) - (send (car p) set-area-hilite 'none) - (paint-one (car p) (cadr p) (caddr p))) - area-hilites) - (set! area-hilites null)))]) - (override* - [on-event ; handle a click - (lambda (e) - (when ready? - (unless start-time ; if the timer's not running, start it - (when (send e button-down?) - (start-timer))) - ;; Find the time for an (x,y) pixel position in the canvas - (let* ([x (quotient (inexact->exact (floor (send e get-x))) - TILE-HW)] - [y (quotient (inexact->exact (floor (send e get-y))) - TILE-HW)] - [t (if (and (< -1 x B-WIDTH) - (< -1 y B-HEIGHT)) - (get-tile x y) - #f)]) ; not a tile - (cond - [(and clicking (or (not (eq? t clicking)) - (not (or (send e button-up?) - (send e dragging?))))) - ;; We're already in the middle of a click, and the mouse - ;; was moved. Paint the tile to show whether releasing the - ;; mouse button selects the tile. - (let ([old clicking]) - (set! clicking #f) - (paint-one old clicking-x clicking-y))] - [(and t - (not (eq? (send t get-state) 'uncovered)) - (or (send e button-down?) - (and (send e dragging?) - (= x clicking-x) - (= y clicking-y)))) - ;; Start a click on a covered tile - (clear-area-hilite) - (set! clicking t) - (set! clicking-x x) - (set! clicking-y y) - (when (send e button-down?) - (set! clicking-right? (or (send e button-down? 'right) - (send e get-control-down) - (send e get-alt-down) - (send e get-meta-down)))) - (paint-one t x y)] - [(and clicking (send e button-up?)) - ;; User released the button - (set! clicking #f) - (do-select x y clicking-right?)] - [(and (not (send e leaving?)) - t - (eq? (send t get-state) 'uncovered) - (positive? (send t get-neighbor-bomb-count))) - ;; Moving over uncovered number - (unless (eq? t area-hilite) - (clear-area-hilite) - (set-near-hilite t x y))] - [(and (not (send e leaving?)) - t - (not (eq? (send t get-state) 'uncovered))) - ;; Moving over tile - (unless (eq? t area-hilite) - (clear-area-hilite) - (set! area-hilite t) - (set! area-hilites (list (list t x y))) - (send t set-area-hilite 'local) - (paint-one t x y))] - [else (clear-area-hilite)]))))] - [on-paint ; refresh the board - (lambda () - (for-each-tile (lambda (tile x y) (paint-one tile x y))))]) - - (super-instantiate (frame)) - - ;; Make canvas size always match the board size: - (min-client-width (* TILE-HW B-WIDTH)) - (min-client-height (* TILE-HW B-HEIGHT)) - (stretchable-width #f) - (stretchable-height #f) - - (define dc (get-dc)) - - (reset) ; initialize the game - (send dc set-font (make-object font% 16 'swiss 'normal 'bold #f 'default #t)) - (send dc set-text-background BG-COLOR) - (send dc set-brush (send the-brush-list find-or-create-brush - BG-COLOR 'solid)))) - - ;; Make the board canvas: - (define board-canvas (make-object board-canvas% frame)) - - ;; Show the frame (and handle events): - (send frame show #t)))) - + (let* ([x (+ x dx)] + [y (+ y dy)] + [t (get-tile x y)]) + (if (not (eq? (send t get-state) 'uncovered)) + (begin + (send t set-area-hilite 'near) + (paint-one t x y) + (list (list t x y))) + null))))))] + [clear-area-hilite + (lambda () + (when area-hilite + (set! area-hilite #f) + (for-each (lambda (p) + (send (car p) set-area-hilite 'none) + (paint-one (car p) (cadr p) (caddr p))) + area-hilites) + (set! area-hilites null)))]) + (override* + [on-event ; handle a click + (lambda (e) + (when ready? + (unless start-time ; if the timer's not running, start it + (when (send e button-down?) + (start-timer))) + ;; Find the time for an (x,y) pixel position in the canvas + (let* ([x (quotient (inexact->exact (floor (send e get-x))) TILE-HW)] + [y (quotient (inexact->exact (floor (send e get-y))) TILE-HW)] + [t (if (and (< -1 x B-WIDTH) (< -1 y B-HEIGHT)) + (get-tile x y) + #f)]) ; not a tile + (cond + [(and clicking (or (not (eq? t clicking)) + (not (or (send e button-up?) + (send e dragging?))))) + ;; We're already in the middle of a click, and the mouse + ;; was moved. Paint the tile to show whether releasing the + ;; mouse button selects the tile. + (let ([old clicking]) + (set! clicking #f) + (paint-one old clicking-x clicking-y))] + [(and t + (not (eq? (send t get-state) 'uncovered)) + (or (send e button-down?) + (and (send e dragging?) + (= x clicking-x) + (= y clicking-y)))) + ;; Start a click on a covered tile + (clear-area-hilite) + (set! clicking t) + (set! clicking-x x) + (set! clicking-y y) + (when (send e button-down?) + (set! clicking-right? + (or (send e button-down? 'right) + (send e get-control-down) + (send e get-alt-down) + (send e get-meta-down)))) + (paint-one t x y)] + [(and clicking (send e button-up?)) + ;; User released the button + (set! clicking #f) + (do-select x y clicking-right?)] + [(and (not (send e leaving?)) + t + (eq? (send t get-state) 'uncovered) + (positive? (send t get-neighbor-bomb-count))) + ;; Moving over uncovered number + (unless (eq? t area-hilite) + (clear-area-hilite) + (set-near-hilite t x y))] + [(and (not (send e leaving?)) + t + (not (eq? (send t get-state) 'uncovered))) + ;; Moving over tile + (unless (eq? t area-hilite) + (clear-area-hilite) + (set! area-hilite t) + (set! area-hilites (list (list t x y))) + (send t set-area-hilite 'local) + (paint-one t x y))] + [else (clear-area-hilite)]))))] + [on-paint ; refresh the board + (lambda () (for-each-tile (lambda (tile x y) (paint-one tile x y))))]) + + (super-instantiate (frame)) + + ;; Make canvas size always match the board size: + (min-client-width (* TILE-HW B-WIDTH)) + (min-client-height (* TILE-HW B-HEIGHT)) + (stretchable-width #f) + (stretchable-height #f) + + (define dc (get-dc)) + + (reset) ; initialize the game + (send dc set-font (make-object font% 16 'swiss 'normal 'bold #f 'default #t)) + (send dc set-text-background BG-COLOR) + (send dc set-brush (send the-brush-list find-or-create-brush + BG-COLOR 'solid)))) + +;; Make the board canvas: +(define board-canvas (make-object board-canvas% frame)) + +;; Show the frame (and handle events): +(send frame show #t))) diff --git a/collects/games/paint-by-numbers/doc.txt b/collects/games/paint-by-numbers/doc.txt index 1dd1be205a..eb4113ae52 100644 --- a/collects/games/paint-by-numbers/doc.txt +++ b/collects/games/paint-by-numbers/doc.txt @@ -1,35 +1,37 @@ -** To play _Paint By Numbers_, run the "Games" application. ** +** To play Paint By Numbers, run the "PLT Games" application. The object of Paint By Numbers is to discover which cells should be -colored blue and which should be colored white. Initially, all squares are -grey, indicating that the correct colors are not known. The lists of -numbers to the left and above the grid are your clues to the correct color -of each square. Each list of numbers specifies the pattern of blue squares -in the row beside it or the column below it. Each number indicates the -length of a group of blue squares. For example, if the list of numbers -beside the first row is "2 3" then you know that there is a contiguous -block of two blue squares followed by a contiguous block of three blue -squares with at least one white square between them. The label does not -tell you where the blue squares are, only their shapes. The trick is to -gather as much information as you can about each row, and then use that -information to determine more about each column. Eventually you should be -able to fill in the entire puzzle. +colored blue and which should be colored white. Initially, all +squares are grey, indicating that the correct colors are not known. +The lists of numbers to the left and above the grid are your clues to +the correct color of each square. Each list of numbers specifies the +pattern of blue squares in the row beside it or the column below it. +Each number indicates the length of a group of blue squares. For +example, if the list of numbers beside the first row is "2 3" then you +know that there is a contiguous block of two blue squares followed by +a contiguous block of three blue squares with at least one white +square between them. The label does not tell you where the blue +squares are, only their shapes. The trick is to gather as much +information as you can about each row, and then use that information +to determine more about each column. Eventually you should be able to +fill in the entire puzzle. -Click on a square to toggle it between blue and gray. Hold down a modifier -key (shift, command, meta, or alt depending on the platform) to toggle a -square between white and gray. The third button under unix and the right -button under windows also toggles between white and gray. +Click on a square to toggle it between blue and gray. Hold down a +modifier key (shift, command, meta, or alt depending on the platform) +to toggle a square between white and gray. The third button under +unix and the right button under windows also toggles between white and +gray. -For some puzzles, hints are available. Choose the Nongram|Show Mistakes -menu item to receive the hints. This will turn all incorrectly colored -squares red. +For some puzzles, hints are available. Choose the Nongram|Show +Mistakes menu item to receive the hints. This will turn all +incorrectly colored squares red. -Thanks to Shoichiro Hattori for his puzzles! Visit him on the web at: +Thanks to Shoichiro Hattori for his puzzles! Visit him on the web at: http://hattori.m78.com/puzzle/ Thanks also to many of the contributors to the Kajitani web site for -permission to re-distribute their puzzles. Visit them online at: +permission to re-distribute their puzzles. Visit them online at: http://www02.so-net.ne.jp/~kajitani/index.html diff --git a/collects/games/parcheesi/doc.txt b/collects/games/parcheesi/doc.txt index 9683ad5eb0..cbe8b8ef84 100644 --- a/collects/games/parcheesi/doc.txt +++ b/collects/games/parcheesi/doc.txt @@ -1,52 +1,47 @@ -_Parcheesi_ +** To play Parcheesi, run the "PLT Games" application. -Parcheesi is a race game for four players. The goal is for -each player to move their pieces from the starting position -(the circles in the corners) to the home square (in the -center of the board), passing a nearly complete loop around -the board in the counter-clockwise direction and then heads -up towards the main row. For example, the green player -enters from the bottom right, travels around the board on -the light blue squares, passing each of the corners, until -it reaches the middle of the bottom of the board, where it -turns off the light blue squares and heads into the central -region. +Parcheesi is a race game for four players. The goal is for each +player to move their pieces from the starting position (the circles in +the corners) to the home square (in the center of the board), passing +a nearly complete loop around the board in the counter-clockwise +direction and then heads up towards the main row. For example, the +green player enters from the bottom right, travels around the board on +the light blue squares, passing each of the corners, until it reaches +the middle of the bottom of the board, where it turns off the light +blue squares and heads into the central region. -On each turn, the player rolls two dice and advances the -pawn, based on the die rolls. Typically the players may move -a pawn for each die. The pawn moves by the number of pips -showing on the die and all of the dice must be used to -complete a turn. +On each turn, the player rolls two dice and advances the pawn, based +on the die rolls. Typically the players may move a pawn for each die. +The pawn moves by the number of pips showing on the die and all of the +dice must be used to complete a turn. There are some exceptions, however: - - you must roll a 5 (either directly or via summing) to - enter from the start area to the main ring. + - you must roll a 5 (either directly or via summing) to enter from + the start area to the main ring. - - if two pieces of the same color occupy a square, no - pieces may pass that square. + - if two pieces of the same color occupy a square, no pieces may + pass that square. - - if an opponent's piece lands on your piece, you piece is - returned to the starting area and the opponent receives - a bonus of 20 (which is treated just as if they had - rolled a 20 on the dice) + - if an opponent's piece lands on your piece, you piece is returned + to the starting area and the opponent receives a bonus of 20 + (which is treated just as if they had rolled a 20 on the dice). - - if your piece makes it home (and it must do so by exact - count) you get a bonus of 10, to be used as an - additional die roll. + - if your piece makes it home (and it must do so by exact count) you + get a bonus of 10, to be used as an additional die roll. -These rules induce a number of unexpected corner cases, but -the GUI only lets you make legal moves. Watch the space -along the bottom of the board for reasons why a move is -illegal or why you have not used all of your die rolls. +These rules induce a number of unexpected corner cases, but the GUI +only lets you make legal moves. Watch the space along the bottom of +the board for reasons why a move is illegal or why you have not used +all of your die rolls. The automated players are: - - Reckless Renee, who she tries to maximize the chances - that someone else bops her. + - Reckless Renee, who she tries to maximize the chances that someone + else bops her. - - Polite Polly, who tries to minimize the distance her - pawns move ("no, after _you_. I insist."), and + - Polite Polly, who tries to minimize the distance her pawns move + ("no, after _you_. I insist."), and - - Amazing Grace, who tries to minimize the chance she gets - bopped while moving as far as possible. + - Amazing Grace, who tries to minimize the chance she gets bopped + while moving as far as possible. diff --git a/collects/games/pousse/doc.txt b/collects/games/pousse/doc.txt index 787b702200..0b8b28eab7 100644 --- a/collects/games/pousse/doc.txt +++ b/collects/games/pousse/doc.txt @@ -1,4 +1,4 @@ -To play _Pousse_, run the "Games" application. +** To play Pousse, run the "PLT Games" application. Pousse (French for "push", pronounced "poo-ss") is a 2 person game, played on an N by N board (usually 4x4). Initially the board is @@ -32,13 +32,13 @@ Note that the last marker of the row or column will be pushed off the board (and must be removed from play) if there are no empty squares on the insertion row or column. -A row or a column is a "straight" of a given color, if it contains -N markers of the given color. +A row or a column is a "straight" of a given color, if it contains N +markers of the given color. The game ends either when an insertion -1) repeats a previous configuration of the board; in this case - the player who inserted the marker LOSES. +1) repeats a previous configuration of the board; in this case the + player who inserted the marker LOSES. 2) creates a configuration with more straights of one color than straights of the other color; the player whose color is dominant diff --git a/collects/games/same/doc.txt b/collects/games/same/doc.txt index a195809ccf..c662a60ea2 100644 --- a/collects/games/same/doc.txt +++ b/collects/games/same/doc.txt @@ -1,18 +1,18 @@ -** To play _Same_, run the Games application. ** +** To play Same, run the "PLT Games" application. -The object of Same is to score points by removing dots from the -board. To remove a dot, click on it. As long as there is another dot -of the same color next to the clicked dot, it will disappear along -with all adjacent dots of the same color. After the dots disappear, -dots in the rows above the deleted dots will fall into the vacated -spaces. If an entire column is wiped out, all of the dots from the -right will slide left to take up the empty column's space. +The object of Same is to score points by removing dots from the board. +To remove a dot, click on it. As long as there is another dot of the +same color next to the clicked dot, it will disappear along with all +adjacent dots of the same color. After the dots disappear, dots in +the rows above the deleted dots will fall into the vacated spaces. If +an entire column is wiped out, all of the dots from the right will +slide left to take up the empty column's space. -Your score increases for each ball removed from the board. The score -for each click is a function of the number of balls that -disappeared. The "This Click" label shows how many points you would -score for clicking the dots underneath the mouse pointer. The score -varies quadratically with the number of balls, so eliminating many -balls with one click is advantageous. +Your score increases for each ball removed from the board. The score +for each click is a function of the number of balls that disappeared. +The "This Click" label shows how many points you would score for +clicking the dots underneath the mouse pointer. The score varies +quadratically with the number of balls, so eliminating many balls with +one click is advantageous. -Click the New Game button to play again. +Click the New Game button to play again. diff --git a/collects/games/slidey/slidey.ss b/collects/games/slidey/slidey.ss index e581ce96a5..dd380b1139 100644 --- a/collects/games/slidey/slidey.ss +++ b/collects/games/slidey/slidey.ss @@ -1,358 +1,318 @@ +#lang mzscheme +(require (lib "etc.ss") + (lib "class.ss") + (lib "unit.ss") + (lib "mred.ss" "mred")) -(module slidey mzscheme - (require (lib "etc.ss") - (lib "class.ss") - (lib "unit.ss") - (lib "mred.ss" "mred")) - - (provide game@) - - (define game@ - (unit - (import) - (export) - - (define (get-bitmap bitmap) - (define f (make-object dialog% "Choose Size" #f #f #f #f #f '(resize-border))) - (define bm-panel (make-object vertical-panel% f)) - (define bm-message (make-object message% bitmap bm-panel)) - (define size-message (make-object message% - (format "Image size: ~a x ~a pixels" - (send bitmap get-width) - (send bitmap get-height)) - bm-panel)) - (define wide-panel (make-object vertical-panel% f '(border))) - (define sw (make-object slider% "Tiles (width)" 2 30 wide-panel - (lambda (_1 _2) - (update-horizontal-cutoff)))) - (define tall-panel (make-object vertical-panel% f '(border))) - (define sh (make-object slider% "Tiles (height)" 2 30 tall-panel - (lambda (_1 _2) - (update-vertical-cutoff)))) - (define button-panel (make-object horizontal-panel% f)) - - (define cancelled? #t) - - (define cancel (make-object button% "Cancel" button-panel (lambda (_1 _2) (send f show #f)))) - (define ok (make-object button% "OK" button-panel (lambda (_1 _2) - (set! cancelled? #f) - (send f show #f)) '(border))) - - (define vertical-cutoff 0) - (define vertical-cutoff-message (make-object message% "" tall-panel)) - - (define horizontal-cutoff 0) - (define horizontal-cutoff-message (make-object message% "" wide-panel)) - - (define (update-vertical-cutoff) - (set! vertical-cutoff (modulo (send bitmap get-height) (send sh get-value))) - (send vertical-cutoff-message set-label - (if (= 0 vertical-cutoff) - "" - (format "Vertical cutoff ~a pixels" vertical-cutoff)))) - (define (update-horizontal-cutoff) - (set! horizontal-cutoff (modulo (send bitmap get-width) (send sw get-value))) - (send horizontal-cutoff-message set-label - (if (= 0 horizontal-cutoff) - "" - (format "Horizontal cutoff ~a pixels" horizontal-cutoff)))) - - (send horizontal-cutoff-message stretchable-width #t) - (send vertical-cutoff-message stretchable-width #t) - (update-vertical-cutoff) - (update-horizontal-cutoff) - (send button-panel set-alignment 'right 'center) - (send button-panel stretchable-height #f) - (send bm-panel set-alignment 'center 'center) - (send wide-panel stretchable-height #f) - (send tall-panel stretchable-height #f) - (make-object grow-box-spacer-pane% button-panel) - (send f show #t) - - (if cancelled? - (values #f #f #f) - (let* ([nb (make-object bitmap% - (- (send bitmap get-width) horizontal-cutoff) - (- (send bitmap get-height) vertical-cutoff))] - [bdc (make-object bitmap-dc% nb)]) - (send bdc draw-bitmap-section bitmap 0 0 0 0 - (- (send bitmap get-width) horizontal-cutoff) - (- (send bitmap get-height) vertical-cutoff)) - (send bdc set-bitmap #f) - (values nb (send sw get-value) (send sh get-value))))) - - (define-struct loc (x y)) - ;; board = (vector-of (vector-of (union #f (make-loc n1 n2)))) - - ;; need to make sure that the bitmap divides nicely - ;(define bitmap (make-object bitmap% (build-path (collection-path "games" "slidey") "11.jpg"))) - ;(define board-width 6) - ;(define board-height 5) - - (define (board-for-each board f) - (let loop ([i (vector-length board)]) - (cond - [(zero? i) (void)] - [else - (let ([row (vector-ref board (- i 1))]) - (let loop ([j (vector-length row)]) - (cond - [(zero? j) (void)] - [else - (f (- i 1) (- j 1) (vector-ref row (- j 1))) - (loop (- j 1))]))) - (loop (- i 1))]))) - - (define (move-one board from-i from-j to-i to-j) - (let ([from-save (board-ref board from-i from-j)] - [to-save (board-ref board to-i to-j)]) - (board-set! board from-i from-j to-save) - (board-set! board to-i to-j from-save))) - - (define (board-set! board i j v) - (vector-set! (vector-ref board i) j v)) - (define (board-ref board i j) - (vector-ref (vector-ref board i) j)) - - (define (get-board-width board) - (vector-length board)) - (define (get-board-height board) - (vector-length (vector-ref board 0))) - - (define (randomize-board board hole-i hole-j) - (let ([board-width (get-board-width board)] - [board-height (get-board-height board)]) - (let loop ([no-good #f] - [i (* 10 board-width board-height)] - [m-hole-i hole-i] - [m-hole-j hole-j]) - (cond - [(zero? i) ;; move hole back to last spot - (let ([i-diff (abs (- m-hole-i hole-i))]) - (let loop ([i 0]) - (unless (= i i-diff) - (move-one - board - (+ m-hole-i i) - m-hole-j - (+ m-hole-i i (if (< m-hole-i hole-i) +1 -1)) - m-hole-j) - (loop (+ i 1))))) - (let ([j-diff (abs (- m-hole-j hole-j))]) - (let loop ([j 0]) - (unless (= j j-diff) - (move-one - board - hole-i - (+ m-hole-j j) - hole-i - (+ m-hole-j j (if (< m-hole-j hole-j) +1 -1))) - (loop (+ j 1)))))] - [else - (let ([this-dir (get-random-number 4 no-good)]) - (let-values ([(new-i new-j) - (case this-dir - ; up - [(0) (values (- m-hole-i 1) m-hole-j)] - [(1) (values (+ m-hole-i 1) m-hole-j)] - [(2) (values m-hole-i (- m-hole-j 1))] - [(3) (values m-hole-i (+ m-hole-j 1))])]) - (if (and (<= 0 new-i) - (< new-i board-width) - (<= 0 new-j) - (< new-j board-height)) - (let ([next-no-good - (case this-dir - [(0) 1] - [(1) 0] - [(2) 3] - [(3) 2])]) - (move-one board new-i new-j m-hole-i m-hole-j) - (loop next-no-good (- i 1) new-i new-j)) - (loop no-good (- i 1) m-hole-i m-hole-j))))])))) - - (define (get-random-number bound no-good) - (let ([raw (random (- bound 1))]) - (cond - [(not no-good) raw] - [(< raw no-good) raw] - [else (+ raw 1)]))) - - (define line-brush (send the-brush-list find-or-create-brush "black" 'transparent)) - (define line-pen (send the-pen-list find-or-create-pen "white" 1 'solid)) - (define mistake-brush (send the-brush-list find-or-create-brush "black" 'transparent)) - (define mistake-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) - (define pict-brush (send the-brush-list find-or-create-brush "black" 'solid)) - (define pict-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) - (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% - (class canvas% - (init-field bitmap board-width board-height) - - (define show-mistakes? #f) - (define/public (show-mistakes nv) - (set! show-mistakes? nv) - (unless solved? - (on-paint))) - - (define solved? #f) - - (define board - (build-vector - board-width - (lambda (i) - (build-vector - board-height - (lambda (j) - (make-loc i j)))))) - (define hole-i (- board-width 1)) - (define hole-j (- board-height 1)) - (board-set! board hole-i hole-j #f) - - (define/override (on-paint) - (if solved? - (send (get-dc) draw-bitmap bitmap 0 0) - (board-for-each - board - (lambda (i j v) - (draw-cell i j))))) +(provide game@) - (define/override (on-event evt) - (unless solved? - (cond - [(send evt button-down? 'left) - (let-values ([(i j) (xy->ij (send evt get-x) (send evt get-y))]) - (slide i j))] - [else (void)]))) - (inherit get-client-size get-dc) - - (define/private (check-end-condition) - (let ([answer #t]) - (board-for-each - board - (lambda (i j v) - (when v - (unless (and (= i (loc-x v)) - (= j (loc-y v))) - (set! answer #f))))) - (when answer - (set! solved? #t)))) - - (define/private (slide i j) - (cond - [(= j hole-j) - (let loop ([new-hole-i hole-i]) - (cond - [(= new-hole-i i) (void)] - [else - (let ([next (if (< i hole-i) - sub1 - add1)]) - (move-one board (next new-hole-i) hole-j new-hole-i hole-j) - (draw-cell new-hole-i hole-j) - (draw-cell (next new-hole-i) hole-j) - (loop (next new-hole-i)))])) - (set! hole-i i) - (check-end-condition) - (when solved? - (on-paint))] - [(= i hole-i) - (let loop ([new-hole-j hole-j]) - (cond - [(= new-hole-j j) (void)] - [else - (let ([next (if (< j hole-j) - sub1 - add1)]) - (move-one board hole-i (next new-hole-j) hole-i new-hole-j) - (draw-cell hole-i new-hole-j) - (draw-cell hole-i (next new-hole-j)) - (loop (next new-hole-j)))])) - (set! hole-j j) - (check-end-condition) - (when solved? - (on-paint))] - [else (void)])) - - (define/private (xy->ij x y) - (let-values ([(w h) (get-client-size)]) - (values - (inexact->exact (floor (* board-width (/ x w)))) - (inexact->exact (floor (* board-height (/ y h))))))) - - (define/private (ij->xywh i j) - (let-values ([(w h) (get-client-size)]) - (let ([cell-w (/ w board-width)] - [cell-h (/ h board-height)]) - (values (* i cell-w) - (* j cell-h) - cell-w - cell-h)))) - (define/private (draw-cell draw-i draw-j) - (let-values ([(xd yd wd hd) (ij->xywh draw-i draw-j)]) - (let* ([dc (get-dc)] - [indicies (board-ref board draw-i draw-j)]) - (if indicies - (let ([bm-i (loc-x indicies)] - [bm-j (loc-y indicies)]) - (let-values ([(xs ys ws hs) (ij->xywh bm-i bm-j)]) - (send dc set-pen pict-pen) - (send dc set-brush pict-brush) - (send dc draw-bitmap-section bitmap xd yd xs ys wd hd) - (if (and show-mistakes? - (or (not (= draw-i bm-i)) - (not (= draw-j bm-j)))) - (begin - (send dc set-pen mistake-pen) - (send dc set-brush mistake-brush)) - (begin - (send dc set-pen line-pen) - (send dc set-brush line-brush))) - (send dc draw-rectangle xd yd wd hd))) - (begin - (send dc set-pen white-pen) - (send dc set-brush white-brush) - (send dc draw-rectangle xd yd wd hd)))))) - - (inherit stretchable-width stretchable-height min-client-width min-client-height) - (super-instantiate ()) - (randomize-board board hole-i hole-j) - (stretchable-width #f) - (stretchable-height #f) - (min-client-width (send bitmap get-width)) - (min-client-height (send bitmap get-height)))) - - (define f (make-object frame% "Slidey")) - (define p (make-object horizontal-panel% f)) - (send p set-alignment 'center 'center) - (define slidey-canvas (make-object slidey-canvas% - (make-object bitmap% - (build-path (collection-path "games" "slidey") "11.jpg")) - 6 6 p)) - (define bp (make-object horizontal-panel% f)) - (send bp stretchable-height #f) - (define show-mistakes - (make-object check-box% "Show misplaced pieces" bp - (lambda ___ (send slidey-canvas show-mistakes (send show-mistakes get-value))))) - (make-object grow-box-spacer-pane% bp) - - (define (change-bitmap) - (let ([fn (get-file)]) - (when fn - (let ([bm (make-object bitmap% fn)]) - (cond - [(send bm ok?) - (let-values ([(bitmap w h) (get-bitmap bm)]) - (when bitmap - (send p change-children (lambda (l) null)) - (set! slidey-canvas (make-object slidey-canvas% bitmap w h p))))] +(define game@ (unit (import) (export) + +(define (get-bitmap bitmap) + (define f (make-object dialog% "Choose Size" #f #f #f #f #f '(resize-border))) + (define bm-panel (make-object vertical-panel% f)) + (define bm-message (make-object message% bitmap bm-panel)) + (define size-message + (make-object message% (format "Image size: ~a x ~a pixels" + (send bitmap get-width) + (send bitmap get-height)) + bm-panel)) + (define wide-panel (make-object vertical-panel% f '(border))) + (define sw (make-object slider% "Tiles (width)" 2 30 wide-panel + (lambda (_1 _2) (update-horizontal-cutoff)))) + (define tall-panel (make-object vertical-panel% f '(border))) + (define sh (make-object slider% "Tiles (height)" 2 30 tall-panel + (lambda (_1 _2) (update-vertical-cutoff)))) + (define button-panel (make-object horizontal-panel% f)) + + (define cancelled? #t) + + (define cancel (make-object button% "Cancel" button-panel + (lambda (_1 _2) (send f show #f)))) + (define ok (make-object button% "OK" button-panel + (lambda (_1 _2) + (set! cancelled? #f) + (send f show #f)) '(border))) + + (define vertical-cutoff 0) + (define vertical-cutoff-message (make-object message% "" tall-panel)) + + (define horizontal-cutoff 0) + (define horizontal-cutoff-message (make-object message% "" wide-panel)) + + (define (update-vertical-cutoff) + (set! vertical-cutoff (modulo (send bitmap get-height) (send sh get-value))) + (send vertical-cutoff-message set-label + (if (= 0 vertical-cutoff) + "" + (format "Vertical cutoff ~a pixels" vertical-cutoff)))) + (define (update-horizontal-cutoff) + (set! horizontal-cutoff (modulo (send bitmap get-width) (send sw get-value))) + (send horizontal-cutoff-message set-label + (if (= 0 horizontal-cutoff) + "" + (format "Horizontal cutoff ~a pixels" horizontal-cutoff)))) + + (send horizontal-cutoff-message stretchable-width #t) + (send vertical-cutoff-message stretchable-width #t) + (update-vertical-cutoff) + (update-horizontal-cutoff) + (send button-panel set-alignment 'right 'center) + (send button-panel stretchable-height #f) + (send bm-panel set-alignment 'center 'center) + (send wide-panel stretchable-height #f) + (send tall-panel stretchable-height #f) + (make-object grow-box-spacer-pane% button-panel) + (send f show #t) + + (if cancelled? + (values #f #f #f) + (let* ([nb (make-object bitmap% + (- (send bitmap get-width) horizontal-cutoff) + (- (send bitmap get-height) vertical-cutoff))] + [bdc (make-object bitmap-dc% nb)]) + (send bdc draw-bitmap-section bitmap 0 0 0 0 + (- (send bitmap get-width) horizontal-cutoff) + (- (send bitmap get-height) vertical-cutoff)) + (send bdc set-bitmap #f) + (values nb (send sw get-value) (send sh get-value))))) + +(define-struct loc (x y)) +;; board = (vector-of (vector-of (union #f (make-loc n1 n2)))) + +;; need to make sure that the bitmap divides nicely +;;(define bitmap (make-object bitmap% (build-path (collection-path "games" "slidey") "11.jpg"))) +;;(define board-width 6) +;;(define board-height 5) + +(define (board-for-each board f) + (let loop ([i (vector-length board)]) + (unless (zero? i) + (let ([row (vector-ref board (- i 1))]) + (let loop ([j (vector-length row)]) + (unless (zero? j) + (f (- i 1) (- j 1) (vector-ref row (- j 1))) + (loop (- j 1))))) + (loop (- i 1))))) + +(define (move-one board from-i from-j to-i to-j) + (let ([from-save (board-ref board from-i from-j)] + [to-save (board-ref board to-i to-j)]) + (board-set! board from-i from-j to-save) + (board-set! board to-i to-j from-save))) + +(define (board-set! board i j v) + (vector-set! (vector-ref board i) j v)) +(define (board-ref board i j) + (vector-ref (vector-ref board i) j)) + +(define (get-board-width board) + (vector-length board)) +(define (get-board-height board) + (vector-length (vector-ref board 0))) + +(define (randomize-board board hole-i hole-j) + (let ([board-width (get-board-width board)] + [board-height (get-board-height board)]) + (let loop ([no-good #f] + [i (* 10 board-width board-height)] + [m-hole-i hole-i] + [m-hole-j hole-j]) + (cond + [(zero? i) ;; move hole back to last spot + (let ([i-diff (abs (- m-hole-i hole-i))]) + (let loop ([i 0]) + (unless (= i i-diff) + (move-one board (+ m-hole-i i) + m-hole-j (+ m-hole-i i (if (< m-hole-i hole-i) +1 -1)) + m-hole-j) + (loop (+ i 1))))) + (let ([j-diff (abs (- m-hole-j hole-j))]) + (let loop ([j 0]) + (unless (= j j-diff) + (move-one board hole-i (+ m-hole-j j) + hole-i (+ m-hole-j j (if (< m-hole-j hole-j) +1 -1))) + (loop (+ j 1)))))] + [else + (let ([this-dir (get-random-number 4 no-good)]) + (let-values ([(new-i new-j) + (case this-dir + ;; up + [(0) (values (- m-hole-i 1) m-hole-j)] + [(1) (values (+ m-hole-i 1) m-hole-j)] + [(2) (values m-hole-i (- m-hole-j 1))] + [(3) (values m-hole-i (+ m-hole-j 1))])]) + (if (and (<= 0 new-i) + (< new-i board-width) + (<= 0 new-j) + (< new-j board-height)) + (let ([next-no-good + (case this-dir [(0) 1] [(1) 0] [(2) 3] [(3) 2])]) + (move-one board new-i new-j m-hole-i m-hole-j) + (loop next-no-good (- i 1) new-i new-j)) + (loop no-good (- i 1) m-hole-i m-hole-j))))])))) + +(define (get-random-number bound no-good) + (let ([raw (random (- bound 1))]) + (cond [(not no-good) raw] + [(< raw no-good) raw] + [else (+ raw 1)]))) + +(define line-brush + (send the-brush-list find-or-create-brush "black" 'transparent)) +(define line-pen (send the-pen-list find-or-create-pen "white" 1 'solid)) +(define mistake-brush + (send the-brush-list find-or-create-brush "black" 'transparent)) +(define mistake-pen (send the-pen-list find-or-create-pen "red" 1 'solid)) +(define pict-brush (send the-brush-list find-or-create-brush "black" 'solid)) +(define pict-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) +(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% + (class canvas% + (init-field bitmap board-width board-height) + + (define show-mistakes? #f) + (define/public (show-mistakes nv) + (set! show-mistakes? nv) + (unless solved? (on-paint))) + + (define solved? #f) + + (define board + (build-vector + board-width + (lambda (i) (build-vector board-height (lambda (j) (make-loc i j)))))) + (define hole-i (- board-width 1)) + (define hole-j (- board-height 1)) + (board-set! board hole-i hole-j #f) + + (define/override (on-paint) + (if solved? + (send (get-dc) draw-bitmap bitmap 0 0) + (board-for-each board (lambda (i j v) (draw-cell i j))))) + + (define/override (on-event evt) + (unless solved? + (when (send evt button-down? 'left) + (let-values ([(i j) (xy->ij (send evt get-x) (send evt get-y))]) + (slide i j))))) + (inherit get-client-size get-dc) + + (define/private (check-end-condition) + (let ([answer #t]) + (board-for-each + board + (lambda (i j v) + (when v + (unless (and (= i (loc-x v)) (= j (loc-y v))) + (set! answer #f))))) + (when answer (set! solved? #t)))) + + (define/private (slide i j) + (cond + [(= j hole-j) + (let loop ([new-hole-i hole-i]) + (unless (= new-hole-i i) + (let ([next (if (< i hole-i) sub1 add1)]) + (move-one board (next new-hole-i) hole-j new-hole-i hole-j) + (draw-cell new-hole-i hole-j) + (draw-cell (next new-hole-i) hole-j) + (loop (next new-hole-i))))) + (set! hole-i i) + (check-end-condition) + (when solved? (on-paint))] + [(= i hole-i) + (let loop ([new-hole-j hole-j]) + (unless (= new-hole-j j) + (let ([next (if (< j hole-j) + sub1 + add1)]) + (move-one board hole-i (next new-hole-j) hole-i new-hole-j) + (draw-cell hole-i new-hole-j) + (draw-cell hole-i (next new-hole-j)) + (loop (next new-hole-j))))) + (set! hole-j j) + (check-end-condition) + (when solved? + (on-paint))] + [else (void)])) + + (define/private (xy->ij x y) + (let-values ([(w h) (get-client-size)]) + (values (inexact->exact (floor (* board-width (/ x w)))) + (inexact->exact (floor (* board-height (/ y h))))))) + + (define/private (ij->xywh i j) + (let-values ([(w h) (get-client-size)]) + (let ([cell-w (/ w board-width)] + [cell-h (/ h board-height)]) + (values (* i cell-w) (* j cell-h) cell-w cell-h)))) + (define/private (draw-cell draw-i draw-j) + (let-values ([(xd yd wd hd) (ij->xywh draw-i draw-j)]) + (let* ([dc (get-dc)] + [indicies (board-ref board draw-i draw-j)]) + (if indicies + (let ([bm-i (loc-x indicies)] + [bm-j (loc-y indicies)]) + (let-values ([(xs ys ws hs) (ij->xywh bm-i bm-j)]) + (send dc set-pen pict-pen) + (send dc set-brush pict-brush) + (send dc draw-bitmap-section bitmap xd yd xs ys wd hd) + (if (and show-mistakes? + (or (not (= draw-i bm-i)) + (not (= draw-j bm-j)))) + (begin (send dc set-pen mistake-pen) + (send dc set-brush mistake-brush)) + (begin (send dc set-pen line-pen) + (send dc set-brush line-brush))) + (send dc draw-rectangle xd yd wd hd))) + (begin (send dc set-pen white-pen) + (send dc set-brush white-brush) + (send dc draw-rectangle xd yd wd hd)))))) + + (inherit stretchable-width stretchable-height + min-client-width min-client-height) + (super-instantiate ()) + (randomize-board board hole-i hole-j) + (stretchable-width #f) + (stretchable-height #f) + (min-client-width (send bitmap get-width)) + (min-client-height (send bitmap get-height)))) + +(define f (make-object frame% "Slidey")) +(define p (make-object horizontal-panel% f)) +(send p set-alignment 'center 'center) +(define slidey-canvas + (make-object slidey-canvas% + (make-object bitmap% + (build-path (collection-path "games" "slidey") "11.jpg")) + 6 6 p)) +(define bp (make-object horizontal-panel% f)) +(send bp stretchable-height #f) +(define show-mistakes + (make-object check-box% "Show misplaced pieces" bp + (lambda ___ (send slidey-canvas show-mistakes (send show-mistakes get-value))))) +(make-object grow-box-spacer-pane% bp) + +(define (change-bitmap) + (let ([fn (get-file)]) + (when fn + (let ([bm (make-object bitmap% fn)]) + (cond + [(send bm ok?) + (let-values ([(bitmap w h) (get-bitmap bm)]) + (when bitmap + (send p change-children (lambda (l) null)) + (set! slidey-canvas (make-object slidey-canvas% bitmap w h p))))] [else (message-box "Slidey" (format "Unrecognized image format: ~a" fn))]))))) - - (define mb (make-object menu-bar% f)) - (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% "Close Window" file-menu (lambda (_1 _2) (send f show #f)) #\w) - - (send f show #t)))) + +(define mb (make-object menu-bar% f)) +(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% "Close Window" file-menu (lambda (_1 _2) (send f show #f)) #\w) + +(send f show #t) + +)) diff --git a/collects/games/spider/doc.txt b/collects/games/spider/doc.txt index ee1e55ce3b..34b02005b4 100644 --- a/collects/games/spider/doc.txt +++ b/collects/games/spider/doc.txt @@ -1,30 +1,30 @@ -** To play _Spider_, run the "Games" application. ** +** To play Spider, run the "PLT Games" application. -Spider is a solitaire card game played with 104 cards. The cards can -include either a single suit, two suits, or four suites. (Choose your +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 variant through the "Options" item in the "Edit" menu.) Terminology: - * Tableau: one of the ten stacks of cards in the play area. The game + * Tableau: one of the ten stacks of cards in the play area. The game starts with six cards in the first four tableaus, and five cards in the rest; only the topmost card is face up, and others are revealed when they become the topmost card of the tableau. * Sequence: a group of cards on the top of a tableau that are in the same suit, and that are in sequence, with the lowest numbered card - topmost (i.e., closer to the bottom of the screen). King is high + topmost (i.e., closer to the bottom of the screen). King is high and ace is low. The object of the game is to create a sequence with ace through king, -at which point the sequence is removed from play. Create eight such +at which point the sequence is removed from play. Create eight such sequences to win the game. On each move, you can either: * Move a sequence from any tableau to one whose topmost card (i.e., closest to the bottom of the screen) has a value that's one more - than the sequence's value. Note that if the top card of the target + than the sequence's value. Note that if the top card of the target tableau has the same suit as the sequence, a larger sequence is formed, but the target tableau's card is not required to have the same suit. @@ -32,12 +32,12 @@ On each move, you can either: * Move a sequence to an empty tableau. * Deal ten cards from the deck (in the upper left corder), one to - each tableau. This move is allowed only if no tableau is empty. + each tableau. This move is allowed only if no tableau is empty. To move a sequence, either drag it to the target tableau, or click the sequence and then click the top card of the target tableau (or the -place where a single card would be for an empty tableau). Click a -select card to de-select it. Clicking a card that is not a valid +place where a single card would be for an empty tableau). Click a +select card to de-select it. Clicking a card that is not a valid target for the currently selected sequence causes the clicked card's sequence to be selected (if the card is face up in a sequence). diff --git a/collects/games/spider/spider.ss b/collects/games/spider/spider.ss index c0bbbf76cf..66dd1da450 100644 --- a/collects/games/spider/spider.ss +++ b/collects/games/spider/spider.ss @@ -1,445 +1,412 @@ +#lang mzscheme -(module spider mzscheme - - (require (lib "cards.ss" "games" "cards") - (lib "class.ss") - (lib "mred.ss" "mred") - (lib "list.ss") - (lib "file.ss") - (lib "unit.ss") - "../show-help.ss") +(require (lib "cards.ss" "games" "cards") + (lib "class.ss") + (lib "mred.ss" "mred") + (lib "list.ss") + (lib "file.ss") + (lib "unit.ss") + "../show-help.ss") - (define (list-first-n l n) - (if (zero? n) - null - (cons (car l) (list-first-n (cdr l) (sub1 n))))) - (define (vector-copy v) - (list->vector (vector->list v))) +(define (list-first-n l n) + (if (zero? n) + null + (cons (car l) (list-first-n (cdr l) (sub1 n))))) +(define (vector-copy v) + (list->vector (vector->list v))) - (provide game@) - - (define game@ - (unit - (import) - (export) - - (define t (make-table "Spider" 11 6)) +(provide game@) +(define game@ (unit (import) (export) - (define num-suits (get-preference 'spider:num-suits (lambda () 2))) +(define t (make-table "Spider" 11 6)) - (define (make-spider-deck) - (let-values ([(suits copies) - (case num-suits - [(1) (values '(spades) 4)] - [(2) (values '(spades hearts) 2)] - [(4) (values '(spades hearts clubs diamonds) 1)])]) - (let ([l (filter (lambda (c) - (memq (send c get-suit) suits)) - (make-deck))]) - (let loop ([n (* 2 copies)]) - (if (zero? n) - null - (append (map (lambda (c) (send c copy)) l) - (loop (sub1 n)))))))) +(define num-suits (get-preference 'spider:num-suits (lambda () 2))) - (define deck (make-spider-deck)) +(define (make-spider-deck) + (let-values ([(suits copies) + (case num-suits + [(1) (values '(spades) 4)] + [(2) (values '(spades hearts) 2)] + [(4) (values '(spades hearts clubs diamonds) 1)])]) + (let ([l (filter (lambda (c) (memq (send c get-suit) suits)) (make-deck))]) + (let loop ([n (* 2 copies)]) + (if (zero? n) + null + (append (map (lambda (c) (send c copy)) l) (loop (sub1 n)))))))) - (define draw-pile deck) +(define deck (make-spider-deck)) - (define CARD-WIDTH (send (car deck) card-width)) - (define CARD-HEIGHT (send (car deck) card-height)) +(define draw-pile deck) - (define dx (quotient CARD-WIDTH 11)) - (define dy dx) +(define CARD-WIDTH (send (car deck) card-width)) +(define CARD-HEIGHT (send (car deck) card-height)) - (define stacks (make-vector 10 null)) - (define dones (make-vector 8 null)) +(define dx (quotient CARD-WIDTH 11)) +(define dy dx) - (define done-count 0) +(define stacks (make-vector 10 null)) +(define dones (make-vector 8 null)) - (define old-states null) +(define done-count 0) - (define-struct state (draw-pile stacks dones done-count face-down?s)) +(define old-states null) - (define mb (make-object menu-bar% t)) +(define-struct state (draw-pile stacks dones done-count face-down?s)) - (define file-menu (make-object menu% "&File" mb)) +(define mb (make-object menu-bar% t)) - (new menu-item% - [label "&Reset Game..."] - [parent file-menu] - [callback (lambda (i e) - (when (eq? 'yes (message-box "Reset Game" - "Are you sure you want to reset the game?" - t - '(yes-no))) - (reset-game!)))]) +(define file-menu (make-object menu% "&File" mb)) - (new separator-menu-item% [parent file-menu]) +(new menu-item% + [label "&Reset Game..."] + [parent file-menu] + [callback + (lambda (i e) + (when (eq? 'yes (message-box "Reset Game" + "Are you sure you want to reset the game?" + t + '(yes-no))) + (reset-game!)))]) - (new menu-item% - [label "&Close"] - [parent file-menu] - [shortcut #\W] - [callback (lambda (i e) (send t show #f))]) +(new separator-menu-item% [parent file-menu]) - (define edit-menu (make-object menu% "&Edit" mb)) +(new menu-item% + [label "&Close"] + [parent file-menu] + [shortcut #\W] + [callback (lambda (i e) (send t show #f))]) - (define undo - (new menu-item% - [label "&Undo"] - [parent edit-menu] - [shortcut #\Z] - [callback (lambda (i e) - (pop-state!))])) +(define edit-menu (make-object menu% "&Edit" mb)) - (new separator-menu-item% [parent edit-menu]) +(define undo + (new menu-item% + [label "&Undo"] + [parent edit-menu] + [shortcut #\Z] + [callback (lambda (i e) (pop-state!))])) - (new menu-item% - [label "&Options..."] - [parent edit-menu] - [callback (lambda (i e) - (define d (new dialog% - [label "Spider Options"] - [parent t] - [stretchable-width #f] - [stretchable-height #f])) - (define suits (new radio-box% - [label #f] - [parent (new group-box-panel% - [parent d] - [label "Number of Suits"] - [stretchable-width #f] - [stretchable-height #f])] - [choices '("1 (easiest)" "2" "4 (hardest)")])) - (define bottom-panel (new horizontal-panel% - [parent d] - [alignment '(right center)] - [stretchable-height #f])) - (new button% - [parent bottom-panel] - [label "&Cancel"] - [callback (lambda (b e) (send d show #f))]) - (new button% - [parent bottom-panel] - [label "&Ok"] - [style '(border)] - [callback (lambda (b e) - (let ([n (expt 2 (send suits get-selection))]) - (if (not (= n num-suits)) - (when (eq? 'yes - (message-box "Warning" - "Reset the game for new suit count?" - d - '(yes-no))) - (set! num-suits n) - (put-preferences '(spider:num-suits) (list n)) - (send d show #f) - (reset-game!)) - (send d show #f))))]) - (send suits set-selection (case num-suits [(1) 0][(2) 1][(4) 2])) - (send d center) - (send d show #t))]) +(new separator-menu-item% [parent edit-menu]) + +(new menu-item% + [label "&Options..."] + [parent edit-menu] + [callback (lambda (i e) + (define d + (new dialog% + [label "Spider Options"] + [parent t] + [stretchable-width #f] + [stretchable-height #f])) + (define suits + (new radio-box% + [label #f] + [parent (new group-box-panel% + [parent d] + [label "Number of Suits"] + [stretchable-width #f] + [stretchable-height #f])] + [choices '("1 (easiest)" "2" "4 (hardest)")])) + (define bottom-panel + (new horizontal-panel% + [parent d] + [alignment '(right center)] + [stretchable-height #f])) + (new button% + [parent bottom-panel] + [label "&Cancel"] + [callback (lambda (b e) (send d show #f))]) + (new button% + [parent bottom-panel] + [label "&Ok"] + [style '(border)] + [callback (lambda (b e) + (let ([n (expt 2 (send suits get-selection))]) + (if (not (= n num-suits)) + (when (eq? 'yes + (message-box "Warning" + "Reset the game for new suit count?" + d + '(yes-no))) + (set! num-suits n) + (put-preferences '(spider:num-suits) (list n)) + (send d show #f) + (reset-game!)) + (send d show #f))))]) + (send suits set-selection (case num-suits [(1) 0][(2) 1][(4) 2])) + (send d center) + (send d show #t))]) (define help (show-help '("games" "spider") "Spider Rules" #f)) - (new menu-item% + (new menu-item% [label "&Rules"] [parent (make-object menu% "&Help" mb)] - [callback (lambda (i e) - (help))]) + [callback (lambda (i e) (help))]) - (define (push-state!) - (when (null? old-states) - (send undo enable #t)) - (set! old-states (cons (make-state - draw-pile - (vector-copy stacks) - (vector-copy dones) - done-count - (map (lambda (c) (send c face-down?)) deck)) - old-states))) +(define (push-state!) + (when (null? old-states) + (send undo enable #t)) + (set! old-states + (cons (make-state draw-pile + (vector-copy stacks) + (vector-copy dones) + done-count + (map (lambda (c) (send c face-down?)) deck)) + old-states))) - (define (pop-state!) - (let ([state (car old-states)]) - (send t begin-card-sequence) - (set! old-states (cdr old-states)) - (set! draw-pile (state-draw-pile state)) - (set! stacks (state-stacks state)) - (set! dones (state-dones state)) - (set! done-count (state-done-count state)) - (for-each (lambda (c fd?) - (send c user-can-move #f) - (unless (eq? (send c face-down?) fd?) - (send c flip))) - deck (state-face-down?s state)) - (send t move-cards draw-pile dx dy) - (send t stack-cards draw-pile) - (let loop ([i 0]) - (unless (= i (vector-length stacks)) - (send t stack-cards (vector-ref stacks i)) - (loop (add1 i)))) - (let loop ([i 0]) - (unless (= i (vector-length dones)) - (move-dones i) - (loop (add1 i)))) - (shift-stacks) - (when (null? old-states) - (send undo enable #f)) - (send t end-card-sequence))) +(define (pop-state!) + (let ([state (car old-states)]) + (send t begin-card-sequence) + (set! old-states (cdr old-states)) + (set! draw-pile (state-draw-pile state)) + (set! stacks (state-stacks state)) + (set! dones (state-dones state)) + (set! done-count (state-done-count state)) + (for-each (lambda (c fd?) + (send c user-can-move #f) + (unless (eq? (send c face-down?) fd?) (send c flip))) + deck (state-face-down?s state)) + (send t move-cards draw-pile dx dy) + (send t stack-cards draw-pile) + (let loop ([i 0]) + (unless (= i (vector-length stacks)) + (send t stack-cards (vector-ref stacks i)) + (loop (add1 i)))) + (let loop ([i 0]) + (unless (= i (vector-length dones)) (move-dones i) (loop (add1 i)))) + (shift-stacks) + (when (null? old-states) (send undo enable #f)) + (send t end-card-sequence))) - (define (find-stack find) - (let loop ([i 0]) - (if (= i (vector-length stacks)) - #f - (let ([l (vector-ref stacks i)]) - (if (and (pair? l) - (memq find l)) - i - (loop (add1 i))))))) +(define (find-stack find) + (let loop ([i 0]) + (if (= i (vector-length stacks)) + #f + (let ([l (vector-ref stacks i)]) + (if (and (pair? l) (memq find l)) + i + (loop (add1 i))))))) - (define (remove-from-stack! cards) - (let* ([i (find-stack (car cards))] - [l (vector-ref stacks i)]) - (vector-set! stacks i (list-tail l (length cards))))) +(define (remove-from-stack! cards) + (let* ([i (find-stack (car cards))] + [l (vector-ref stacks i)]) + (vector-set! stacks i (list-tail l (length cards))))) - (define (stacked-cards card) - (let ([i (find-stack card)]) - (if i - (reverse - (let loop ([l (vector-ref stacks i)]) - (cond - [(not (send (car l) user-can-move)) null] - [(eq? (car l) card) (list card)] - [else (cons (car l) (loop (cdr l)))]))) - #f))) +(define (stacked-cards card) + (let ([i (find-stack card)]) + (if i + (reverse (let loop ([l (vector-ref stacks i)]) + (cond [(not (send (car l) user-can-move)) null] + [(eq? (car l) card) (list card)] + [else (cons (car l) (loop (cdr l)))]))) + #f))) - (define (drag-ok? cards i) - (let ([c (car cards)] - [l (vector-ref stacks i)]) - (and l - (or (null? l) - (= (send (car l) get-value) - (add1 (send c get-value))))))) +(define (drag-ok? cards i) + (let ([c (car cards)] + [l (vector-ref stacks i)]) + (and l + (or (null? l) + (= (send (car l) get-value) + (add1 (send c get-value))))))) - (let loop ([i 0]) - (unless (= i (vector-length stacks)) - null - (let ([r (make-region (+ dx (* i (+ CARD-WIDTH dx))) - (+ dy CARD-HEIGHT dy) - CARD-WIDTH - (- (* CARD-HEIGHT 5) dy dy) - #f - (lambda (cards) - (when (drag-ok? cards i) - (move-to-stack cards i))))]) - (set-region-interactive-callback! - r - (lambda (on? cards) - (let ([ok? (and on? (drag-ok? cards i))]) - (for-each (lambda (c) - (send c snap-back-after-move (not ok?))) - cards) - (let ([l (vector-ref stacks i)]) - (unless (null? l) - (send (car l) dim ok?)))))) - (send t add-region r) - (loop (add1 i))))) +(let loop ([i 0]) + (unless (= i (vector-length stacks)) + null + (let ([r (make-region (+ dx (* i (+ CARD-WIDTH dx))) + (+ dy CARD-HEIGHT dy) + CARD-WIDTH + (- (* CARD-HEIGHT 5) dy dy) + #f + (lambda (cards) + (when (drag-ok? cards i) + (move-to-stack cards i))))]) + (set-region-interactive-callback! + r + (lambda (on? cards) + (let ([ok? (and on? (drag-ok? cards i))]) + (for-each (lambda (c) (send c snap-back-after-move (not ok?))) + cards) + (let ([l (vector-ref stacks i)]) + (unless (null? l) (send (car l) dim ok?)))))) + (send t add-region r) + (loop (add1 i))))) - - (define (move-to-stack cards i) - (unselect) - (let ([l (vector-ref stacks i)]) - (unless (null? l) - (send (car l) dim #f))) - (push-state!) - (remove-from-stack! cards) - (vector-set! stacks i - (append (reverse cards) - (vector-ref stacks i))) - (for-each (lambda (c) - (send c snap-back-after-move #t)) - cards) - (shift-stacks)) - (define selected null) +(define (move-to-stack cards i) + (unselect) + (let ([l (vector-ref stacks i)]) + (unless (null? l) (send (car l) dim #f))) + (push-state!) + (remove-from-stack! cards) + (vector-set! stacks i (append (reverse cards) (vector-ref stacks i))) + (for-each (lambda (c) (send c snap-back-after-move #t)) cards) + (shift-stacks)) - (define (select cards) - (unselect) - (set! selected cards) - (for-each (lambda (c) (send c dim #t)) - selected)) +(define selected null) - (define (unselect) - (for-each (lambda (c) (send c dim #f)) - selected) - (set! selected null)) +(define (select cards) + (unselect) + (set! selected cards) + (for-each (lambda (c) (send c dim #t)) selected)) - (define (move-dones i) - (send t move-cards (vector-ref dones i) - (- (* 10 CARD-WIDTH) dx (* i (+ CARD-WIDTH dx))) - dy)) +(define (unselect) + (for-each (lambda (c) (send c dim #f)) selected) + (set! selected null)) - (define (draw push?) - (when push? - (push-state!)) - (let ([drawn-cards - (let loop ([i 0]) - (if (or (= i (vector-length stacks)) - (null? draw-pile)) - null - (if (vector-ref stacks i) - (let ([a (car draw-pile)]) - (vector-set! stacks i (cons a - (vector-ref stacks i))) - (send a flip) - (set! draw-pile (cdr draw-pile)) - (cons a (loop (add1 i)))) - (loop (add1 i)))))]) - (send t card-to-front (car drawn-cards)) - (send t stack-cards drawn-cards)) - (shift-stacks)) - - (define (check-complete) - (let loop ([i 0]) - (unless (= i (vector-length stacks)) - (let ([l (vector-ref stacks i)]) - (when (and (pair? l) - (= 1 (send (car l) get-value))) - (let ([suit (send (car l) get-suit)]) - (let loop ([j 2][a (list (car l))][l (cdr l)]) - (cond - [(= j 14) - ;; Complete set - move 13 cards to a done pile - (vector-set! dones done-count a) - (move-dones done-count) - (set! done-count (add1 done-count)) - (for-each (lambda (c) - (send c user-can-move #f)) - a) - (vector-set! stacks i l)] - [(and (pair? l) - (= j (send (car l) get-value)) - (equal? suit (send (car l) get-suit))) - (loop (add1 j) (cons (car l) a) (cdr l))] - [else (void)]))))) - (loop (add1 i))))) +(define (move-dones i) + (send t move-cards (vector-ref dones i) + (- (* 10 CARD-WIDTH) dx (* i (+ CARD-WIDTH dx))) + dy)) - (define (shift-stacks) - (unselect) - (check-complete) - (let ([cards (apply append (map reverse (vector->list stacks)))] - [deltas (list->vector - (let loop ([i 0]) - (if (= i (vector-length stacks)) - null - (append - (let* ([l (vector-ref stacks i)] - [ddy (min (quotient CARD-HEIGHT 3) - (quotient (- (* CARD-HEIGHT 4) - dy dy dy) - (max 1 (sub1 (length l)))))]) - (let loop ([l l][dy 0]) - (if (null? l) - null - (cons (list (* i (+ CARD-WIDTH dx)) dy) - (loop (cdr l) (+ dy ddy)))))) - (loop (add1 i))))))]) - (send t move-cards cards dx (+ CARD-HEIGHT dy dy) - (lambda (i) (apply values (vector-ref deltas i)))) - - (let loop ([i 0]) - (unless (= i (vector-length stacks)) - (let ([l (vector-ref stacks i)]) - (when (pair? l) - (when (send (car l) face-down?) - (send t flip-card (car l))) - (send (car l) user-can-move #t) - (let loop ([l (cdr l)][prev (car l)]) - (unless (null? l) - (if (and (not (send (car l) face-down?)) - (equal? (send prev get-suit) - (send (car l) get-suit)) - (= (add1 (send prev get-value)) - (send (car l) get-value))) - (begin - (send (car l) user-can-move #t) - (loop (cdr l) (car l))) - (for-each (lambda (c) - (send c user-can-move #f)) - l)))))) - (loop (add1 i)))))) - - (send t set-double-click-action void) +(define (draw push?) + (when push? (push-state!)) + (let ([drawn-cards + (let loop ([i 0]) + (if (or (= i (vector-length stacks)) (null? draw-pile)) + null + (if (vector-ref stacks i) + (let ([a (car draw-pile)]) + (vector-set! stacks i (cons a (vector-ref stacks i))) + (send a flip) + (set! draw-pile (cdr draw-pile)) + (cons a (loop (add1 i)))) + (loop (add1 i)))))]) + (send t card-to-front (car drawn-cards)) + (send t stack-cards drawn-cards)) + (shift-stacks)) - (send t set-single-click-action - (lambda (c) - (cond - [(and (pair? draw-pile) - (eq? c (car draw-pile))) - (if (ormap null? (vector->list stacks)) - (bell) - (draw #t))] - [(and (pair? selected) (eq? c (car selected))) - (unselect)] - [(and (pair? selected) - (let ([i (find-stack c)]) - (and i - (not (equal? i (find-stack (car selected)))) - (drag-ok? selected i) - i))) - => (lambda (i) - (send t card-to-front (car (last-pair selected))) - (send t stack-cards (reverse selected)) - (move-to-stack selected i))] - [(stacked-cards c) - => (lambda (cards) (select cards))]))) +(define (check-complete) + (let loop ([i 0]) + (unless (= i (vector-length stacks)) + (let ([l (vector-ref stacks i)]) + (when (and (pair? l) (= 1 (send (car l) get-value))) + (let ([suit (send (car l) get-suit)]) + (let loop ([j 2][a (list (car l))][l (cdr l)]) + (cond + [(= j 14) + ;; Complete set - move 13 cards to a done pile + (vector-set! dones done-count a) + (move-dones done-count) + (set! done-count (add1 done-count)) + (for-each (lambda (c) (send c user-can-move #f)) a) + (vector-set! stacks i l)] + [(and (pair? l) + (= j (send (car l) get-value)) + (equal? suit (send (car l) get-suit))) + (loop (add1 j) (cons (car l) a) (cdr l))] + [else (void)]))))) + (loop (add1 i))))) - ;; Add a region for each stack to receive clicks when - ;; the stack is empty: - (let loop ([i 0]) - (unless (= i (vector-length stacks)) - (send t add-region (make-button-region - (+ dx (* i (+ CARD-WIDTH dx))) - (+ dy CARD-HEIGHT dy) - CARD-WIDTH CARD-HEIGHT - #f - (lambda () - (when (and (null? (vector-ref stacks i)) - (pair? selected)) - (move-to-stack selected i))))) - (loop (add1 i)))) +(define (shift-stacks) + (unselect) + (check-complete) + (let ([cards (apply append (map reverse (vector->list stacks)))] + [deltas (list->vector + (let loop ([i 0]) + (if (= i (vector-length stacks)) + null + (append + (let* ([l (vector-ref stacks i)] + [ddy (min (quotient CARD-HEIGHT 3) + (quotient (- (* CARD-HEIGHT 4) + dy dy dy) + (max 1 (sub1 (length l)))))]) + (let loop ([l l][dy 0]) + (if (null? l) + null + (cons (list (* i (+ CARD-WIDTH dx)) dy) + (loop (cdr l) (+ dy ddy)))))) + (loop (add1 i))))))]) + (send t move-cards cards dx (+ CARD-HEIGHT dy dy) + (lambda (i) (apply values (vector-ref deltas i)))) - (send t set-button-action 'left 'drag-raise/above) - (send t set-button-action 'middle 'drag-raise/above) - (send t set-button-action 'right 'drag-raise/above) + (let loop ([i 0]) + (unless (= i (vector-length stacks)) + (let ([l (vector-ref stacks i)]) + (when (pair? l) + (when (send (car l) face-down?) (send t flip-card (car l))) + (send (car l) user-can-move #t) + (let loop ([l (cdr l)][prev (car l)]) + (unless (null? l) + (if (and (not (send (car l) face-down?)) + (equal? (send prev get-suit) + (send (car l) get-suit)) + (= (add1 (send prev get-value)) + (send (car l) get-value))) + (begin (send (car l) user-can-move #t) + (loop (cdr l) (car l))) + (for-each (lambda (c) (send c user-can-move #f)) + l)))))) + (loop (add1 i)))))) - (define (reset-game!) - (send t remove-cards deck) - (set! deck (make-spider-deck)) - (send t add-cards deck dx dy) - (send t begin-card-sequence) - (unselect) - (send undo enable #f) - (set! draw-pile (shuffle-list deck 7)) - (for-each (lambda (c) - (unless (send c face-down?) - (send c flip)) - (send c user-can-flip #f) - (send c user-can-move #f) - (send c snap-back-after-move #t)) - draw-pile) - (set! stacks (make-vector 10 null)) - (set! dones (make-vector 8 null)) - (set! done-count 0) - (set! old-states null) - (send t stack-cards draw-pile) - (let loop ([i 0]) - (unless (= i (vector-length stacks)) - (let ([n (if (< i 4) 5 4)]) - (vector-set! stacks i (list-first-n draw-pile n)) - (set! draw-pile (list-tail draw-pile n))) - (loop (add1 i)))) - (draw #f) - (send t end-card-sequence)) - (reset-game!) - (send t show #t)))) +(send t set-double-click-action void) + +(send t set-single-click-action + (lambda (c) + (cond + [(and (pair? draw-pile) + (eq? c (car draw-pile))) + (if (ormap null? (vector->list stacks)) (bell) (draw #t))] + [(and (pair? selected) (eq? c (car selected))) + (unselect)] + [(and (pair? selected) + (let ([i (find-stack c)]) + (and i + (not (equal? i (find-stack (car selected)))) + (drag-ok? selected i) + i))) + => (lambda (i) + (send t card-to-front (car (last-pair selected))) + (send t stack-cards (reverse selected)) + (move-to-stack selected i))] + [(stacked-cards c) => (lambda (cards) (select cards))]))) + +;; Add a region for each stack to receive clicks when +;; the stack is empty: +(let loop ([i 0]) + (unless (= i (vector-length stacks)) + (send t add-region (make-button-region + (+ dx (* i (+ CARD-WIDTH dx))) + (+ dy CARD-HEIGHT dy) + CARD-WIDTH CARD-HEIGHT + #f + (lambda () + (when (and (null? (vector-ref stacks i)) + (pair? selected)) + (move-to-stack selected i))))) + (loop (add1 i)))) + +(send t set-button-action 'left 'drag-raise/above) +(send t set-button-action 'middle 'drag-raise/above) +(send t set-button-action 'right 'drag-raise/above) + +(define (reset-game!) + (send t remove-cards deck) + (set! deck (make-spider-deck)) + (send t add-cards deck dx dy) + (send t begin-card-sequence) + (unselect) + (send undo enable #f) + (set! draw-pile (shuffle-list deck 7)) + (for-each (lambda (c) + (unless (send c face-down?) (send c flip)) + (send c user-can-flip #f) + (send c user-can-move #f) + (send c snap-back-after-move #t)) + draw-pile) + (set! stacks (make-vector 10 null)) + (set! dones (make-vector 8 null)) + (set! done-count 0) + (set! old-states null) + (send t stack-cards draw-pile) + (let loop ([i 0]) + (unless (= i (vector-length stacks)) + (let ([n (if (< i 4) 5 4)]) + (vector-set! stacks i (list-first-n draw-pile n)) + (set! draw-pile (list-tail draw-pile n))) + (loop (add1 i)))) + (draw #f) + (send t end-card-sequence)) +(reset-game!) +(send t show #t) + +))