280 lines
8.6 KiB
Racket
280 lines
8.6 KiB
Racket
|
|
(module card-class mzscheme
|
|
(require mzlib/class
|
|
mzlib/class100
|
|
mzlib/shared
|
|
(prefix mred: mred)
|
|
"snipclass.ss"
|
|
"region.ss"
|
|
(only scheme/base for in-range))
|
|
|
|
(provide card%)
|
|
|
|
(define prev-regions #f)
|
|
(define prev-region-dc #f)
|
|
|
|
(define (with-card-region dc x y width height thunk)
|
|
(let ([rs (if (eq? prev-region-dc dc)
|
|
prev-regions
|
|
(cons (make-object mred:region% dc)
|
|
(make-object mred:region% dc)))])
|
|
(set! prev-regions rs)
|
|
(set! prev-region-dc dc)
|
|
(send (car rs) set-rectangle x (add1 y) width (- height 2))
|
|
(send (cdr rs) set-rectangle (add1 x) y (- width 2) height)
|
|
(send (car rs) union (cdr rs))
|
|
(let ([r (send dc get-clipping-region)])
|
|
(when r
|
|
(send (car rs) intersect r))
|
|
(send dc set-clipping-region (car rs))
|
|
(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 -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]
|
|
[mk-dim-front -mk-dim-front]
|
|
[mk-dim-back -mk-dim-back]
|
|
[dim-front #f]
|
|
[dim-back #f]
|
|
[is-dim? #f]
|
|
[flipped? #f]
|
|
[semi-flipped? #f]
|
|
[can-flip? #t]
|
|
[can-move? #t]
|
|
[snap-back? #f]
|
|
[stay-region #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?
|
|
(if flipped?
|
|
(unless dim-back
|
|
(set! dim-back (mk-dim-back)))
|
|
(unless 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
|
|
(lambda ()
|
|
(set! flipped? (not flipped?))
|
|
(refresh))]
|
|
[semi-flip
|
|
(lambda ()
|
|
(set! semi-flipped? (not semi-flipped?))
|
|
(refresh))]
|
|
[face-up (lambda () (when flipped? (flip)))]
|
|
[face-down (lambda () (unless flipped? (flip)))]
|
|
[dim (case-lambda
|
|
[() is-dim?]
|
|
[(v)
|
|
(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
|
|
(lambda ()
|
|
(case suit-id
|
|
[(1) 'clubs]
|
|
[(2) 'diamonds]
|
|
[(3) 'hearts]
|
|
[(4) 'spades]
|
|
[else 'unknown]))]
|
|
[get-value
|
|
(lambda () value)]
|
|
[user-can-flip
|
|
(case-lambda
|
|
[() can-flip?]
|
|
[(f) (set! can-flip? (and f #t))])]
|
|
[user-can-move
|
|
(case-lambda
|
|
[() can-move?]
|
|
[(f) (set! can-move? (and f #t))])]
|
|
[snap-back-after-move
|
|
(case-lambda
|
|
[() snap-back?]
|
|
[(f) (set! snap-back? (and f #t))])]
|
|
[stay-in-region
|
|
(case-lambda
|
|
[() stay-region]
|
|
[(r) (set! stay-region r)])]
|
|
[home-region
|
|
(case-lambda
|
|
[() home-reg]
|
|
[(r) (set! home-reg r)])]
|
|
[card-width (lambda () width)]
|
|
[card-height (lambda () height)])
|
|
(override
|
|
[resize
|
|
(lambda (w h) (void))]
|
|
[get-extent
|
|
(lambda (dc x y w h descent space lspace rspace)
|
|
(map
|
|
(lambda (b)
|
|
(when b
|
|
(set-box! b 0)))
|
|
(list descent space lspace rspace))
|
|
(when w (set-box! w width))
|
|
(when h (set-box! h height)))]
|
|
[draw
|
|
(lambda (dc x y left top right bottom dx dy draw-caret)
|
|
(check-dim)
|
|
(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)])
|
|
(public
|
|
[remember-location
|
|
(lambda (pb)
|
|
(send pb get-snip-location this save-x save-y))]
|
|
[back-to-original-location
|
|
(lambda (pb)
|
|
(when snap-back?
|
|
(send pb move-to this (unbox save-x) (unbox save-y)))
|
|
(when home-reg
|
|
(let ([xbox (box 0)]
|
|
[ybox (box 0)])
|
|
(send pb get-snip-location this xbox ybox #f)
|
|
;; Completely in the region?
|
|
(let* ([l (unbox xbox)]
|
|
[rl (region-x home-reg)]
|
|
[r (+ l width)]
|
|
[rr (+ rl (region-w home-reg))]
|
|
[t (unbox ybox)]
|
|
[rt (region-y home-reg)]
|
|
[b (+ t height)]
|
|
[rb (+ rt (region-h home-reg))])
|
|
(when (or (< l rl) (> r rr)
|
|
(< t rt) (> b rb))
|
|
;; Out of the region - completely or partly?
|
|
(if (and (or (<= rl l rr) (<= rl r rr))
|
|
(or (<= rt t rb) (<= rt b rb)))
|
|
;; Just slightly out
|
|
(send pb move-to this
|
|
(min (max l rl) (- rr width))
|
|
(min (max t rt) (- rb height)))
|
|
;; Completely out
|
|
(send pb move-to this (unbox save-x) (unbox save-y))))))))])
|
|
(sequence
|
|
(super-init)
|
|
(set-count 1)
|
|
(set-snipclass sc)
|
|
(flip)))))
|
|
|
|
|