198 lines
4.9 KiB
Scheme
198 lines
4.9 KiB
Scheme
|
|
(module card-class mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "class100.ss")
|
|
(prefix mred:(lib "mred.ss" "mred"))
|
|
"snipclass.ss"
|
|
"region.ss")
|
|
|
|
(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 card%
|
|
(class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back)
|
|
(inherit set-snipclass set-count get-admin)
|
|
(private-field
|
|
[suit-id -suit-id]
|
|
[value -value]
|
|
[width -width]
|
|
[height -height]
|
|
[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]
|
|
[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])
|
|
(private
|
|
[refresh
|
|
(lambda ()
|
|
(let ([a (get-admin)])
|
|
(when a
|
|
(send a needs-update this 0 0 width height))))]
|
|
[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))))))])
|
|
(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))])]
|
|
[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)
|
|
(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)))])
|
|
(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)))))
|
|
|
|
|