From 4254ad8afa837c23055bfcfbfd3796573dbcab07 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 16 Nov 2008 17:27:41 +0000 Subject: [PATCH] add support for rotated cards in games/cards svn: r12461 --- collects/games/cards/card-class.ss | 134 +++++++++++++++++++++++------ collects/games/cards/cards.scrbl | 51 ++++++++--- collects/games/cards/classes.ss | 64 +++++++++----- collects/games/cards/make-cards.ss | 25 +----- 4 files changed, 196 insertions(+), 78 deletions(-) diff --git a/collects/games/cards/card-class.ss b/collects/games/cards/card-class.ss index 526642bd1f..1f9330efd1 100644 --- a/collects/games/cards/card-class.ss +++ b/collects/games/cards/card-class.ss @@ -2,9 +2,11 @@ (module card-class mzscheme (require mzlib/class mzlib/class100 + mzlib/shared (prefix mred: mred) "snipclass.ss" - "region.ss") + "region.ss" + (only scheme/base for in-range)) (provide card%) @@ -28,18 +30,43 @@ (thunk) (send dc set-clipping-region r)))) + (define (rotate-bm bm cw?) + (let ([w (send bm get-width)] + [h (send bm get-height)]) + (let ([bm2 (make-object mred:bitmap% h w)] + [s (make-bytes (* w h 4))] + [s2 (make-bytes (* h w 4))]) + (send bm get-argb-pixels 0 0 w h s) + (for ([i (in-range w)]) + (for ([j (in-range h)]) + (let ([src-pos (* (+ i (* j w)) 4)]) + (bytes-copy! s2 + (if cw? + (* (+ (- (- h j) 1) (* i h)) 4) + (* (+ j (* (- (- w i) 1) h)) 4)) + s src-pos (+ src-pos 4))))) + (let ([dc (make-object mred:bitmap-dc% bm2)]) + (send dc set-argb-pixels 0 0 h w s2) + (send dc set-bitmap #f)) + bm2))) + + (define orientations (shared ([o (list* 'n 'e 's 'w o)]) o)) + (define (find-head l s) + (if (eq? (car l) s) + l + (find-head (cdr l) s))) + (define card% - (class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back) + (class100 mred:snip% (-suit-id -value -width -height -front -back -mk-dim-front -mk-dim-back -rotated-bms) (inherit set-snipclass set-count get-admin) (private-field [suit-id -suit-id] [value -value] [width -width] [height -height] + [rotated 'n] [front -front] [back -back] - [semi-front -semi-front] - [semi-back -semi-back] [mk-dim-front -mk-dim-front] [mk-dim-back -mk-dim-back] [dim-front #f] @@ -51,13 +78,20 @@ [can-move? #t] [snap-back? #f] [stay-region #f] - [home-reg #f]) + [home-reg #f] + [rotated-bms -rotated-bms]) (private [refresh (lambda () (let ([a (get-admin)]) (when a (send a needs-update this 0 0 width height))))] + [refresh-size + (lambda () + (let ([a (get-admin)]) + (when a + (send a resized this #f))) + (refresh))] [check-dim (lambda () (when is-dim? @@ -65,7 +99,18 @@ (unless dim-back (set! dim-back (mk-dim-back))) (unless dim-front - (set! dim-front (mk-dim-front))))))]) + (set! dim-front (mk-dim-front))))))] + [get-rotated + (lambda (bm dir) + (if (eq? dir 'n) + bm + (or (hash-table-get rotated-bms (cons dir bm) #f) + (let ([rotated-bm (case dir + [(w) (rotate-bm bm #f)] + [(e) (rotate-bm bm #t)] + [(s) (rotate-bm (rotate-bm bm #t) #t)])]) + (hash-table-put! rotated-bms (cons dir bm) rotated-bm) + rotated-bm))))]) (public [face-down? (lambda () flipped?)] [flip @@ -84,6 +129,25 @@ (unless (eq? is-dim? (and v #t)) (set! is-dim? (and v #t)) (refresh))])] + [orientation (lambda () (case rotated + [(n) 0] + [(e) 270] + [(w) 90] + [(s) 180]))] + [rotate (lambda (mode) + (let ([delta (case mode + [(0 360) 0] + [(cw -90 270) 1] + [(ccw 90 -270) 3] + [(180 -180) 2] + [else (error 'rotate "bad mode: ~e" mode)])]) + (set! rotated (list-ref (find-head orientations rotated) delta)) + (if (odd? delta) + (let ([w width]) + (set! width height) + (set! height w) + (refresh-size)) + (refresh))))] [get-suit-id (lambda () suit-id)] [get-suit @@ -133,26 +197,44 @@ [draw (lambda (dc x y left top right bottom dx dy draw-caret) (check-dim) - (if semi-flipped? - (send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y) - (with-card-region - dc x y width height - (lambda () - (send dc draw-bitmap - (if flipped? - (if is-dim? dim-back back) - (if is-dim? dim-front front)) - x y)))))] - [copy (lambda () (make-object card% suit-id value width height - front back semi-front semi-back - (lambda () - (unless dim-front - (set! dim-front (mk-dim-front))) - dim-front) - (lambda () - (unless dim-back - (set! dim-back (mk-dim-back))) - dim-back)))]) + (let ([do-draw + (lambda (x y) + (with-card-region + dc x y width height + (lambda () + (send dc draw-bitmap + (let ([bm (if flipped? + (if is-dim? dim-back back) + (if is-dim? dim-front front))]) + (get-rotated bm rotated)) + x y))))]) + (if semi-flipped? + (let-values ([(sx sy) (send dc get-scale)]) + (case rotated + [(n s) + (send dc set-scale (/ sx 2) sy) + (do-draw (+ (* 2 x) (/ width 2)) y) + (send dc set-scale sx sy)] + [(e w) + (send dc set-scale sx (/ sy 2)) + (do-draw x (+ (* 2 y) (/ height 2))) + (send dc set-scale sx sy)])) + (do-draw x y))))] + [copy (lambda () + (let ([rotated? (memq rotated '(e w))]) + (make-object card% suit-id value + (if rotated? height width) + (if rotated? width height ) + front back + (lambda () + (unless dim-front + (set! dim-front (mk-dim-front))) + dim-front) + (lambda () + (unless dim-back + (set! dim-back (mk-dim-back))) + dim-back) + rotated-bms)))]) (private-field [save-x (box 0)] [save-y (box 0)]) diff --git a/collects/games/cards/cards.scrbl b/collects/games/cards/cards.scrbl index 7eda556041..556a0a292f 100644 --- a/collects/games/cards/cards.scrbl +++ b/collects/games/cards/cards.scrbl @@ -17,8 +17,9 @@ module provides a toolbox for creating cards games.} table<%>]{ Returns a table. The table is named by @scheme[title], and it is -@scheme[w] cards wide and @scheme[h] cards high. The table is not -initially shown; @scheme[(send table show #t)] shows it.} +@scheme[w] cards wide and @scheme[h] cards high (assuming a standard +card of 71 by 96 pixels). The table is not initially shown; +@scheme[(send table show #t)] shows it.} @defproc[(make-deck) (listof card<%>)]{ @@ -37,7 +38,7 @@ Returns a single card given a bitmap for the front, an optional bitmap for the back, and arbitrary values for the card's suit and value (which are returned by the card's @method[card<%> get-value] and @method[card<%> get-suit-id] methods). All provided bitmaps should be -71 by 96 pixels.} +the same size.} @defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?]) list?]{ @@ -171,8 +172,9 @@ Create an instance with @scheme[make-table]. void?]{ Adds @scheme[cards] to fill the region @scheme[r], fanning them out - bottom-right to top-left. The region @scheme[r] does not have to be - added to the table.} + bottom-right to top-left, assuming that all cards in @scheme[cards] + have the same width and height. The region @scheme[r] does not have + to be added to the table.} @defmethod[(remove-card [card (is-a?/c card<%>)]) void?]{ @@ -227,6 +229,19 @@ Removes @scheme[card] from the table.} Like @method[table<%> flip-cards], but only for @scheme[card] or elements of @scheme[cards] that are currently face down/up.} +@defmethod*[([(rotate-card [card (is-a?/c card<%>)] + [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) + void?] + [(rotate-cards [cards (listof (is-a?/c card<%>))] + [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) + void?])]{ + + Rotates @scheme[card] or all @scheme[cards] (at once, currently + without animation, but animation may be added in the future). + The center of each card is kept in place, except that the card is + moved as necessary to keep it on the table. See @xmethod[card<%> + rotate] for information on @scheme[mode].} + @defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?] [(card-to-back [card (is-a?/c card<%>)]) void?])]{ @@ -384,13 +399,13 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. @defmethod[(card-width) exact-nonnegative-integer?]{ - Returns the width of the card in pixels. All cards have the same - width.} + Returns the width of the card in pixels. If the card is rotated 90 or + 270 degrees, the result is the card's original height.} @defmethod[(card-height) exact-nonnegative-integer?]{ - Returns the height of the card in pixels. All cards have the same - height.} + Returns the height of the card in pixels. If the card is rotated 90 or + 270 degrees, the result is the card's original width.} @defmethod[(flip) void?]{ @@ -409,6 +424,22 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. Returns @scheme[#t] if the card is currently face down.} +@defmethod[(rotate [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) void?]{ + + Rotates the card. Unlike using the @xmethod[table<%> rotate-card] method, + the card's top-left position is kept in place. + + If @scheme[mode] is @scheme['cw], the card is + rotated clockwise; if @scheme[mode] is @scheme['ccw], the card is + rotated counter-clockwise; if @scheme[mode] is one of the allowed + numbers, the card is rotated the corresponding amount in degrees + counter-clockwise.} + +@defmethod[(orientation) (or/c 0 90 180 270)]{ + + Returns the orientation of the card, where @scheme[0] corresponds to + its initial state, @scheme[90] is rotated 90 degrees counter-clockwise, and so on.} + @defmethod[(get-suit-id) any/c]{ Normally returns @scheme[1], @scheme[2], @scheme[3], or @scheme[4] @@ -476,7 +507,7 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. @defmethod*[([(dim) boolean?] [(dim [can? any/c]) void?])]{ - Gets/sets a hilite on the card, whichis rendered by drawing it dimmer + Gets/sets a hilite on the card, which is rendered by drawing it dimmer than normal.} @defmethod[(copy) (is-a?/c card<%>)]{ diff --git a/collects/games/cards/classes.ss b/collects/games/cards/classes.ss index 7c8444d0e6..7016f4bd53 100644 --- a/collects/games/cards/classes.ss +++ b/collects/games/cards/classes.ss @@ -519,6 +519,27 @@ (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))] + [rotate-card + (lambda (card mode) (rotate-cards (list card) mode))] + [rotate-cards + (lambda (cards mode) + (begin-card-sequence) + (let ([tw (table-width)] + [th (table-height)]) + (map (lambda (c) + (let ([w (send c card-width)] + [h (send c card-height)]) + (send c rotate mode) + (let ([w2 (send c card-width)] + [h2 (send c card-height)] + [x (box 0)] + [y (box 0)]) + (send pb get-snip-location c x y) + (send pb move-to c + (min (max 0 (+ (unbox x) (/ (- w w2) 2))) (- tw w2)) + (min (max 0 (+ (unbox y) (/ (- h h2) 2))) (- th h2)))))) + cards) + (end-card-sequence)))] [card-face-up (lambda (card) (cards-face-up (list card)))] @@ -695,27 +716,28 @@ (send pb only-front-selected)))] [position-cards-in-region (lambda (cards r set) - (let-values ([(x y w h) (send pb get-region-box r)] - [(len) (sub1 (length cards))] - [(cw ch) (values (send back get-width) - (send back get-height))]) - (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] - [pw (pretty cw)] - [ph (pretty ch)]) - (let-values ([(x w) (if (> w pw) - (values (+ x (/ (- w pw) 2)) pw) - (values x w))] - [(y h) (if (> h ph) - (values (+ y (/ (- h ph) 2)) ph) - (values y h))]) - (position-cards cards x y - (lambda (p) - (if (zero? len) - (values (/ (- w cw) 2) - (/ (- h ch) 2)) - (values (* (- len p) (/ (- w cw) len)) - (* (- len p) (/ (- h ch) len))))) - set)))))]) + (unless (null? cards) + (let-values ([(x y w h) (send pb get-region-box r)] + [(len) (sub1 (length cards))] + [(cw ch) (values (send (car cards) get-width) + (send (car cards) get-height))]) + (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] + [pw (pretty cw)] + [ph (pretty ch)]) + (let-values ([(x w) (if (> w pw) + (values (+ x (/ (- w pw) 2)) pw) + (values x w))] + [(y h) (if (> h ph) + (values (+ y (/ (- h ph) 2)) ph) + (values y h))]) + (position-cards cards x y + (lambda (p) + (if (zero? len) + (values (/ (- w cw) 2) + (/ (- h ch) 2)) + (values (* (- len p) (/ (- w cw) len)) + (* (- len p) (/ (- h ch) len))))) + set))))))]) (super-new [label title] [style '(metal no-resize-border)]) (begin (define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll))) diff --git a/collects/games/cards/make-cards.ss b/collects/games/cards/make-cards.ss index 9317e79039..38da0dcbd4 100644 --- a/collects/games/cards/make-cards.ss +++ b/collects/games/cards/make-cards.ss @@ -9,15 +9,6 @@ (define (get-bitmap file) (make-object mred:bitmap% file)) - (define (make-semi bm-in w h) - (let* ([bm (make-object mred:bitmap% (floor (/ w 2)) h)] - [mdc (make-object mred:bitmap-dc%)]) - (send mdc set-bitmap bm) - (send mdc set-scale 0.5 1) - (send mdc draw-bitmap bm-in 0 0) - (send mdc set-bitmap #f) - bm)) - (define (make-dim bm-in) (let ([w (send bm-in get-width)] [h (send bm-in get-height)]) @@ -46,11 +37,6 @@ (define back (get-bitmap (here "card-back.png"))) - (define semi-back - (let ([w (send back get-width)] - [h (send back get-height)]) - (make-semi back w h))) - (define dim-back (make-dim back)) @@ -74,9 +60,9 @@ value w h front back - (make-semi front w h) semi-back (lambda () (make-dim front)) - (lambda () dim-back)) + (lambda () dim-back) + (make-hash-table 'equal)) (vloop (sub1 value)))))))))) (define (make-card front-bm back-bm suit-id value) @@ -87,12 +73,9 @@ value w h front-bm (or back-bm back) - (make-semi front-bm w h) - (if back-bm - (make-semi back-bm w h) - semi-back) (lambda () (make-dim front-bm)) (lambda () (if back-bm (make-dim back) - dim-back)))))) + dim-back)) + (make-hash-table 'equal)))))