409 lines
14 KiB
Racket
409 lines
14 KiB
Racket
#lang mzscheme
|
|
|
|
(require games/cards mred mzlib/class mzlib/list mzlib/file mzlib/unit
|
|
"../show-scribbling.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)))
|
|
|
|
(provide game@)
|
|
(define game@ (unit (import) (export)
|
|
|
|
(define t (make-table "Spider" 11 6))
|
|
|
|
(define num-suits (get-preference 'spider:num-suits (lambda () 2)))
|
|
|
|
(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 deck (make-spider-deck))
|
|
|
|
(define draw-pile deck)
|
|
|
|
(define CARD-WIDTH (send (car deck) card-width))
|
|
(define CARD-HEIGHT (send (car deck) card-height))
|
|
|
|
(define dx (quotient CARD-WIDTH 11))
|
|
(define dy dx)
|
|
|
|
(define stacks (make-vector 10 null))
|
|
(define dones (make-vector 8 null))
|
|
|
|
(define done-count 0)
|
|
|
|
(define old-states null)
|
|
|
|
(define-struct state (draw-pile stacks dones done-count face-down?s))
|
|
|
|
(define mb (make-object menu-bar% t))
|
|
|
|
(define file-menu (make-object menu% "&File" mb))
|
|
|
|
(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 separator-menu-item% [parent file-menu])
|
|
|
|
(new menu-item%
|
|
[label "&Close"]
|
|
[parent file-menu]
|
|
[shortcut #\W]
|
|
[callback (lambda (i e) (send t show #f))])
|
|
|
|
(define edit-menu (make-object menu% "&Edit" mb))
|
|
|
|
(define undo
|
|
(new menu-item%
|
|
[label "&Undo"]
|
|
[parent edit-menu]
|
|
[shortcut #\Z]
|
|
[callback (lambda (i e) (pop-state!))]))
|
|
|
|
(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-scribbling '(lib "games/scribblings/games.scrbl")
|
|
"spider"))
|
|
(new menu-item%
|
|
[label "&Rules"]
|
|
[parent (make-object menu% "&Help" mb)]
|
|
[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 (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 (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 (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)))))
|
|
|
|
|
|
(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 (select cards)
|
|
(unselect)
|
|
(set! selected cards)
|
|
(for-each (lambda (c) (send c dim #t)) selected))
|
|
|
|
(define (unselect)
|
|
(for-each (lambda (c) (send c dim #f)) selected)
|
|
(set! selected null))
|
|
|
|
(define (move-dones i)
|
|
(send t move-cards (vector-ref dones i)
|
|
(- (* 10 CARD-WIDTH) dx (* i (+ CARD-WIDTH dx)))
|
|
dy))
|
|
|
|
(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 (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)
|
|
|
|
(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)
|
|
|
|
))
|