#lang mzscheme
(require games/cards mred mzlib/class mzlib/unit mzlib/list)

(provide game@)
(define game@ (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-scribble-button status-pane 
      '(lib "games/scribblings/games.scrbl") "gofish")
(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
                               (list* found 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)))))