#|

When playing and it's a user's turn, the history has an extra step at the end that 
corresponds to the unplayed move! that's confusing.

|#

(module admin-gui mzscheme
  (require "gui.ss"
           "die.ss"
           "interfaces.ss"
           "admin.ss"
           "board.ss"
	   "moves.ss"
           "rules.ss"
           "best-players.ss"
           framework
           mzlib/class
           mzlib/list
           mred)
  
  (provide gui-game%)
  
  ;; move-candidate = (make-move-candidate coordinate move (listof number))
  (define-struct move-candidate (move dice) (make-inspector))
  
  (define-struct past (board color roll) (make-inspector))
  (print-struct #t)
  
  (define gui-game%
    (class* object% (game<%>)
      
      (define the-game (new game%))
      (define/public (register o) (send the-game register o))
      (define/public (start) (send the-game start))
      (define game-observer
        (new
         (class* object% (game-observer<%>)
           (define/public (introduce . x) (void))
           (define/public (taking-turn color roll)
             (queue-callback
              (lambda ()
                (set-box! (cdr (assq color latest-dice)) roll)
                (set! history (append history (list (make-past partial-history color roll))))
                (update-players-dice color roll))))
           (define/public (took-turn color board) 
             (queue-callback
              (lambda ()
                (set! partial-history board)
                (send board-pasteboard set-board board))))
           (define/public (game-over winner-name color)
             (queue-callback
              (lambda ()
                (if winner-name
                    (set-bottom-message (format "~a (~s) won!" winner-name color))
                    (set-bottom-message "everone cheated")))))
           (super-new))))
      (send the-game set-observer game-observer)
      
      (define gui-player%
        (class* object% (player<%>)
          (define color #f)
          (define/public (start-game _color)
            (set! color _color)
            "Human")
          (define/public (do-move board roll)
            (let ([chan (make-channel)])
              (queue-callback
               (lambda ()
                 (enable-gui board roll color chan)))
              (channel-get chan)))
          (define/public (doubles-penalty) 
            (let ([sema (make-semaphore 0)])
              (queue-callback
               (lambda ()
                 (message-box "Parcheesi" 
                              (format 
                               "~a rolled doubles 3 times, so the front-most piece goes back to the start."
                               color))
                 (semaphore-post sema)))
              (semaphore-wait sema)))
          (super-new)))
      
      (define board-pasteboard (new board-pasteboard% (admin-gui this)))
      
      ;; history : (listof past)
      (define history '())
      ;; partial-history : board
      ;; temporary holding variable until a move is complete and history can be updated.
      (define partial-history (new-board))
      
      (define frame (new board-frame% (label "Parcheesi") (style '(metal)) (board-pasteboard board-pasteboard)))
      (define main-hp (new horizontal-panel% (parent frame)))
      (define bottom-panel (new horizontal-panel% 
                                (parent frame)
                                (stretchable-height #f)))
      (define bottom-msg (new message% (parent bottom-panel) (stretchable-width #t) (label "")))
      (define left-vp (new vertical-panel% (parent main-hp) (stretchable-width #f)))
      (define board-ec (new editor-canvas% 
                            (style '(no-hscroll no-vscroll))
                            (parent main-hp)
                            (editor board-pasteboard)
                            (min-height 400)
                            (min-width 400)))
      (define right-vp (new vertical-panel% (parent main-hp) (stretchable-width #f)))
      
      (define blue-player-panel (new vertical-panel% 
                                     (alignment '(center top))
                                     (parent left-vp)
                                     (stretchable-height #f)))
      (new horizontal-panel% (parent left-vp))
      (define yellow-player-panel (new vertical-panel% 
                                       (alignment '(center bottom))
                                       (parent left-vp)
                                       (stretchable-height #f)))
      (define red-player-panel (new vertical-panel% 
                                    (alignment '(center top))
                                    (parent right-vp)
                                    (stretchable-height #f)))
      (new horizontal-panel% (parent right-vp))
      (define green-player-panel (new vertical-panel% 
                                      (alignment '(center bottom))
                                      (parent right-vp)
                                      (stretchable-height #f)))
      
      (define dice '())
      
      (define/private (make-dice color parent)
        (let* ([p (new horizontal-panel% (parent parent) (stretchable-height #f))]
               [die-objects (list (new die% (parent p) (dim? #t))
                                  (new die% (parent p) (dim? #t))
                                  (new die% (parent p) (dim? #t))
                                  (new die% (parent p) (dim? #t)))]
               [dice-in-order
                (case color
                  [(yellow blue) (reverse die-objects)]
                  [else die-objects])])
          (set! dice (cons (list color dice-in-order) dice))))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;
      ;;  controlling the players
      ;;
      
      (define/private (add-gui-player-controls color parent-panel)
        (let* ([accept-move-button (new button%
                                        (label "Done")
                                        (parent parent-panel)
                                        (callback (lambda (x y) (accept-move))))]
               [reset-move-button (new button%
                                       (label "Reset")
                                       (parent parent-panel)
                                       (callback (lambda (x y) (reset-button-callback))))]
               [bp-panel (new horizontal-panel% 
                              (parent parent-panel)
                              (stretchable-height #f)
                              (stretchable-width #f))])
          (send accept-move-button enable #f)
          (send reset-move-button enable #f)
          (make-dice color parent-panel)
          (set! gui-player-accept-move-buttons
                (cons (cons color accept-move-button) gui-player-accept-move-buttons))
          (set! gui-player-reset-move-buttons
                (cons (cons color reset-move-button) gui-player-reset-move-buttons))))
      
      (define gui-player-accept-move-buttons '())
      (define gui-player-reset-move-buttons '())
      
      (define/private (go-back)
        (reset-move)
        (set! viewing-index 
              (cond
                [(eq? viewing-index 'latest) (- (length history) 1)]
                [(and this-move-color (zero? viewing-index)) 'latest]  ;; only go to latest when its time to show a move
                [(zero? viewing-index) (- (length history) 1)]
                [else (- viewing-index 1)]))
        (update-gui))
      (define/private (go-forw)
        (reset-move)
        (set! viewing-index (cond
                              [(eq? viewing-index 'latest) 0]
                              [(and this-move-color (= viewing-index (- (length history) 1)))
                               'latest]
                              [(= viewing-index (- (length history) 1))
                               0]
                              [else (+ viewing-index 1)]))
        (update-gui))
      
      (define/private (reset-button-callback)
        (reset-move)
        (update-gui))
      
      (define/private (reset-move)
        (set! current-moves '())
        (set! current-board start-board)
        (set! current-dice start-dice)
        (set! dice-used '()))
      
      (define/private (accept-move)
        (update-players-dice this-move-color start-dice)
        (for-each (lambda (die) (send die set-dim #t))
                  (cadr (assq this-move-color dice)))
        (let ([accept (cdr (assq this-move-color gui-player-accept-move-buttons))]
              [reset (cdr (assq this-move-color gui-player-reset-move-buttons))])
          (send reset enable #f)
          (send accept enable #f))
        (channel-put answer-chan current-moves))
      
      (define current-moves '())
      (define answer-chan #f)
      (define start-board #f)
      (define current-board #f)
      (define start-dice #f)
      (define current-dice '())
      (define dice-used '())
      (define this-move-color #f)
      (define viewing-index 'latest)
      (define latest-dice (list (cons 'green (box null))
                                (cons 'red (box null))
                                (cons 'blue (box null))
                                (cons 'yellow (box null))))
      
      (define/private (enable-gui board roll color _answer-chan)
        (set! current-board board)
        (set! start-board board)
        (set! current-dice roll)
        (set! start-dice roll)
        (set! dice-used '())
        (set! this-move-color color)
        (set! answer-chan _answer-chan)
        (set! current-moves '())
        (set-bottom-message "")
        (update-gui))
      
      (define/public (build-new-board/register-move mc)
        (let ([new-move (move-candidate-move mc)])
          (with-handlers ([exn:bad-move? 
                           (lambda (x) 
                             ;; call this first, since it calls set-bottom-message
                             ;; and we don't want that one to survive
                             (update-gui) 
                             
                             (set-bottom-message (exn-message x)))])
            (let-values ([(new-board total-bonuses) 
                          (make-moves start-board (append current-moves (list new-move)))])
              (set-bottom-message "")
              (set! dice-used (append dice-used (move-candidate-dice mc)))
              (set! current-board new-board)
              (set! current-moves (append current-moves (list new-move)))
              (set! current-dice (foldl remq (append start-dice total-bonuses) dice-used))
              (update-gui)))))
      
      (define/private (update-gui)
        (cond
          [(eq? viewing-index 'latest)
           (dim-dice-except this-move-color)
           (for-each (lambda (latest-dice-line)
                       (if (eq? this-move-color (car latest-dice-line))
                           (update-players-dice this-move-color current-dice)
                           (update-players-dice (car latest-dice-line) (unbox (cdr latest-dice-line)))))
                     latest-dice)
           (send board-pasteboard set-board current-board)
           (let-values ([(highlights move-candidates)
                         (find-roll-coordinates current-board current-dice this-move-color)])
             (send board-pasteboard set-highlighted-squares highlights move-candidates))]
          [(number? viewing-index)
           (let ([past (list-ref history viewing-index)])
             (clear-dice-except (past-color past))
             (update-players-dice (past-color past) (past-roll past))
             (send board-pasteboard set-board (past-board past))
             (send board-pasteboard set-highlighted-squares '() '()))]
          [else (error 'update-gui "unknown viewing index ~e\n" viewing-index)])
        (reset-accept/move-buttons)
        (reset-forw-back-buttons))
      
      (define/private (reset-accept/move-buttons)
        (when this-move-color
          (let ([accept (cdr (assq this-move-color gui-player-accept-move-buttons))]
                [reset (cdr (assq this-move-color gui-player-reset-move-buttons))])
            (send reset enable (and (eq? viewing-index 'latest) (not (null? current-moves))))
            (send accept enable 
                  (and (eq? viewing-index 'latest) 
                       (with-handlers ([exn:bad-move? (lambda (x) 
                                                        (set-bottom-message 
                                                         (string-append 
                                                          (format "~a is not done: " this-move-color)
                                                          (exn-message x)))
                                                        #f)])
                         (take-turn this-move-color start-board start-dice current-moves)
                         #t))))))
      
      (define/private (reset-forw-back-buttons)
        (send forw enable (not (null? history)))
        (send back enable (not (null? history))))
      
      (define/private (set-bottom-message msg) (send bottom-msg set-label msg))
      
      (define/private (dim-dice-except color)
        (for-each (lambda (die-roll) 
                    (cond
                      [(eq? (car die-roll) color)
                       (for-each (lambda (die) (send die set-dim #f)) (cadr die-roll))]
                      [else 
                       (for-each (lambda (die) (send die set-dim #t)) (cadr die-roll))]))
                  dice))
      
      (define/private (clear-dice-except color)
        (for-each (lambda (die-roll) 
                    (cond
                      [(eq? (car die-roll) color)
                       (for-each (lambda (die) (send die set-dim #f)) (cadr die-roll))]
                      [else 
                       (for-each (lambda (die) (send die set-digit #f)) (cadr die-roll))]))
                  dice))
      
      (define/private (update-players-dice color roll)
        (let loop ([roll roll]
                   [dice (cadr (assq color dice))])
          (cond
            [(null? dice) (void)]
            [(null? roll) (send (car dice) set-digit #f)
                          (loop roll (cdr dice))]
            [else (send (car dice) set-digit (car roll))
                  (loop (cdr roll) (cdr dice))])))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;
      ;;  player choice gui
      ;;

      (define/private (index->player i) 
        (case i
          [(0) best-player%]
          [(1) polite-player%]
          [(2) reckless-player%]
          [(3) gui-player%]))
      
      (define players (vector (index->player 0)
                              (index->player 0)
                              (index->player 0)
                              (index->player 0)))
      
      (define/private (add-choose-player-controls color parent-panel)
        (let ([color-order '((green . 0) (red . 1) (blue . 2) (yellow . 3))])
          (new radio-box%
               (parent parent-panel)
               (label #f)
               (choices '("Amazing Grace"
                          "Polite Polly"
                          "Reckless Renee"
                          "You"))
               (callback
                (lambda (rb y)
                  (vector-set! players
                               (cdr (assq color color-order))
                               (index->player
                                (send rb get-selection))))))))
      
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;
      ;;  put all the gui elements together
      ;;
      
      (define/private (make-player-control-panel parent color ah aw)
        (let* ([parent 
                (new panel:single% 
                     (stretchable-height #f)
                     (parent parent))]
               [choose-player-panel (new vertical-panel% 
                                         (parent parent)
                                         (style '(border))
                                         (alignment `(,aw ,ah))
                                         (stretchable-width #f)
                                         (stretchable-height #f))]
               [control-player-panel (new vertical-panel% 
                                          (parent parent)
                                          (style '(border))
                                          (alignment `(,aw ,ah))
                                          (stretchable-width #f)
                                          (stretchable-height #f))])
          (add-gui-player-controls color control-player-panel)
          (add-choose-player-controls color choose-player-panel)
          (list color parent choose-player-panel control-player-panel)))
      
      (define gui-player-control-panels
        (list (make-player-control-panel green-player-panel 'green 'top 'left)
              (make-player-control-panel red-player-panel 'red 'bottom 'left)
              (make-player-control-panel yellow-player-panel 'yellow 'top 'right)
              (make-player-control-panel blue-player-panel 'blue 'bottom 'right)))
      
      (define/private (get-player-panel color i)
        (let ([e (assq color gui-player-control-panels)])
          (unless e
            (error 'get-player-panel "bad color ~e" color))
          (list-ref e i)))
      (define/private (get-player-parent-panel c) (get-player-panel c 1))
      (define/private (get-choose-player-panel c) (get-player-panel c 2))
      (define/private (get-control-player-panel c) (get-player-panel c 3))

      (define sbf-panel (new panel:single% 
                             (parent bottom-panel) 
                             (stretchable-width #f)
                             (stretchable-height #f)
                             (alignment '(right center))))
      
      (define start-button (new button%
                                (label "Start Game")
                                (parent sbf-panel)
                                (callback
                                 (lambda (x y)
                                   (for-each (lambda (color)
                                               (send (get-player-parent-panel color)
                                                     active-child
                                                     (get-control-player-panel color)))
                                             '(red blue green yellow))
                                   (send sbf-panel active-child bf-panel)
                                   (start-game)))))
      (define bf-panel (new horizontal-panel% (parent sbf-panel) (stretchable-width #f) (stretchable-height #f)))
      (define back (new button%
                        (label "<")
                        (parent bf-panel)
                        (callback (lambda (x y) (go-back)))))
      (define forw (new button%
                        (label ">")
                        (parent bf-panel)
                        (callback (lambda (x y) (go-forw)))))
      (define rules-button (new button% (parent bottom-panel) (label "Rules") (callback (lambda (x y) (show-rules)))))

      (super-new)
      (send frame show #t)
      
      ;; start the game
      (define/private (start-game)
        (for-each (lambda (player%) (send the-game register (new player%))) (vector->list players))
        (thread (lambda () (send the-game start))))))
  
  (define board-pasteboard%
    (class pasteboard%
      (inherit get-admin get-view-size)
      (init-field admin-gui)
      (init-field [board (new-board)])
      
      (define/public (set-board _board)
        (set! board _board)
        (frame-size-changed))
      
      ;; highlighted-squares : (listof (cons coordinate (listof coordinate)))
      ;; the first element in the list is the key and the rest are
      ;; squares that should be highlighted when the cursor moves over
      ;; the key square
      (define highlighted-squares '())
      ;; move-candidates : (listof (cons coordinate (listof move-candidate)))
      (define move-candidates '())
      (define/public (set-highlighted-squares hs mcs)
        (set! highlighted-squares hs)
        (set! move-candidates mcs))
      
      ;; current-highlight : (listof coordinate)
      (define current-highlight '())
      (define current-mouse #f)
      
      (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
        (let ([admin (get-admin)])
          (when admin
            (let-values ([(w h) (get-size)])
              (let ([pen (send dc get-pen)]
                    [brush (send dc get-brush)])
                (when before? (draw-board board dc w h dx dy #f))
                (unless before? (draw-highlighted-squares dc dx dy w h))
                (send dc set-pen pen)
                (send dc set-brush brush))))))
      
      (define/private (draw-highlighted-squares dc dx dy w h)
        (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
        (send dc set-brush (send the-brush-list find-or-create-brush "black" 'hilite))
        (for-each (lambda (highlighted-offset)
                    (let-values ([(x y cw ch) (coordinate->xywh highlighted-offset w h)])
                      (send dc draw-rectangle (+ dx x) (+ dy y) cw ch)))
                  current-highlight))
      
      (inherit dc-location-to-editor-location)
      (define/override (on-event event)
        (let-values ([(w h) (get-size)])
          (cond
            [(and (send event button-up?)
                  (find-next-selected-snip #f))
             =>
             (lambda (snip)
               (super on-event event)
               (let ([pawn-id (send snip get-pawn-id)])
                 (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
                   (let* ([potential-move-line
                           (memf (lambda (mcl) (in-coord? (car mcl) x y w h))
                                 move-candidates)])
                     (if potential-move-line
                         (let* ([potential-moves (cdar potential-move-line)]
                                [new-move (ormap (lambda (mc)
                                                   (and (= pawn-id (get-move-id (move-candidate-move mc)))
                                                        mc))
                                                 potential-moves)])
                           (if new-move
                               (send admin-gui build-new-board/register-move new-move)
                               (reset-snips)))
                         (reset-snips)))))
               (update-current-mouse (get-mouse-coordinate event w h)))]
            [else
             (update-current-mouse (get-mouse-coordinate event w h))
             (super on-event event)])))
      
      (inherit find-next-selected-snip)
      (define/private (get-mouse-coordinate event w h)
        (cond
          [(and (send event dragging?)
                (find-next-selected-snip #f))
           =>
           (lambda (snip) (send snip get-coord))]
          [else
           (let-values ([(x y) (dc-location-to-editor-location (send event get-x) (send event get-y))])
             (let loop ([highlights highlighted-squares])
               (cond
                 [(null? highlights) #f]
                 [else
                  (let* ([highlight-list (car highlights)]
                         [highlight (car highlight-list)])
                    (let-values ([(sx sy cw ch) (coordinate->xywh highlight w h)])
                      (if (and (<= sx x (+ sx cw))
                               (<= sy y (+ sy ch)))
                          highlight
                          (loop (cdr highlights)))))])))]))
      
      (inherit invalidate-bitmap-cache)
      (define/private (update-current-mouse mse)
        (unless (equal? current-mouse mse)
          (set! current-mouse mse)
          (set! current-highlight 
                (if mse 
                    (let ([ent (assoc current-mouse highlighted-squares)])
                      (if ent 
                          (cdr ent)
                          '()))
                    '()))
          (invalidate-bitmap-cache)))
      
      
      (inherit insert begin-edit-sequence end-edit-sequence find-first-snip set-min-width set-min-height)
      (define/public (frame-size-changed) (reset-snips))
      (define/private (reset-snips)
        (begin-edit-sequence)
        (let loop ([s (find-first-snip)])
          (when s
            (let ([n (send s next)])
              (send s release-from-owner)
              (loop n))))
        (let-values ([(w h) (get-size)])
          (let ([pawn-size (get-piece-size w h)])
            (set-min-width w)
            (set-min-height h)
            (for-each-piece/position 
             board w h
             (lambda (pawn x y coord)
               (insert (new coordinate-snip%
                            (color (pawn-color pawn))
                            (id (pawn-id pawn))
                            (coord coord)
                            (w pawn-size)
                            (h pawn-size))
                       x 
                       y)))))
        (end-edit-sequence))
      
      (define/private (get-size)
        (let ([wb (box 0)]
              [hb (box 0)])
          (get-view-size wb hb)
          (values (max 10 (- (unbox wb) 3))
                  (max 10 (- (unbox hb) 3)))))
      
      (super-new)
      (inherit set-selection-visible)
      (set-selection-visible #f)))
  
  (define coordinate-snip%
    (class snip%
      (define/override (draw dc x y left top right bottom dx dy draw-caret)
        (let ([old-pen (send dc get-pen)]
              [old-brush (send dc get-brush)]
              [old-smoothing (send dc get-smoothing)])
          (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
          (send dc set-brush (send the-brush-list find-or-create-brush (pawn-drawn-color color) 'solid))
          (send dc set-smoothing 'aligned)
          (send dc draw-ellipse x y w h)
          (send dc set-pen old-pen)
          (send dc set-brush old-brush)
          (send dc set-smoothing old-smoothing)))
      (define/override (get-extent dc x y wb hb descent space lspace rspace)
        (set-box/f! wb w)
        (set-box/f! hb h)
        (set-box/f! descent 0)
        (set-box/f! space 0)
        (set-box/f! lspace 0)
        (set-box/f! rspace 0))
      (init-field id coord color w h)
      (define/public (get-coord) coord)
      (define/public (get-pawn-id) id)
      (super-new)
      (inherit set-snipclass)
      (set-snipclass coordinate-snipclass)))
  
  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
  
  (define coordinate-snipclass
    (new
     (class snip-class%
       (define/override (read in)
         (let ([id (send in get-fixed)]
               [coord '???])
           (new coordinate-snip% (id id) (coord coord))))
       (super-new))))
  (send coordinate-snipclass set-classname "parcheesi:coordinate-snipclass")
  (send coordinate-snipclass set-version 1)
  (send (get-the-snip-class-list) add coordinate-snipclass)
  
  (define board-frame%
    (class frame%
      (init-field [board-pasteboard #f])
      (define/public (set-board-pasteboard bpb) (set! board-pasteboard bpb))
      (define/override (on-size w h)
        (when board-pasteboard
          (send board-pasteboard frame-size-changed)))
      (define/override (on-superwindow-show shown?)
        (when board-pasteboard
          (send board-pasteboard frame-size-changed)))
      (super-new)))
  
  (define (in-coord? coord x y w h)
    (let-values ([(cx cy cw ch) (coordinate->xywh coord w h)])
      (and (<= cx x (+ cx cw))
           (<= cy y (+ cy ch)))))
  
  ;; coordinate->xywh : coordinate -> (values number number number number)
  (define (coordinate->xywh loc w h)
    (cond
      [(main-c? loc)
       (let*-values ([(x y horizontal?) (find-main-coordinates (main-c-count loc) w h)]
                     [(cw ch) (get-cell-size horizontal? w h)])
         (values (- x (/ cw 2)) (- y (/ ch 2)) cw ch))]
      [(home-row-c? loc)
       (let*-values ([(x y horizontal?) (find-home-row-coordinates (home-row-c-color loc)
                                                                   (home-row-c-count loc)
                                                                   w
                                                                   h)]
                     [(cw ch) (get-cell-size horizontal? w h)])
         (values (- x (/ cw 2)) (- y (/ ch 2)) cw ch))]
      [(home-c? loc)
       (values (* w 1/3) (* h 1/3) (* w 1/3) (* h 1/3))]
      [(start-c? loc)
       (case (start-c-color loc)
         [(blue) (values 0 0 (* w 1/3) (* h 1/3))]
         [(red) (values (* w 2/3) 0 (* w 1/3) (* h 1/3))]
         [(yellow) (values 0 (* h 2/3) (* w 1/3) (* h 1/3))]
         [(green) (values (* w 2/3) (* h 2/3) (* w 1/3) (* h 1/3))])]
      [else (error 'coordinate->xywh "unk loc ~e" loc)]))
  
  ;; find-roll-coordinates : board
  ;;                         (listof number) 
  ;;                         color 
  ;;                      -> (values (listof (cons coordinate (listof coordinate)))
  ;;                                 (listof (cons coordinate (listof move-candidate))))
  ;; finds the coordinates for the moves that the GUI highlights.
  ;; in the resulting list, the first entry is the place with the
  ;; piece and subsequent entries are places that it can move to.
  (define (find-roll-coordinates board roll color)
    (let-values ([(start-coords start-moves)
                  (find-start-roll-coordinates board roll color)]
                 [(main-coords main-moves)
                  (find-main-roll-coordinates board roll color)]
                 [(home-coords home-moves)
                  (find-home-roll-coordinates board roll color)])
      (values (map (lambda (x) (cons (car x) (eliminate-duplicates (cdr x))))
                   (append start-coords main-coords home-coords))
              (collapse-same-coordinates (append start-moves main-moves home-moves)))))
  
  ;; eliminate-duplicates : (listof X) -> (listof X)
  (define (eliminate-duplicates lst)
    (let ([ht (make-hash-table 'equal)])
      (for-each (lambda (x) (hash-table-put! ht x #t)) lst)
      (hash-table-map ht (lambda (x y) x))))
  
  ;; collapse-same-coordinates : (listof (cons coordinate (listof move-candidate)))
  ;;                          -> (listof (cons coordinate (listof move-candidate)))
  (define (collapse-same-coordinates l)
    (let ([ht (make-hash-table 'equal)])
      (for-each (lambda (pr)
                  (hash-table-put! ht (car pr)
                                   (append (cdr pr)
                                           (hash-table-get ht (car pr) (lambda () '())))))
                l)
      (hash-table-map ht cons)))
  
  ;; like find-roll-coordinates, but only for the main track of the board
  (define (find-home-roll-coordinates board roll color)
    (find-move-coordinates board-home-row-size
                           (lambda (i) (board-home-row-i board color i))
                           roll
                           color
                           (lambda (num) (make-home-row-c num color))
                           make-move-piece-home
                           home-row-add))
  
  ;; like find-roll-coordinates, but only for the main track of the board
  (define (find-main-roll-coordinates board roll color)
    (find-move-coordinates board-main-size
                           (lambda (i) (board-main-i board i))
                           roll
                           color
                           make-main-c
                           make-move-piece-main
                           main-ring-add))
  
  ;; find-move-coordinates : number
  ;;                         (number -> (listof pawn))
  ;;                         number color
  ;;                         (number -> coordinate)
  ;;                         (pawn number number -> move)
  ;;                         (color number number -> (union #f number))
  (define (find-move-coordinates len ref roll color make-coordinate make-move-piece find-end-spot)
    (let loop ([i len]
               [coords null]
               [move-candidates null])
      (cond
        [(= i 0) (values coords move-candidates)]
        [else (let* ([pos (- i 1)]
                     [ent (ref pos)])
                (if (and (pair? ent)
                         (eq? (pawn-color (car ent)) color))
                    (let* ([build-list
                            (lambda (f)
                              (foldl
                               (lambda (die sofar)
                                 (let ([final-spot (find-end-spot color pos die)])
                                   (if final-spot
                                       (cons (f die final-spot) sofar)
                                       sofar)))
                               '()
                               roll))]
                           
                           [new-coord (cons (make-coordinate pos) 
                                            (build-list (lambda (die final-spot) final-spot)))]
                           [new-moves 
                            (build-list (lambda (die final-spot)
                                          (cons final-spot
                                                (map (lambda (pawn)
                                                       (make-move-candidate (make-move-piece pawn pos die)
                                                                            (list die)))
                                                     ent))))])
                      (loop (- i 1)
                            (cons new-coord coords)
                            (append new-moves move-candidates)))
                    (loop (- i 1) coords move-candidates)))])))
  
  (define (main-ring-add color start dist)
    (let ([landed (find-end-spot color start dist)])
      (cond
        [(eq? landed 'too-far) #f]
        [(eq? landed 'home) (make-home-c color)]
        [(eq? (car landed) 'home-row)
         (make-home-row-c (cdr landed) color)]
        [(eq? (car landed) 'main)
         (make-main-c (cdr landed))])))
  
  (define (home-row-add color pos die)
    (let ([final-spot (+ pos die)])
      (cond
        [(< final-spot board-home-row-size)
         (make-home-row-c final-spot color)]
        [(= final-spot board-home-row-size)
         (make-home-c color)]
        [else #f])))
  
  ;; like find-roll-coordinates, but only for the start position of the board
  (define (find-start-roll-coordinates board roll color)
    (let ([available-pawns (filter (lambda (pawn) (eq? (pawn-color pawn) color)) (board-start board))]
          [ent (board-main-i board (get-enter-pos color))])
      (cond
        [(and (has-entering-roll? roll)
              (not (null? available-pawns))
              (or (null? ent)
                  (null? (cdr ent))))
         (let ([entry-coord (make-main-c (get-enter-pos color))])
           (values 
            (list (list (make-start-c color) entry-coord))
            (list 
             (cons entry-coord
                   (map
                    (lambda (pawn)
                      (make-move-candidate (make-enter-piece pawn)
                                           (if (memq 5 roll) '(5) roll)))
                    available-pawns)))))]
        [else (values null null)]))))