(module classes mzscheme
  (require mzlib/class
	   mzlib/class100
	   (prefix mred: mred)
	   mzlib/list
	   mzlib/etc
	   (prefix util: "utils.ss")
	   "constants.ss"
	   "make-cards.ss"
	   "region.ss"
	   string-constants
	   "../show-help.ss"
	   "../show-scribbling.ss")

  (provide pasteboard%
	   table%)

  (define pasteboard%
    (class100 mred:pasteboard% ()
      (inherit begin-edit-sequence end-edit-sequence get-admin
	       invalidate-bitmap-cache
	       find-next-selected-snip find-first-snip find-snip
	       set-before set-after
	       add-selected is-selected? no-selected set-selected remove-selected
	       get-snip-location move-to
	       dc-location-to-editor-location
	       set-selection-visible)
      (private-field
	[select-one? #t]
	[select-backward? #f]
	[raise-to-front? #f]
	[button-map '((left #f #f #t)
		      (middle #t #f #t)
		      (right #f #t #f))]

	[do-on-double-click 'flip]
	[do-on-single-click void]

	[selecting? #f]
	[dragging? #f]
	[bg-click? #f]
	[click-base #f]
        [last-click #f]
	[regions null])
      (private
	[get-snip-bounds
	 (lambda (s)
	   (let ([xbox (box 0)]
		 [ybox (box 0)])
	     (get-snip-location s xbox ybox #f)
	     (let ([l (unbox xbox)]
		   [t (unbox ybox)])
	       (get-snip-location s xbox ybox #t)
	       (values l t (unbox xbox) (unbox ybox)))))]
	[for-each-selected
	 (lambda (f)
	   (let loop ([snip (find-next-selected-snip #f)])
	     (when snip
	       (f snip)
	       (loop (find-next-selected-snip snip)))))]
	[make-overlapping-list
	 (lambda (s so-far behind?)
	   (let-values ([(sl st sr sb) (get-snip-bounds s)])
	     (let loop ([t (find-first-snip)][so-far so-far][get? (not behind?)])
	       (cond
		[(not t) so-far]
		[(eq? s t) (if behind?
			       (loop (send t next) so-far #t)
			       so-far)]
		[get?
		 (let ([l (if (and (not (memq t so-far))
				   (let-values ([(tl tt tr tb) 
						 (get-snip-bounds t)])
				     (and (or (<= sl tl sr)
					      (<= sl tr sr))
					  (or (<= st tt sb)
					      (<= st tb sb)))))
			      (make-overlapping-list t (cons t so-far) behind?)
			      so-far)])
		   (loop (send t next) l #t))]
		[else
		 (loop (send t next) so-far #f)]))))]
	[get-reverse-selected-list
	 (lambda ()
	   (let loop ([s (find-next-selected-snip #f)][l null])
	     (if s
		 (loop (find-next-selected-snip s) (cons s l))
		 l)))]
	[shuffle
	 (lambda (selected-list) ; cards to shuffle in back->front order
	   (let* ([permuted-list
		   (util:shuffle-list selected-list 7)]
		  [get-pos
		   (lambda (s)
		     (let ([xb (box 0)]
			   [yb (box 0)])
		       (get-snip-location s xb yb)
		       (cons (unbox xb) (unbox yb))))]
		  [sel-loc-list (map get-pos selected-list)]
		  [perm-loc-list (map get-pos permuted-list)])
	     (for-each
	      (lambda (s start-pos end-pos)
		(let* ([sx (car start-pos)]
		       [sy (cdr start-pos)]
		       [ex (car end-pos)]
		       [ey (cdr end-pos)]
		       [steps (max 1 (floor (/ 50 (length selected-list))))])
		  (let loop ([i 1])
		    (unless (> i steps)
		      (let ([x (+ sx (* (/ i steps) (- ex sx)))]
			    [y (+ sy (* (/ i steps) (- ey sy)))])
			(move-to s x y)
			(mred:flush-display)
			(loop (add1 i)))))))
	      permuted-list perm-loc-list sel-loc-list)
	     (let loop ([l permuted-list])
	       (unless (null? l)
		 (set-before (car l) #f)
		 (loop (cdr l))))
	     (no-selected)))]
	[update-region 
	 (lambda (region)
	   (let-values ([(sx sy sw sh) (get-region-box region)])
	     (invalidate-bitmap-cache sx sy sw sh)))])
      (public
        [only-front-selected
         (lambda ()
 	   (let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)])
	     (when s
               (if (eq? s ok)
                   (loop (find-next-selected-snip s)
                         (send ok next))
                   (let loop ([s s][l (list s)])
                     (let ([next (find-next-selected-snip s)])
                       (if next
                           (loop next (cons s l))
                           (for-each (lambda (s)
                                       (remove-selected s))
                                     l))))))))])
      (override
	[on-paint
	 (lambda (before? dc l t r b dx dy caret)
	   (when before?
	     (for-each
	      (lambda (region)
		(when (region-paint-callback region)
		  (let-values ([(sx sy sw sh) (get-region-box region)])
		    ((region-paint-callback region) dc (+ dx sx) (+ dy sy) sw sh)))
		(when (region-label region)
		  (let ([old-b (send dc get-brush)]
			[old-p (send dc get-pen)])
		    (let-values ([(sx sy sw sh) (get-region-box region)])
		      (send dc set-brush white-brush)
		      (send dc set-pen no-pen)
		      (send dc draw-rectangle (+ dx sx) (+ dy sy) sw sh)
		      (send dc set-pen dark-gray-pen)
		      (draw-roundish-rectangle dc (+ dx sx) (+ dy sy) sw sh)
		      (let ([text (region-label region)])
			(if (string? text)
			    (let ([old-f (send dc get-font)])
			      (send dc set-font nice-font)
			      (let-values ([(x y d a) (send dc get-text-extent text)])
				(send dc draw-text text
				      (+ dx sx (/ (- sw x) 2))
				      (if (region-button? region)
					  ;; Since we use size-in-pixels, the letters
					  ;;  should really be 12 pixels high (including
					  ;;  the descender), but the space above the letter
					  ;;  can vary by font; center on 12, splitting
					  ;;  the difference for the descender
					  (+ dy sy (/ (- sh 12) 2) (- 12 y (/ d -2)))
					  (+ dy sy 5))))
			      (send dc set-font old-f))
			    (send dc draw-bitmap text
				  (+ dx sx (/ (- sw (send text get-width)) 2))
				  (+ dy sy (/ (- sh (send text get-height)) 2))
				  'solid black-color
				  (send text get-loaded-mask))))
		      (when (region-hilite? region)
			(send dc set-brush hilite-brush)
			(send dc set-pen no-pen)
			(send dc draw-rectangle (+ dx sx 1) (+ dy sy 1) (- sw 2) (- sh 2))))
		    (send dc set-brush old-b)
		    (send dc set-pen old-p))))
	      regions)))])
      (augment
	[after-select
	 (lambda (s on?)
	   (inner (void) after-select s on?)
	   (unless (or (not on?) selecting?)
	     (set! selecting? #t)
	     (if select-one?
		 (when raise-to-front?
		   (set-before s #f))
		 (begin
		   (begin-edit-sequence)
		   (let ([l (make-overlapping-list s (list s) select-backward?)])
		     (for-each (lambda (i) (add-selected i)) l))
		   (when raise-to-front?
		     (let loop ([snip (find-next-selected-snip #f)][prev #f])
		       (when snip
			 (if prev
			     (set-after snip prev)
			     (set-before snip #f))
			 (loop (find-next-selected-snip snip) snip))))
		   (end-edit-sequence)))
	     (set! selecting? #f)))]
	[on-interactive-move
	 (lambda (e)
	   (inner (void) on-interactive-move e)
	   (for-each (lambda (region) (set-region-decided-start?! region #f)) regions)
	   (for-each-selected (lambda (snip) (send snip remember-location this)))
	   (set! dragging? #t))])
      (override
	[interactive-adjust-move
	 (lambda (snip xb yb)
	   (super interactive-adjust-move snip xb yb)
	   (let-values ([(l t r b) (get-snip-bounds snip)])
	     (let-values ([(rl rt rw rh)
			   (let ([r (send snip stay-in-region)])
			     (if r
				 (values (region-x r) (region-y r)
					 (region-w r) (region-h r))
				 (let ([wb (box 0)][hb (box 0)])
				   (send (get-admin) get-view #f #f wb hb)
				   (values 0 0 (unbox wb) (unbox hb)))))])
	       (let ([max-x (- (+ rl rw) (- r l))]
		     [max-y (- (+ rt rh) (- b t))])
		 (when (< (unbox xb) rl)
		   (set-box! xb rl))
		 (when (> (unbox xb) max-x)
		   (set-box! xb max-x))
		 (when (< (unbox yb) rt)
		   (set-box! yb rt))
		 (when (> (unbox yb) max-y)
		   (set-box! yb max-y))))))])
      (augment
	[after-interactive-move
	 (lambda (e)
           (when dragging?
             (set! dragging? #f)
             (inner (void) after-interactive-move e)
             (for-each-selected (lambda (snip) (send snip back-to-original-location this)))
             (let ([cards (get-reverse-selected-list)])
               (only-front-selected) ; in case overlap changed
               (for-each
                (lambda (region)
                  (when (region-hilite? region)
                    (mred:queue-callback
                                        ; Call it outside the current edit sequence
                     (lambda ()
                       ((region-callback region) cards)
                       (unhilite-region region)))))
                regions))))])
      (override
	[on-default-event
	 (lambda (e)
	   (let ([click (let ([c (or (and (send e button-down? 'left) 'left)
                                     (and (send e button-down? 'right) 'right)
                                     (and (send e button-down? 'middle) 'middle))])
                          (cond
                           [(eq? c last-click) c]
                           [(not last-click) c]
                           ;; Move/drag event has different mouse button,
                           ;; and there was no mouse up. Don't accept the
                           ;; click, yet.
                           [else #f]))])
             (set! last-click click)
	     (when click
	       (let* ([actions (cdr (assoc click button-map))]
		      [one? (list-ref actions 0)]
		      [backward? (list-ref actions 1)]
		      [raise? (list-ref actions 2)])
		 (unless (and (eq? backward? select-backward?)
			      (eq? one? select-one?)
			      (eq? raise? raise-to-front?))
		   (set! select-one? one?)
		   (set! select-backward? backward?)
		   (set! raise-to-front? raise?)
		   (no-selected))))
	     (let*-values ([(lx ly) (dc-location-to-editor-location 
				     (send e get-x) 
				     (send e get-y))]
			   [(s) (find-snip lx ly)])
	       ; Clicking on a "selected" card unselects others
	       ; in this interface
	       (when (send e button-down?)
		 (unless (or (not click-base) (not s) (eq? s click-base))
		   (no-selected))
		 (set! click-base s))
	       (when (and dragging? click-base (send click-base user-can-move))
		 (for-each
		  (lambda (region)
		    (when (and (not (region-button? region))
			       (region-callback region)
			       (or (not (region-decided-start? region))
				   (region-can-select? region)))
		      (let-values ([(sx sy sw sh) (get-region-box region)])
			(let ([in? (and (<= sx lx (+ sx sw))
					(<= sy ly (+ sy sh)))])
			  (unless (region-decided-start? region)
			    (set-region-decided-start?! region #t)
			    (set-region-can-select?! region (not in?)))
			  (when (and (not (eq? in? (region-hilite? region)))
				     (region-can-select? region))
			    (set-region-hilite?! region in?)
			    (when (region-interactive-callback region)
			      ((region-interactive-callback region) in? (get-reverse-selected-list)))
			    (invalidate-bitmap-cache sx sy sw sh))))))
		  regions))
	       ; Can't move => no raise, either
	       (unless (or (not click-base) (send click-base user-can-move))
		 (set! raise-to-front? #f))
	       (let ([was-bg? bg-click?])
		 (if (send e button-down?)
		     (set! bg-click? (not s))
		     (when (and bg-click? (not (send e dragging?)))
		       (set! bg-click? #f)))
		 (unless bg-click?
		   (super on-default-event e))
                 (when (and bg-click? dragging?)
                   ;; We didn't call super on-default-event, so we need
                   ;;  to explicitly end the drag:
                   (after-interactive-move e))
		 (when bg-click?
		   ; Check for clicking on a button region:
		   (for-each
		    (lambda (region)
		      (when (and (region-button? region)
				 (region-callback region))
			(let-values ([(sx sy sw sh) (get-region-box region)])
			  (let ([in? (and (<= sx lx (+ sx sw))
					  (<= sy ly (+ sy sh)))])
			    (unless (region-decided-start? region)
			      (set-region-decided-start?! region #t)
			      (set-region-can-select?! region in?))
			    (when (and (not (eq? in? (region-hilite? region)))
				       (region-can-select? region))
			      (set-region-hilite?! region in?)
			      (invalidate-bitmap-cache sx sy sw sh))))))
		    regions))
		 (when (and was-bg? (not bg-click?))
		   ; Callback hilighted button:
		   (for-each
		    (lambda (region)
		      (when (region-button? region) 
			(set-region-decided-start?! region #f)
			(when (region-hilite? region)
			  (mred:queue-callback
			   ; Call it outside the current edit sequence
			   (lambda ()
			     ((region-callback region))
			     (unhilite-region region))))))
		    regions)))
	       (when (and (send e button-down?)
			  click-base
			  (not (send click-base user-can-move)))
		 (no-selected)))
	     (when (and click click-base)
	       (do-on-single-click click-base))))]
	[on-double-click
	 (lambda (s e)
	   (cond
	    [(eq? do-on-double-click 'flip)
	     (begin-edit-sequence)
	     (let ([l (get-reverse-selected-list)])
	       (for-each 
		(lambda (s) 
		  (when (send s user-can-flip)
		    (send s flip)))
		l)
	       (let loop ([l (reverse l)])
		 (unless (null? l)
		   (set-before (car l) #f)
		   (loop (cdr l)))))
	     (no-selected)
	     (end-edit-sequence)]
	    [do-on-double-click
	     (do-on-double-click s)]
	    [else (void)]))])
      (public
	[get-all-list
	 (lambda ()
	   (let loop ([t (find-first-snip)][accum null])
	     (cond
	      [(not t) (reverse accum)]
	      [else (loop (send t next) (cons t accum))])))]
	[get-full-box
	 (lambda ()
	   (let ([xb (box 0)][yb (box 0)]
			     [wb (box 0)][hb (box 0)])
	     (send (get-admin) get-view xb yb wb hb)
	     (values 0 0 (unbox wb) (unbox hb))))]
	[get-region-box
	 (lambda (region)
	   (values (region-x region)
		   (region-y region)
		   (region-w region)
		   (region-h region)))]
	[add-region
	 (lambda (r)
	   (set! regions (append regions (list r)))
	   (update-region r))]
	[remove-region
	 (lambda (r)
	   (set! regions (remq r regions))
	   (update-region r))]
	[unhilite-region
	 (lambda (region)
	   (set-region-hilite?! region #f)
	   (update-region region))]
	[hilite-region
	 (lambda (region)
	   (set-region-hilite?! region #t)
	   (update-region region))]
	[set-double-click-action
	 (lambda (a)
	   (set! do-on-double-click a))]
	[set-single-click-action
	 (lambda (a)
	   (set! do-on-single-click a))]
	[set-button-action
	 (lambda (button action)
	   (let ([map
		  (case action
		    [(drag/one) (list #t #f #f)]
		    [(drag-raise/one) (list #t #f #t)]
		    [(drag/above) (list #f #f #f)]
		    [(drag-raise/above) (list #f #f #t)]
		    [(drag/below) (list #f #t #f)]
		    [(drag-raise/below) (list #f #t #t)]
		    [else (error 'set-button-action "unknown action: ~s" action)])])
	     (set! button-map
		   (cons
		    (cons button map)
		    (remq (assoc button button-map)
			  button-map)))))])
      (sequence
	(super-init)
	(set-selection-visible #f))))

  (define table%
    (class mred:frame%
      (init title w h)
      (inherit reflow-container)
      (augment*
	[on-close
	 (lambda ()
	   (exit))])
      (public*
	[table-width (lambda ()
		       (reflow-container)
		       (let-values ([(x y w h) (send pb get-full-box)])
			 w))]
	[table-height (lambda ()
			(reflow-container)
			(let-values ([(x y w h) (send pb get-full-box)])
			  h))]
	[begin-card-sequence
	 (lambda ()
	   (set! in-sequence (add1 in-sequence))
	   (send pb begin-edit-sequence))]
	[end-card-sequence
	 (lambda ()
	   (send pb end-edit-sequence)
	   (set! in-sequence (sub1 in-sequence)))]
	[add-card
	 (lambda (card x y)
	   (position-cards (list card) x y (lambda (p) (values 0 0)) add-cards-callback))]
	[add-cards
	 (opt-lambda (cards x y [offset (lambda (p) (values 0 0))])
	   (position-cards cards x y offset add-cards-callback))]
	[add-cards-to-region
	 (lambda (cards region)
	   (position-cards-in-region cards region add-cards-callback))]
	[move-card
	 (lambda (card x y)
	   (position-cards (list card) x y (lambda (p) (values 0 0)) move-cards-callback))]
	[move-cards
	 (opt-lambda (cards x y  [offset (lambda (p) (values 0 0))])
	   (position-cards cards x y offset move-cards-callback))]
	[move-cards-to-region
	 (lambda (cards region)
	   (position-cards-in-region cards region (lambda (c x y) (send pb move-to c x y))))]
	[card-location
	 (lambda (card)
	   (let ([x (box 0)]
		 [y (box 0)])
	     (unless (send pb get-snip-location card x y)
	       (raise-mismatch-error 'card-location "card not on table: " card))
	     (values (unbox x) (unbox y))))]
	[all-cards
	 (lambda ()
	   (send pb get-all-list))]
	[remove-card
	 (lambda (card)
	   (remove-cards (list card)))]
	[remove-cards
	 (lambda (cards)
	   (begin-card-sequence)
	   (for-each (lambda (c) (send pb release-snip c)) cards)
	   (end-card-sequence))]
	[flip-card
	 (lambda (card)
	   (flip-cards (list card)))]
	[flip-cards
	 (lambda (cards)
	   (if (or (not animate?) (positive? in-sequence))
	       (for-each (lambda (c) (send c flip)) cards)
	       (let ([flip-step
		      (lambda (go)
			(let ([start (current-milliseconds)])
			  (begin-card-sequence)
			  (go)
			  (end-card-sequence)
			  (pause (max 0 (- (/ ANIMATION-TIME ANIMATION-STEPS)
					   (/ (- (current-milliseconds) start) 1000))))))])
		 (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)))]
	[cards-face-up
	 (lambda (cards)
	   (flip-cards (filter (lambda (c) (send c face-down?)) cards)))]
	[card-face-down
	 (lambda (card)
	   (cards-face-down (list card)))]
	[cards-face-down
	 (lambda (cards)
	   (flip-cards (filter (lambda (c) (not (send c face-down?))) cards)))]
	[card-to-front
	 (lambda (card)
	   (send pb set-before card #f))]
	[card-to-back
	 (lambda (card)
	   (send pb set-after card #f))]
	[stack-cards
	 (lambda (cards)
	   (unless (null? cards)
	     (send pb only-front-selected) ; in case overlap changes
	     (begin-card-sequence)
	     (let loop ([l (cdr cards)][behind (car cards)])
	       (unless (null? l)
		 (send pb set-after (car l) behind)
		 (loop (cdr l) (car l))))
	     (end-card-sequence)))]
	[add-region
	 (lambda (r)
	   (send pb add-region r))]
	[remove-region
	 (lambda (r)
	   (send pb remove-region r))]
	[hilite-region
	 (lambda (r)
	   (send pb hilite-region r))]
	[unhilite-region
	 (lambda (r)
	   (send pb unhilite-region r))]
	[set-button-action
	 (lambda (button action)
	   (send pb set-button-action button action))]
	[set-double-click-action
	 (lambda (a)
	   (send pb set-double-click-action a))]
	[set-single-click-action
	 (lambda (a)
	   (send pb set-single-click-action a))]
	[pause
	 (lambda (duration)
	   (let ([s (make-semaphore)]
		 [a (alarm-evt (+ (current-inexact-milliseconds)
				  (* duration 1000)))]
		 [enabled? (send c is-enabled?)])
	     ;; Can't move the cards during this time:
	     (send c enable #f)
	     (mred:yield a)
	     (when enabled?
	       (send c enable #t))))]
	[animated
	 (case-lambda 
	  [() animate?]
	  [(on?) (set! animate? (and on? #t))])]
	[create-status-pane
	 (lambda ()
	   (let ([p (make-object mred:horizontal-pane% this)])
	     (set! msg (new mred:message% 
			    [parent p]
			    [label ""]
			    [stretchable-width #t]))
	     p))]
	[set-status
	 (lambda (str)
	   (when msg
	     (send msg set-label str)))]
	[add-help-button
	 (lambda (pane where title tt?)
	   (new mred:button% 
		(parent pane)
		(label (string-constant help-menu-label))
		(callback
		 (let ([show-help (show-help where title tt?)])
		   (lambda x
		     (show-help))))))]
	[add-scribble-button
	 (lambda (pane mod tag)
	   (new mred:button% 
		(parent pane)
		(label (string-constant help-menu-label))
		(callback
		 (let ([show-help (show-scribbling mod tag)])
		   (lambda x
		     (show-help))))))])
      (begin
	(define msg #f)
	(define add-cards-callback
	 (lambda (card x y)
	   (send pb insert card #f x y)))
        (define move-cards-callback
	 (lambda (card x y)
	   (send pb move-to card x y)
	   (send card remember-location pb))))
      (begin
	(define animate? #t)
	(define in-sequence 0))
      (private*
        [position-cards
	 (lambda (cards x y offset set)
	   (let ([positions (let loop ([l cards][n 0])
			      (if (null? l)
				  null
				  (let-values ([(dx dy) (offset n)])
				    (cons (cons (+ x dx) (+ y dy))
					  (loop (cdr l) (add1 n))))))])
	     (if (or (not animate?) (positive? in-sequence) (eq? set add-cards-callback))
		 (begin
		   (begin-card-sequence)
		   (for-each (lambda (c p) (set c (car p) (cdr p))) cards positions)
		   (end-card-sequence))
		 (let-values ([(moving-cards
				source-xs
				source-ys
				dest-xs
				dest-ys)
			       (let loop ([cl cards][pl positions])
				 (if (null? cl)
				     (values null null null null null)
				     (let-values ([(mcl sxl syl dxl dyl) (loop (cdr cl) (cdr pl))]
						  [(card) (car cl)]
						  [(x y) (values (caar pl) (cdar pl))])
				       (let ([xb (box 0)][yb (box 0)])
					 (send pb get-snip-location card xb yb)
					 (let ([sx (unbox xb)][sy (unbox yb)])
					   (if (and (= x sx) (= y sy))
					       (values mcl sxl syl dxl dyl)
					       (values (cons card mcl)
						       (cons sx sxl)
						       (cons sy syl)
						       (cons x dxl)
						       (cons y dyl))))))))])
		   (let ([time-scale
			  ;; An animation speed that looks good for
			  ;; long moves looks too slow for short
			  ;; moves. So scale the time back by as much
			  ;; as 50% if the max distance for all cards
			  ;; is short.
			  (let ([max-delta (max (apply max 0 (map (lambda (sx dx)
								    (abs (- sx dx)))
								  source-xs dest-xs))
						(apply max 0 (map (lambda (sy dy)
								    (abs (- sy dy)))
								  source-ys dest-ys)))])
			    (if (max-delta . < . 100)
				(/ (+ max-delta 100) 200.0)
				1))])
		     (let loop ([n 1])
		       (unless (> n ANIMATION-STEPS)
			 (let ([start (current-milliseconds)]
			       [scale (lambda (s d)
					(+ s (* (/ n ANIMATION-STEPS) (- d s))))])
			   (begin-card-sequence)
			   (for-each
			    (lambda (c sx sy dx dy)
			      (set c (scale sx dx) (scale sy dy)))
			    moving-cards
			    source-xs source-ys
			    dest-xs dest-ys)
			   (end-card-sequence)
			   (pause (max 0 (- (/ (* time-scale ANIMATION-TIME) ANIMATION-STEPS)
					    (/ (- (current-milliseconds) start) 1000))))
			   (loop (add1 n))))))))
	     ;; In case overlap changed:
	     (send pb only-front-selected)))]
	[position-cards-in-region
	 (lambda (cards r 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) card-width)
                                           (send (car cards) card-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)))
	(define pb (make-object pasteboard%)))
      (send c min-client-width (+ 10 (inexact->exact (floor (* w (send back get-width))))))
      (send c min-client-height (+ 10 (inexact->exact (floor (* h (send back get-height))))))
      (send c stretchable-width #f)
      (send c stretchable-height #f)
      (send this stretchable-width #f)
      (send this stretchable-height #f)
      (send c set-editor pb)))

  (define (draw-roundish-rectangle dc x y w h)
    (send dc draw-line (+ x 1) y (+ x w -2) y)
    (send dc draw-line (+ x 1) (+ y h -1) (+ x w -2) (+ y h -1))
    (send dc draw-line x (+ y 1) x (+ y h -2))
    (send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -2))))