(module play mzscheme
  (require (lib "class.ss")
           (lib "mred.ss" "mred")
           (lib "etc.ss"))

  ;; The size of a pebble drawn on the screen.
  ;; The rest of the board generally scales with this value.
  (define pebble-width 16)

  ;; Derived contants:
  ;;   Space between pebbles:
  (define pebble-space (/ pebble-width 2))
  ;;   Width and height of a card to purchase:
  (define card-width (* 9 pebble-width))
  (define card-height (* 4/3 card-width))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  Game data structures
  
  ;; The pebble colors:
  (define pebble-colors '(white red green blue yellow))

  ;; random-color : -> symbol
  ;;  Chooses a random pebble color
  (define (random-color)
    (list-ref pebble-colors (random (length pebble-colors))))

  ;; TEST: if we pick enough pebbles, we'll eventually
  ;;  pick any given pebble, and no random result will
  ;;  be a non-pebble.
  (for-each (lambda (c1)
              (let loop ()
                (let ([c2 (random-color)])
                  (unless (member c2 pebble-colors)
                    (error 'random-color "bad result: ~e" c2))
                  (unless (eq? c1 c2)
                    (loop)))))
            pebble-colors)
  
  ;; A (buyable) card is 
  ;;  (make-card num list-of-sym)
  ;; where the first num is the star count and
  ;; the list is the set of pebbles needed to
  ;; buy the card
  (define-struct card (stars pebbles))

  ;; random-card : -> card
  ;;  Generates a card with a random star count
  ;;  and random set of five pebbles.
  (define (random-card)
    (make-card (random 3)
	       (list (random-color) (random-color)
		     (random-color) (random-color)
		     (random-color))))

  ;; TEST: every random card is well formed, and we pick
  ;; each possible star combination
  (define (pebble-color? p) (memq p pebble-colors))
  (for-each (lambda (star-count)
              (let loop ()
                (let ([c (random-card)])
                  (unless (and (<= 0 (card-stars c) 2)
                               (andmap pebble-color?
                                       (card-pebbles c)))
                    (error 'random-card "bad card: ~e" c))
                  (unless (= star-count (card-stars c))
                    (loop)))))
            '(0 1 2))
                    
  ;; A barter-line is
  ;;  (cons list-of-sym list-of-sym)
  ;; The first list-of-sym reprsents trade-in pebbles,
  ;;  and the second represents what you get back
  ;; A barter-card is a list-of-barter-line

  ;; barter-cards : list-of-barter-cards
  (define barter-cards
    '((((white) . (red yellow))
       ((red) . (blue green white))
       ((blue blue) . (green white))
       ((yellow) . (white red green green))
       ((white blue) . (red red yellow yellow)))
      (((white) . (red red))
       ((blue) . (yellow yellow green))
       ((green green) . (white white))
       ((red) . (blue blue yellow yellow))
       ((blue blue) . (red red white green)))
      (((blue) . (green green))
       ((white) . (green red yellow))
       ((red) . (yellow blue white))
       ((red green) . (blue blue yellow))
       ((white white green) . (blue yellow red)))
      (((red) . (green blue))
       ((blue) . (red green yellow))
       ((yellow) . (white white red))
       ((green) . (white red yellow blue))
       ((white red) . (yellow yellow blue green)))
      (((yellow) . (white green))
       ((red red) . (blue yellow))
       ((green yellow) . (red blue))
       ((blue) . (white white green yellow))
       ((green green) . (white yellow red blue)))
      (((green) . (yellow white))
       ((green) . (blue red red))
       ((white) . (blue yellow red))
       ((green blue) . (white red yellow))
       ((white white) . (blue yellow green green)))
      (((blue) . (white yellow))
       ((white white) . (green red))
       ((red yellow) . (blue blue))
       ((green white) . (red red blue))
       ((yellow yellow blue) . (green green white)))
      (((yellow) . (blue red))
       ((blue) . (white white green))
       ((yellow white) . (blue green))
       ((yellow yellow) . (blue red green))
       ((red red white) . (green yellow blue)))
      (((green) . (blue red))
       ((yellow) . (white blue red))
       ((yellow white) . (red green))
       ((green red) . (yellow white blue))
       ((yellow red white) . (green green blue)))
      (((red) . (white white))
       ((blue) . (yellow white green))
       ((yellow blue) . (green red))
       ((red) . (blue green yellow white))
       ((white green) . (yellow yellow red blue)))))
  
  ;; Choose two cards randomly on startup:
  (define-values (barter-card1 barter-card2)
    (let* ([r1 (random 9)]
           [r2 (+ r1 (random (- 10 r1)))])
      (values (list-ref barter-cards r1)
              (list-ref barter-cards r2))))
  
  ;; TEST: at least check that each barter-card matches the
  ;;  data defn:
  (for-each (lambda (bc)
              (and (list? bc)
                   (list? (car bc))
                   (andmap pebble-color? (car bc))
                   (andmap pebble-color? (cdr bc))))
            (list barter-card1 barter-card2))
  
  
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  Game GUI support

  ;; Graphics objects for painting pebbles and cards:
  (define brushes (map (lambda (s)
                         (cons s
                               (make-object brush% (symbol->string s) 'solid)))
                       pebble-colors))
  (define light-brushes (map (lambda (b)
                               (let ([c (send (cdr b) get-color)]
                                     [lighter (lambda (v) (- 255 (quotient (- 255 v) 2)))])
                                 (cons (car b)
                                       (make-object brush% 
                                         (make-object color% 
                                           (lighter (send c red))
                                           (lighter (send c green))
                                           (lighter (send c blue)))
                                         'solid))))
                             brushes))
  (define gray-brush (make-object brush% "light gray" 'solid))
  (define black-pen (make-object pen% "black" 1 'solid))
  (define gray-pen (make-object pen% "gray" 1 'solid))
  (define card-font (make-object font% (* 2 pebble-width) 'system 'normal 'normal))

  ;; This list is used to force a refresh of canvases when they
  ;; are disabled or enabled (i.e., work around a deficiency
  ;; in the GUI toolbox):
  (define need-refresh-list null)
  (define (refresh-all)
    (for-each (lambda (w) (send w refresh))
              need-refresh-list))
  
  ;; A click-canvas% is a canvas that responds to mouse clicks much
  ;;  like a button. It's also non-stretchy and has a margin, like a
  ;;  button. The content of the canvas is partly drawn automatically,
  ;;  including the border and a background that's sensitive to the
  ;;  click state. Override `paint-rest' to finish the content, and
  ;;  override `on-click' to handle a click.
  (define click-canvas% 
    (class canvas%
      (init-field width height)
      (inherit get-dc min-client-width min-client-height refresh is-enabled?)
      (define tracking? #f)
      (define hilite? #f)
      (define/override (on-event e)
        (cond
          [(and (send e button-up?)
                tracking?)
           (set! tracking? #f)
           (when hilite?
             (set! hilite? #f)
             (on-click))
           (refresh)]
          [(send e button-down?)
           (set! tracking? #t)
           (set! hilite? #t)
           (refresh)]
          [(and (send e dragging?)
                tracking?)
           (let ([on? (and (<= 0 (send e get-x) card-width)
                           (<= 0 (send e get-y) card-height))])
             (unless (eq? on? hilite?)
               (set! hilite? on?)
               (refresh)))]
          [(send e moving?)
           (set! tracking? #f)
           (when hilite?
             (set! hilite? #f)
             (refresh))]))
      (define/override (on-paint)
        (let ([dc (get-dc)])
          (send dc set-pen black-pen)
          (send dc set-brush (if hilite?
                                 gray-brush
                                 (cdr (assq 'white brushes))))
          (send dc draw-rectangle 0 0 width height)
          (let ([all-enabled? (let loop ([p this])
                                (or (not p)
                                    (and (or (not (is-a? p window<%>))
                                             (send p is-enabled?))
                                         (loop (send p get-parent)))))])
            (unless all-enabled?
              (send dc set-pen gray-pen))
            (paint-rest dc (not all-enabled?)))))

      ;; Override these two:
      ;;  paint-rest gets the dc to draw into; light? is
      ;;  #t when the canvas is disabled
      (define/public (paint-rest dc light?) 
	(void))
      ;;  on-click takes no arguments and reacts to a mouse
      ;;  click
      (define/public (on-click) 
	(void))
      
      (super-new [style '()]
                 [stretchable-width #f]
                 [stretchable-height #f]
                 [horiz-margin 5]
                 [vert-margin 5])
      (min-client-width width)
      (min-client-height height)
      (set! need-refresh-list (cons this need-refresh-list))))

  ;; draw-pebbles : dc<%> bool list-of-sym real real -> void
  ;;  Draws a row of pebbles into the given dc at the given
  ;;  position. If `light?' is true, the pebbles are drawn
  ;;  grayed out (for use with a disabled canvas)
  (define (draw-pebbles dc light? pebbles dx dy)
    (let loop ([x dx] [pebbles pebbles])
      (unless (null? pebbles)
        (send dc set-brush (cdr (assq (car pebbles) (if light? light-brushes brushes))))
        (send dc draw-ellipse x dy pebble-width pebble-width)
        (loop (+ x pebble-width pebble-space) (cdr pebbles)))))

  ;; barter-line-canvas% implements one line on a barter card.
  ;;  The line has enough room for 3 pebbles on the left of the
  ;;  equation and 4 on the right. Clicking the canvas sends a message
  ;;  to the current player object to try the barter. In that case,
  ;;  change the state of the game to buy mode.
  (define barter-line-canvas%
    (class click-canvas%
      (init-field barter-line)
      ;; Draw the pebble equation
      (define/override (paint-rest dc light?)
        (draw-pebbles dc light?
                      (car barter-line) 
                      (+ pebble-space
                         (* (- 3 (length (car barter-line)))
                            (+ pebble-width pebble-space)))
                      (/ pebble-width 2))
        (let ([x (+ (* 3 pebble-width)
                    (* 4 pebble-space))]
              [y1 (* 3/4 pebble-width)]
              [y2 (* 5/4 pebble-width)])
          (send dc draw-line x y1 (+ x pebble-width) y1)
          (send dc draw-line x y2 (+ x pebble-width) y2))
        (draw-pebbles dc light?
                      (cdr barter-line) 
                      (+ (* pebble-width 4)
                         (* pebble-space 5))
                      (/ pebble-width 2)))
      ;; Handle a click:
      (define/override (on-click)
        (if (send current-player try-barter barter-line)
            (buy-card!)
            (bell)))
      ;; Set up canvas size
      (super-new [height (* 2 pebble-width)]
                 [width (+ (* pebble-width 8) 
                           (* pebble-space 9))])))

  ;; A card-canvas% displays a buyable card (with stars and pebbles).
  ;; When clicked, it sends the current player object a message to try
  ;; to buy the card. If the buy succeeds, a new card is randomly
  ;; generated for this canvas.
  (define card-canvas% 
    (class click-canvas%
      ;; The card shown by the canvas, initially random:
      (define current-card (random-card))
      ;; Handle a click:
      (define/override (on-click)
        (if (send current-player try-to-buy current-card)
            (begin
              (set! current-card (random-card))
              (next-player!))
            (bell)))
      ;; Draw the card content:
      (define/override (paint-rest dc light?)
        (let ([stars (make-string (card-stars current-card) #\*)])
          (send dc set-font card-font)
          (let-values ([(w h d a) (send dc get-text-extent stars)])
            (send dc draw-text stars (/ (- card-width w) 2) (* 1/4 card-height))
            (draw-pebbles dc light?
                          (card-pebbles current-card)
                          (/ (- card-width (* pebble-width 5) (* pebble-space 4))
                             2)
                          (* 3/5 card-height)))))
      ;; Set canvas size:
      (super-new [width card-width]
                 [height card-height])))


  ;; A player% panel contains an individual player's state:
  ;;  pebble set and score. The player objects handles trying
  ;;  to barter or buy a card.
  (define player%
    (class vertical-panel%
      (super-new [style '(border)]
                 [alignment '(center center)])
      ;; The "title" is shown only during this player's turn:
      (define title (new message%
                         [label "This player's turn"]
                         [parent this]))
      (send title show #f)
      ;; pebble-canvas shows pebble-pb, which manages
      ;;  dragable pebbles as "snip"s
      (define pebble-pb (new pasteboard%))
      (define pebble-canvas (new editor-canvas% 
                                 [parent this]
                                 [editor pebble-pb]
                                 [min-height 100]))
      ;; The player's point display:
      (define status (new message%
                          [label "Points: 0"]
                          [parent this]
                          [stretchable-width #t]))
      (define points 0)
      
      ;; add-die-pebble : sym -> (void)
      ;;  Called when the player rolls the die. The
      ;;  die result can be "*", in which case the player
      ;;  gets to choose a color.
      (define/public (add-die-pebble color)
        (add-pebble (if (eq? color '*)
                        (let force-choice-loop ()
                          (let ([c 
                                 (get-choices-from-user
                                  "Star Die Roll"
                                  "Choose a color:"
                                  (map symbol->string pebble-colors))])
                            (if c
                                (list-ref pebble-colors (car c))
                                (force-choice-loop))))
                        color)))
      
      ;; add-pebble : sym -> (void)
      ;;  Adds a pebble to the player's pile. This is complex only
      ;;  because we want to put the pebble in a nice place (not
      ;;  overlapping an existing pebble)
      (define/public (add-pebble color)
	;; Loop to try x and y, and check whether this overlaps
	;;  with a pebble starting from "snip"
        (let loop ([x 0] [y 0] [snip (send pebble-pb find-first-snip)])
          (if snip
	      ;; Check the pebble's location
              (let ([px (box 0)]
                    [py (box 0)])
                (send pebble-pb get-snip-location snip px py)
                (if (and (<= x (unbox px) (+ x pebble-width))
                         (<= y (unbox py) (+ y pebble-width)))
		    ;; Overlaps, so try a new spot and start over
                    (loop (+ x pebble-width 2) 0 (send pebble-pb find-first-snip))
		    ;; So far so good; check the next pebble...
                    (loop x y (send snip next))))
	      ;; No more pebbles --- this spot is fine
              (send pebble-pb insert (make-object pebble% color) x y))))
      
      ;; try-to-buy-card : card -> bool
      ;;  Check whether the card can be bought (i.e., the necessary
      ;;  pebbles are available) and computes the player's new score
      ;;  on success
      (define/public (try-to-buy card)
        (find-pebbles
         (card-pebbles card)
         (lambda (used)
           ;; Buy succeeds.
	   ;; Remove the pebbles from this user.
           (for-each (lambda (p) (send pebble-pb delete p)) used)
	   ;; Calculate new poinrts
           (let ([r (length (get-all-pebbles))])
             (let ([pts
                    (case (card-stars card)
                      [(0) (case r
                             [(0) 80]
                             [(1) 60]
                             [(2) 50]
                             [else 40])]
                      [(1) (case r
                             [(0) 110]
                             [(1) 80]
                             [(2) 60]
                             [else 50])]
                      [(2) (case r
                             [(0) 150]
                             [(1) 110]
                             [(2) 80]
                             [else 60])])])
               (set! points (+ pts points))
               (send status set-label (format "Points: ~a" points))))
           #t)
         (lambda ()
	   ;; Can't buy
           #f)))
           
      ;; try-barter : barter-line -> bool
      ;;   Executes the specified barter, if possible
      (define/public (try-barter barter-line)
        (find-pebbles 
         (car barter-line)
         (lambda (used)
           ;; Found a barter
           (for-each (lambda (p) (send pebble-pb delete p)) used)
           (for-each (lambda (c) (add-pebble c)) (cdr barter-line))
           #t)
         (lambda ()
           #f)))

      ;; find-pebbles : list-of-sym (list-of-snip -> X) (-> X) -> X
      ;;  Tries to find "snip"s that match the given list of pebble
      ;;  colors. On success, it call `found-k' with the snips.
      ;;  If the pebbles can't be found, calls `fail-k'.
      (define/private (find-pebbles colors found-k fail-k)
        (let ([all-pebbles (get-all-pebbles)])
	  ;; Traverse the colors list, accumulating mathcing
	  ;;  pebbles into `used'; the `pebbles' list contains
	  ;;  pebbles that havne't been used, yet.
          (let loop ([colors colors]
                     [pebbles all-pebbles]
                     [used null])
            (cond
              [(null? colors)
               ;; Found a match
               (found-k used)]
              [(null? pebbles)
               ;; Failed to barter
               (fail-k)]
              [(member (car pebbles) used)
               ;; Already used that pebble
               (loop colors (cdr pebbles) used)]
              [(eq? (car colors) (send (car pebbles) get-color))
               ;; Found one
               (loop (cdr colors) all-pebbles (cons (car pebbles) used))]
              [else
               ;; Look further
               (loop colors (cdr pebbles) used)]))))

      ;; get-all-pebbles : -> list-of-snip
      ;;  Returns the snips for all of this player's pebbles.
      (define/private (get-all-pebbles)
        (let loop ([snip (send pebble-pb find-first-snip)])
          (if snip
              (cons snip (loop (send snip next)))
              null)))
      
      ;; get-all-pebble-colors : -> list-of-sym
      ;;  Returns a list of colors for the players pebble;
      ;;  mainly for testing
      (define/public (get-all-pebble-colors)
        (map (lambda (p) (send p get-color)) (get-all-pebbles)))
      ;; get-score : -> num
      ;;  Get the player's score, mainly for testing
      (define/public (get-score)
        points)
        
      ;; activate-player : bool -> 
      ;;  Shows or hides this player's title, to indicate
      ;;   who is playing.
      (define/public (activate-player on?)
        (send title show on?))
      
      (init start-pebble)
      (add-pebble start-pebble)
      
      (send pebble-pb set-selection-visible #f)
      (void)))

  ;; Implements the pebble snip:
  (define pebble%
    (class snip%
      (inherit set-snipclass)
      (init-field color)
      (define/override (get-extent dc x y w h d a l r)
        (set-box! w pebble-width)
        (set-box! h pebble-width)
        (map (lambda (b) (and b (set-box! b 0))) (list d a l r)))
      (define/override (draw dc x y l t r b dx dy caret)
        (let ([p (send dc get-pen)]
              [b (send dc get-brush)])
          (send dc set-pen black-pen)
          (send dc set-brush (cdr (assq color brushes)))
          (send dc draw-ellipse x y pebble-width pebble-width)
          (send dc set-pen p)
          (send dc set-brush b)))
      (define/public (get-color)
        color)
      (super-new)
      (set-snipclass pebble-snip-class)))
  
  ;; Needed for the pebble snip, in principle, for marshalling,
  ;;  but we don't need cut-and-paste or file saving:
  (define pebble-snip-class
    (new
     (class snip-class%
       (super-new))))

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  Player tests
  
  ;; We have to create a dummy frame to put the player panel
  ;;  inside.
  (let ([dummy-frame (new frame% [label "Dummy"])])
    (let ([p (new player% [parent dummy-frame][start-pebble 'red])]
          [check (lambda (what v1 v2)
                   (unless (equal? v1 v2)
                     (error what "failed: ~e != ~e" v1 v2)))])
      (check 'barter1 #t (send p try-barter '((red) . (green blue))))
      (check 'barter2 #t (send p try-barter '((green) . (blue))))
      (check 'after0 '(blue blue) (send p get-all-pebble-colors))
      (check 'barter3 #f (send p try-barter '((red) . (green blue))))
      (check 'after1 '(blue blue) (send p get-all-pebble-colors))
      (send p add-pebble 'blue)
      (check 'barter4 #t (send p try-barter '((blue blue blue) . (green red))))
      (check 'after2 #t (and (member (send p get-all-pebble-colors)
                                     '((green red) (red green)))
                             #t))
      (send p add-pebble 'white)
      (send p add-pebble 'yellow)
      (send p add-pebble 'red)
      (check 'buy1 #f (send p try-to-buy (make-card 0 '(red white yellow green blue))))
      (check 'buy2 #t (send p try-to-buy (make-card 0 '(red white yellow green red))))
      (check 'after3 null (send p get-all-pebble-colors))
      (check 'score0 80 (send p get-score))
      (let* ([try-card-score
              (lambda (card value)
                (let ([old-score (send p get-score)])
                  (for-each (lambda (c) (send p add-pebble c))
                            (card-pebbles card))
                  (check 'buyx #t (send p try-to-buy card))
                  (check 'scorex (+ old-score value) (send p get-score))))]
             [try-cards-score
              (lambda (c0 c1 c2)
                (try-card-score (make-card 0 '(red green blue blue red)) c0)
                (try-card-score (make-card 1 '(yellow yellow blue blue yellow)) c1)
                (try-card-score (make-card 2 '(yellow yellow yellow blue yellow)) c2)
                (send p add-pebble 'red))])
        (try-cards-score 80 110 150)
        (try-cards-score 60 80 110)
        (try-cards-score 50 60 80)
        (try-cards-score 40 50 60)
        (try-cards-score 40 50 60)
        (check 'post-buy '(red red red red red) (send p get-all-pebble-colors)))))
      
  ;; We still have a lot of GUI code above that isn't tested. It
  ;; can be tested by scripting a robot, which is the sort of thing
  ;; that the DrScheme implementors do to test the GUI.
  
  ;; A better version of the code would separate the model (the game
  ;; state) from the view (the GUI), and test the model part directly.
  ;; For example, we could test that cards-to-buy change correctly
  ;; when a player succesfully buys a card.
  
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  GUI instantiation

  ;; f : frame%
  ;;  The main game window
  (define f (new frame% 
                 [label "Bazaar"]))

  ;; A pane for the roll-or-barter phase of a turn
  (define roll-or-barter-pane
    (new horizontal-panel%
         [style '(border)]
         [parent f]
         [stretchable-height #f]
         [alignment '(center center)]))
  
  ;; The die-rolling button; when clicked, it tells the current player
  ;;  to add a pebble, and then it changes the turn state to the
  ;;  card-buying phase.
  (define roll-button
    (make-object button% "Roll Die!" roll-or-barter-pane
      (lambda (b e)
        (let ([color (list-ref (cons '* pebble-colors) (random 6))])
          (send current-player add-die-pebble color)
          (buy-card!)))))
  
  (new message% [label "  or   "] [parent roll-or-barter-pane])
  
  ;; The barter cards, implemented as two sequences of barter lines:
  (let ([barter-pane
         (new vertical-pane%
              [parent roll-or-barter-pane]
              [stretchable-height #f]
              [stretchable-width #f])])
    (let ([p (new horizontal-pane%
                  [parent barter-pane]
                  [alignment '(center center)]
                  [stretchable-height #f])])
      (let ([mk (lambda (card)
                  (let ([p (new vertical-panel%
                                [style '(border)]
                                [parent p]
                                [alignment '(center center)]
                                [stretchable-height #f]
                                [stretchable-width #f])])
                    (for-each (lambda (barter-line)
                                (new barter-line-canvas% 
                                     [barter-line barter-line] 
                                     [parent p]))
                              card)))])
        (mk barter-card1)
        (mk barter-card2))))

  ;; The panel for the buy phase:
  (define buy-or-pass-pane
    (new horizontal-panel%
         [style '(border)]
         [parent f]
         [stretchable-height #f]
         [alignment '(center center)]))

  (define dont-buy-button
    (new button% 
         [label "Don't Buy"]
         [parent buy-or-pass-pane]
         [callback (lambda (b e)
                     (next-player!))]))
    
  (new message% [label "  or "] [parent buy-or-pass-pane])

  (let ([buy-pane
         (new vertical-pane%
              [parent buy-or-pass-pane]
              [stretchable-height #f]
              [stretchable-width #f])])
    (let ([p (new horizontal-pane%
                  [parent buy-pane]
                  [alignment '(center center)]
                  [stretchable-height #f])])
      (let ([mk (lambda ()
                  (new card-canvas% [parent p]))])
        (mk)
        (mk)
        (mk)
        (mk)
        (mk))))
  
  ;; The two players:
  (define players
    (let ([p (new horizontal-pane%
                  [parent f]
                  [alignment '(center center)]
                  [stretchable-height #f])])
      (list
       (new player% [parent p][start-pebble (random-color)])
       (new player% [parent p][start-pebble (random-color)]))))
  
  ;; Player management:
  (define current-player (car players))
  (send current-player activate-player #t)
  (define (next-player!)
    (send current-player activate-player #f)
    (set! current-player
          (let ([l (member current-player players)])
            (if (null? (cdr l))
                (car players)
                (cadr l))))
    (send current-player activate-player #t)
    (send buy-or-pass-pane enable #f)
    (send roll-or-barter-pane enable #t)
    (send roll-button focus)
    (refresh-all))
  
  ;; Moves to the buy phase for the current player:
  (define (buy-card!)
    (send buy-or-pass-pane enable #t)
    (send roll-or-barter-pane enable #f)    
    (send dont-buy-button focus)
    (refresh-all))

  ;; Initially in the barter/roll phase, so disable
  ;;  the buy panel:
  (send buy-or-pass-pane enable #f)
    
  ;; Show the frane to start playing:
  (send f show #t))