add support for rotated cards in games/cards
svn: r12461
This commit is contained in:
Matthew Flatt
parent
1e5caacdde
commit
4254ad8afa
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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<%>)]{
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user