1#lang racket
2(require games/cards racket/gui racket/class racket/unit)
3
4(provide game@)
5
6(define game@ (unit (import) (export)
7
8;; Layout width and height:
9(define WIDTH 5)
10(define HEIGHT 4)
11(define MAX-MATCHES (/ (* WIDTH HEIGHT) 2))
12
13;; Randomize
14(random-seed (modulo (current-milliseconds) 10000))
15
16;; Set up the table
17(define t (make-table "Memory" (+ 2 WIDTH) (+ 1 HEIGHT)))
18(send t show #t)
19(send t set-double-click-action #f)
20
21;; Get table width & height
22(define w (send t table-width))
23(define h (send t table-height))
24
25;; Set up the cards
26(define deck
27  (let ([cards (map (lambda (name value)
28                      (let ([bm (make-object
29                                 bitmap%
30                                 (build-path
31                                  (collection-path "games" "memory" "images")
32                                  (format "~a.png" name)))])
33                        (make-card bm #f 0 value)))
34                    '("club" "heart" "spade" "diamond"
35                      "happy" "unhappy"
36                      "fish" "two-fish"
37                      "jack" "star")
38                    '(1 2 3 4 5 6 7 8 9 10))])
39    (append cards (map (lambda (c) (send c copy)) cards))))
40(for-each (lambda (card)
41            (send card user-can-move #f)
42            (send card user-can-flip #t))
43          deck)
44
45;; Card width & height
46(define cw (send (car deck) card-width))
47(define ch (send (car deck) card-height))
48
49(define dx (/ cw (+ 2 WIDTH)))
50(define dy (/ ch (+ 1 HEIGHT)))
51
52(define match-x (- w cw dx))
53(define match-y dy)
54
55(define time-h (+ 12 5 5))
56(define time-x match-x)
57(define time-y (+ ch dy dy))
58
59;; Put the cards on the table
60(send t add-cards deck match-x match-y)
61
62;; Setup
63(define (setup)
64  (reset-timer)
65  (set! deck (shuffle-list deck 7))
66  (send t stack-cards deck)
67  (send t move-cards deck 0 0
68        (lambda (pos)
69          (let ([i (modulo pos WIDTH)]
70                [j (quotient pos WIDTH)])
71            (values (+ dx (* i (+ cw dx)))
72                    (+ dy (* j (+ ch dy))))))))
73
74;; Number of matches found so far:
75(define matches 0)
76
77;; First card flipped, or #f if non flipped, yet
78(define card-1 #f)
79
80(define (flip-and-match c)
81  (cond [(eq? c card-1)
82         ;; Cancel first card
83         (send t flip-card c)
84         (set! card-1 #f)]
85        [(not (send c face-down?))
86         ;; Can't click a matched card, unless the game is over,
87         ;; in which case we reset the game
88         (when (= matches MAX-MATCHES)
89           (send t flip-cards deck)
90           (set! matches 0)
91           (setup))]
92        [else
93         ;; Flip over a card...
94         (send t flip-card c)
95         (send t card-to-front c)
96         (run-timer)
97         (cond [(not card-1)
98                ;; That was the first card
99                (set! card-1 c)]
100               [(and (equal? (send card-1 get-value) (send c get-value))
101                     (equal? (send card-1 get-suit) (send c get-suit)))
102                ;; Match
103                (send t pause 0.5)
104                (send t move-cards (list card-1 c) match-x match-y)
105                (set! card-1 #f)
106                (set! matches (add1 matches))]
107               [else
108                ;; Not a match
109                (send t pause 0.5)
110                (send t flip-cards (list card-1 c))
111                (set! card-1 #f)])]))
112(send t set-single-click-action flip-and-match)
113
114;; The timer turns out to be the most difficult part:
115(define (make-time-region secs)
116  (make-region time-x time-y cw time-h
117               (if (>= secs 6000)
118                 "XX:XX"
119                 (format
120                  "~a:~a"
121                  (substring (number->string (+ 100 (quotient secs 60))) 1)
122                  (substring (number->string (+ 100 (modulo secs 60))) 1)))
123               #f))
124(define start-time #f)   ; in inexact milliseconds; #f means not started
125(define shown-seconds 0) ; used to compute the delay until the next update
126(define time-region (make-time-region 0)) ; old region, so we wan remove it
127(send t add-region time-region) ; start with the initial region added
128(define (show-time n)
129  ;; Compute new time to show:
130  (set! shown-seconds n)
131  ;; Update the time by removing the old region and adding a new one:
132  (send t begin-card-sequence)
133  (send t remove-region time-region)
134  (set! time-region (make-time-region shown-seconds))
135  (send t add-region time-region)
136  (send t end-card-sequence))
137(define (get-update-delta)
138  ;; Figure out how many milliseconds to sleep before the next update
139  (max 0 (inexact->exact (floor (- (+ start-time (* 1000 shown-seconds) 1000)
140                                   (current-inexact-milliseconds))))))
141(define time-timer
142  (make-object timer%
143    (lambda ()
144      (unless (= matches MAX-MATCHES)
145        (show-time
146         (inexact->exact
147          (floor (/ (- (current-inexact-milliseconds) start-time) 1000))))
148        (send time-timer start (get-update-delta) #t)))))
149(define (reset-timer)
150  (send time-timer stop)
151  (set! start-time #f)
152  (show-time 0))
153(define (run-timer)
154  (unless start-time
155    (set! start-time (current-inexact-milliseconds))
156    (send time-timer start 1000 #t)))
157
158;; Start the game:
159(send t pause 0.25)
160(setup)))
161