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