
(module gofish mzscheme
  (require (lib "cards.ss" "games" "cards")
	   (lib "mred.ss" "mred")
	   (lib "class.ss")
           (lib "unit.ss")
	   (lib "list.ss"))
  
  (provide game-unit)
  
  (define game-unit
    (unit
      (import)
      (export)
      
      ;; Player record
      (define-struct player (r hand-r discard-r count-r ; regions
                               hand discarded ; cards
                               tried)) ; memory for simulating players
      
      ;; Player names
      (define PLAYER-1-NAME "Opponent 1")
      (define PLAYER-2-NAME "Opponent 2")
      (define YOUR-NAME "You")
      
      ;; Initial card count
      (define DEAL-COUNT 7)
      
      ;; Messages
      (define YOUR-TURN-MESSAGE "Your turn.  (Drag a match to your discard box or drag a card to an opponent.)")
      (define GO-FISH-MESSAGE "Go Fish!  (Drag a card from the center deck to your box.)")
      (define MATCH-MESSAGE "Match!")
      (define GAME-OVER-MESSAGE "GAME OVER")
      
      ;; Region layout constants
      (define MARGIN 10)
      (define SUBMARGIN 10)
      (define LABEL-H 15)
      
      ;; Randomize
      (random-seed (modulo (current-milliseconds) 10000))
      
      ;; Set up the table
      (define t (make-table "Go Fish" 8 4.5))
      (define status-pane (send t create-status-pane))
      (send t add-help-button status-pane '("games" "gofish") "Go Fish Help" #f)
      (send t show #t)
      (send t set-double-click-action #f)
      (send t set-button-action 'left 'drag-raise/one)
      (send t set-button-action 'middle 'drag/one)
      (send t set-button-action 'right 'drag/one)
      
      ;; Get table width & height
      (define w (send t table-width))
      (define h (send t table-height))
      
      ;; Set up the cards
      (define deck (shuffle-list (make-deck) 7))
      (for-each
       (lambda (card)
         (send card snap-back-after-move #t)
         (send card user-can-flip #f))
       deck)
      
      ;; Function for dealing or drawing cards
      (define (deal n)
        (let loop ([n n][d deck])
          (if (zero? n)
              (begin
                (set! deck d)
                null)
              (cons (car d) (loop (sub1 n) (cdr d))))))
      
      ;; Card width & height
      (define cw (send (car deck) card-width))
      (define ch (send (car deck) card-height))
      
      ;; Put the cards on the table
      (send t add-cards 
            deck
            (/ (- w cw) 2)
            (- (/ (- h ch) 2) (/ ch 3)))
      
      ;; Player region size
      (define pw (- (/ (- w cw) 2) (* 2 MARGIN)))
      (define ph (- (/ (- h (/ ch 3)) 2) (* 2 MARGIN)))
      
      ;; Region-makers
      (define (make-hand-region r)
        (define m SUBMARGIN)
        (make-region
         (+ m (region-x r)) (+ LABEL-H m (region-y r))
         (- (region-w r) (* 3 m) cw) (- (region-h r) LABEL-H (* 2 m))
         #f #f))
      (define (make-discard-region r)
        (make-region
         (- (+ (region-x r) (region-w r)) SUBMARGIN cw)
         (- (+ (region-y r) (region-h r)) SUBMARGIN ch)
         cw ch
         #f #f))
      (define (make-discard-count-region r c cb)
        (make-region
         (- (+ (region-x r) (region-w r)) SUBMARGIN cw (/ SUBMARGIN 2))
         (- (+ (region-y r) (region-h r)) SUBMARGIN ch LABEL-H (/ SUBMARGIN 2))
         (+ cw SUBMARGIN) (+ ch LABEL-H SUBMARGIN)
         (number->string c)
         cb))
      
      ;; Define the initial regions
      (define player-1-region
        (make-region
         MARGIN MARGIN pw ph
         PLAYER-1-NAME
         void))
      (define player-2-region
        (make-region
         (- w MARGIN pw) MARGIN pw ph
         PLAYER-2-NAME
         void))
      (define you-region
        (make-region
         MARGIN (- h MARGIN ph) (- w (* 2 MARGIN)) ph
         YOUR-NAME
         void))
      
      ;; Player setup
      (define (create-player r discard-callback)
        (let ([p (make-player
                  r
                  (make-hand-region r)
                  (make-discard-region r)
                  (make-discard-count-region r 0 discard-callback)
                  (deal DEAL-COUNT)
                  null
                  null)])
          (send t add-region r)
          (send t add-region (player-count-r p))
          (for-each (lambda (card) (send t card-to-front card)) (reverse (player-hand p))) 
          (send t move-cards-to-region (player-hand p) (player-hand-r p))
          p))
      
      (define player-1 (create-player player-1-region #f))
      (define player-2 (create-player player-2-region #f))
      (define you (create-player you-region 
                                 ;; Dragging to your discard pile checks to see if the card
                                 ;;  makes a match:
                                 (lambda (cards) 
                                   (check-hand you (car cards))
                                   (send t set-status YOUR-TURN-MESSAGE))))
      
      ;; More card setup: Opponents's cards and deck initally can't be moved
      (for-each
       (lambda (card) (send card user-can-move #f))
       (append
        (player-hand player-1)
        (player-hand player-2)
        deck))
      
      ;; More card setup: Show your cards
      (send t flip-cards (player-hand you))
      
      ;; Function to update the display for a player record
      (define (rearrange-cards p)
        ;; Stack cards in 3D first-to-last
        (send t stack-cards (player-discarded p))
        (send t stack-cards (player-hand p))
        ;; Move them to their regions
        (send t move-cards-to-region (player-discarded p) (player-discard-r p))
        (send t move-cards-to-region (player-hand p) (player-hand-r p))
        ;; Recreate the counter region to reset the count
        (send t begin-card-sequence)
        (send t remove-region (player-count-r p))
        (set-player-count-r! p (make-discard-count-region 
                                (player-r p) (/ (length (player-discarded p)) 2)
                                (region-callback (player-count-r p))))
        (send t add-region (player-count-r p))
        (send t end-card-sequence))
      
      ;; Function to search for an equivalent card
      (define (find-equiv card hand)
        (ormap (lambda (c)
                 (and (not (eq? c card))
                      (= (send card get-value) (send c get-value))
                      c))
               hand))
      
      ;; Function to check for a match involving `card' already in the player's hand
      (define (check-hand player card)
        (let* ([h (player-hand player)]
               [found (find-equiv card h)])
          (if found
              (begin
                ;; Make sure the matching cards are face-up and pause for the user
                (send t cards-face-up (list found card))
                (send t set-status MATCH-MESSAGE)
                ;; The players has a match! Move the card from the player's hand
                ;;  to his discard pile
                (set-player-hand! player (remove* (list card found) h))
                (set-player-discarded! player (cons found 
                                                    (cons card 
                                                          (player-discarded player))))
                ;; The dicarded cards can no longer be moved
                (send card user-can-move #f)
                (send found user-can-move #f)
                ;; Move the cards to their new places
                (rearrange-cards player)
                ;; Slower
                #t)
              #f)))
      
      ;; Function to enable/disable moving your cards
      (define (enable-your-cards on?)
        (for-each (lambda (c) (send c user-can-move on?))
                  (player-hand you)))
      
      ;; Callbacks communicate back to the main loop via these
      (define something-happened (make-semaphore 1))
      (define go-fish? #f)
      
      ;; Function for trying to get a card from another player
      (define (ask-player-for-match getter giver card)
        (let* ([h (player-hand giver)]
               [found (find-equiv card h)])
          (if found
              (begin
                ;; The giver player has a matching card - give it to the getter
                (set-player-hand! giver (remq found h))
                (set-player-hand! getter (cons found (player-hand getter)))
                ;; Make sure the matching cards are face-up and pause for the user
                (send t cards-face-up (list found card))
                ;; Move the cards around
                (check-hand getter card)
                (rearrange-cards giver)
                #t)
              ;; The giver player doesn't have it - Go Fish!
              #f)))
      
      ;; Callback for dragging a card to an opponent
      (define (player-callback player)
        (lambda (cards)
          (set! go-fish? (not (ask-player-for-match you player (car cards))))
          (semaphore-post something-happened)))
      
      ;; Visual info to go fish
      (define wiggle-top-card
        (lambda ()
          (let ([top (car deck)]
                [x (/ (- w cw) 2)]
                [y (- (/ (- h ch) 2) (/ ch 3))])
            (send t move-card top (- x 10) y)
            (send t move-card top (+ x 10) y)
            (send t move-card top x y))))
      
      ;; Callback for going fishing
      (define fishing
        (lambda (cards)
          (send t flip-card (car deck))
          (set-player-hand! you (append (deal 1) (player-hand you)))
          (rearrange-cards you)
          (semaphore-post something-happened)))
      
      ;; Function to simulate a player
      (define (simulate-player player other-player k)
        ;; Try cards in the players hand that haven't been tried
        (let ([cards-to-try (remq* (player-tried player) (player-hand player))])
          (if (null? cards-to-try)
              (begin
                ;; No cards to try. Reset the history and start over
                (set-player-tried! player null)
                (simulate-player player other-player k))
              ;; Pick a random card and a random opponent
              (let ([c (list-ref cards-to-try (random (length cards-to-try)))]
                    [o (list-ref (list you other-player) (random 2))])
                (set-player-tried! player (cons c (player-tried player)))
                ;; Show you the card-to-ask
                (send t flip-card c)
                ;; Hilight player-to-ask
                (send t hilite-region (player-r o))
                ;; Wait a moment
                (sleep 0.3)
                ;; Unhilight player-to-ask
                (send t unhilite-region (player-r o))
                (if (ask-player-for-match player o c)
                    ;; Got it - go again
                    (check-done
                     (lambda ()
                       (simulate-player player other-player k)))
                    ;; Go fish
                    (begin
                      ;; Wait a bit, then turn the asked-for card back over
                      (sleep 0.3)
                      (send t flip-card c)
                      (if (null? deck)
                          ;; No more cards; pass
                          (k)
                          (begin
                            ;; Draw a card
                            (set-player-hand! player (append (deal 1) (player-hand player)))
                            (rearrange-cards player)
                            (if (check-hand player (car (player-hand player)))
                                ;; Drew a good card - keep going
                                (check-done
                                 (lambda ()
                                   (simulate-player player other-player k)))
                                ;; End of our turn
                                (k))))))))))
      
      ;; Function to check for end-of-game
      (define (check-done k)
        (if (ormap (lambda (p) (null? (player-hand p))) (list player-1 player-2 you))
            (begin
              (enable-your-cards #f)
              (send t set-status GAME-OVER-MESSAGE))
            (k)))
      
      ;; Look in opponents' initial hands for matches
      ;; (Since each player gets 7 cards, it's impossible to run out of cards this way)
      (define (find-initial-matches player)
        (when (ormap (lambda (card) (check-hand player card)) (player-hand player))
          ;; Found a match in the hand
          (find-initial-matches player)))
      (find-initial-matches player-1)
      (find-initial-matches player-2)   
      
      ;; Run the game loop
      (let loop ()
        (set-region-callback! (player-r you) #f)
        (set-region-callback! (player-r player-1) (player-callback player-1))
        (set-region-callback! (player-r player-2) (player-callback player-2))
        (send t set-status YOUR-TURN-MESSAGE)
        (yield something-happened)
        (if go-fish?
            (begin
              (if (if (null? deck)
                      ;; No more cards; pass
                      #f
                      ;; Draw a card (wait for the user to drag it)
                      (begin
                        (send t set-status GO-FISH-MESSAGE)
                        (wiggle-top-card)
                        (enable-your-cards #f)
                        (set-region-callback! (player-r player-1) #f)
                        (set-region-callback! (player-r player-2) #f)
                        (set-region-callback! (player-r you) fishing)
                        (send (car deck) user-can-move #t)
                        (yield something-happened)
                        (enable-your-cards #t)
                        (check-hand you (car (player-hand you)))))
                  (check-done loop)
                  (begin
                    (send t set-status PLAYER-1-NAME)
                    (simulate-player 
                     player-1 player-2
                     (lambda ()
                       (send t set-status PLAYER-2-NAME)
                       (simulate-player player-2 player-1 loop))))))
            (check-done loop))))))
    
    