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

(provide game@)
(define game@ (unit (import) (export)

;; Initial card count
(define DEAL-COUNT 10)

;; Messages
(define YOUR-TURN-MESSAGE "Your turn.  (Draw a card or pickup a discard.)")
(define DISCARD-MESSAGE "Drag a card from your hand to discard.")
(define GAME-OVER-MESSAGE "GAME OVER")

;; Area labels
(define YOU-NAME "You")
(define MACHINE-NAME "Opponent")

;; Region layout constants
(define MARGIN 5)
(define LABEL-H 15)

;; Randomize
(random-seed (modulo (current-milliseconds) 10000))

;; Set up the table
(define t (make-table "Rummy" 8 4.5))
(define status-pane (send t create-status-pane))
(send t add-scribble-button status-pane
      '(lib "games/scribblings/games.scrbl") "ginrummy")
(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/above)

;; 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 user-can-move #f)
            (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))

;; Draw and discard pile locations
(define draw-x (/ (- w (* 3 cw)) 2))
(define draw-y (/ (- h ch) 2))
(define discard-x (+ draw-x (* 2 cw)))
(define discard-y draw-y)

;; Put the cards on the table
(send t add-cards deck draw-x draw-y)

;; Player region size
(define pw (- w (* 2 MARGIN)))
(define ph (- (* 1.75 ch) (* 4 MARGIN)))

;; Define the regions
(define machine-region
  (make-region MARGIN MARGIN pw ph MACHINE-NAME #f))
(define you-region
  (make-region MARGIN (- h ph MARGIN) pw ph YOU-NAME void))
(define discard-region
  (make-region (- discard-x MARGIN) (- discard-y MARGIN)
               (+ cw (* 2 MARGIN)) (+ ch (* 2 MARGIN))
               "" #f))

;; Install the visible regions
(send t add-region machine-region)
(send t add-region you-region)
(send t add-region discard-region)

;; Deal the initial hands
(define machine-hand (deal DEAL-COUNT))
(define you-hand (deal DEAL-COUNT))

      ;; Function to inset a region
(define (region->display-region r)
  (define m MARGIN)
  (make-region (+ m (region-x r)) (+ m (region-y r))
               (- (region-w r) (* 2 m)) (- (region-h r) (* 2 m))
               #f #f))

;; Place cards nicely
(define machine-display-region (region->display-region machine-region))
(send t move-cards-to-region machine-hand machine-display-region)
(send t move-cards-to-region you-hand (region->display-region you-region))

;; All cards in your hand are movable, but must stay in your region
(for-each (lambda (card) 
            (send card home-region you-region)
            (send card user-can-move #t))
          you-hand)

;; More card setup: Show your cards
(send t cards-face-up you-hand)

;; Start the discard pile
(define discards (deal 1))
(send t card-face-up (car discards))
(send t move-card (car discards) discard-x discard-y)

;; ;;;;;;;;;;;;; Finding Rummy and The Machine Player Strategy ;;;;;;;;

;; Check whether a group of (at least 3) cards forms a set (building
;; up to gin).
(define (set? cards)
  (let ([values (map (lambda (c) (send c get-value)) cards)]
        [suits (map (lambda (c) (send c get-suit-id)) cards)])
    ;; All same value? ... or
    (or (apply = values)
        ;; ... All same suit and a straight?
        (and (apply = suits)
             (let ([sorted (sort values <)]
                   [try (lambda (l)
                          (let loop ([l l])
                            (or (null? (cdr l))
                                (and (= (car l) (sub1 (cadr l)))
                                     (loop (cdr l))))))])
               ;; Try with Ace at end and at beginning
               (or (try sorted)
                   (and (= 1 (car sorted))
                        (try (append (cdr sorted) (list 14))))))))))

;; Check how close a hand comes to winning by returning the maximum number of
;; cards that can be arranged into sets. This function is used both to detect
;; gin for the end-of-game condition, and also as part of the machine player's
;; strategy.
(define (gin-size cards)
  (if (<= (length cards) 2)
    0
    (let* ([sort (lambda (get)
                   (sort cards (lambda (a b) (< (get a) (get b)))))]

           ;; It's not reasonable to test every combination of 10 cards, but we
           ;; can cut down the search space a lot by starting with two
           ;; different sorts on the card list.

           ;; We sort by value, to find 3-of-a-kind sets, and by
           ;; suit-then-value, to find straights. Whatever the best allocation
           ;; of cards to sets, one of the sets must show up as three cards
           ;; together in one of the sorted lists.  Also, if an extension to
           ;; that set leads to an optimal allocation, the extended set
           ;; corresponds to an extended section of the list.
           [value-sorted (sort (lambda (c) (send c get-value)))]
           [suit-sorted (sort (lambda (c) (+ (* 20 (send c get-suit-id)) (send c get-value))))]

           ;; Procedure to find a set allocation given one of the sorted
           ;; lists. It picks each group of three consecutive items from the
           ;; list and see how that choice works out.  (We're still performing
           ;; a lot of redundant work here, but it's fast enough.)
           [find-set
            (lambda (l)
              ;; 3loop tries each group of three items
              (let 3loop ([pre null] ; prefix we've tried already
                          [group (list (car l) (cadr l) (caddr l))] ; the group to try
                          [post (cdddr l)]) ; suffix we haven't tried yet
                (max (if (set? group)
                       ;; We have a start; try to extend or not, and
                       ;; make gin with the rest, then try the next 3-set
                       (max (let exloop ([set group][post post])
                              (cond
                                [(null? post)
                                 ;; No more items? Can't extend the set. Does the
                                 ;; set we found work out in the long run?
                                 (+ (length set)
                                    (if (null? pre) 0 (gin-size pre)))]
                                ;; Try to extend the set...
                                [(set? (cons (car post) set))
                                 ;; The set can be extended.  Maybe this
                                 ;; extension works in the long run...
                                 (max (exloop (cons (car post) set) (cdr post))
                                      ;; or maybe without extension works in
                                      ;; the long run...
                                      (+ (length set) (gin-size (append pre post))))]
                                ;; Can't extend the set, so try without
                                ;; extension
                                [else (+ (length set)
                                         (gin-size (append pre post)))])))
                       0)
                     ;; Try next three, if possible
                     (if (null? post)
                       0
                       ;; Rotate the group, pulling a new last item in from
                       ;; post and kicking the first item out to pre.
                       (3loop (cons (car group) pre)
                              (list (cadr group) (caddr group) (car post))
                              (cdr post))))))])
      ;; Try the value-sorted list, the suit-sorted list, then...
      (max (find-set value-sorted)
           (find-set suit-sorted)
           ;; the suit-sorted list with with Aces at the end instead of the
           ;; beginning
           (let ace-loop ([pre null][l suit-sorted])
             (cond
               [(null? l)
                ;; No more aces to find
                (find-set (reverse pre))]
               [(null? (cdr l))
                ;; No more aces to find
                (find-set (reverse (cons (car l) pre)))]
               ;; Is the front card an ace (before something else of the same
               ;; suit)?
               [(and (= 1 (send (car l) get-value))
                     (= (send (car l) get-suit-id) (send (cadr l) get-suit-id)))
                ;; Ace is at beginning; move it to the end
                (let* ([ace (car l)]
                       [ace-suit (send ace get-suit-id)])
                  (let loop ([pre (cons (cadr l) pre)][l (cddr l)])
                    ;; At end of this suit?
                    (if (or (null? l) (> (send (car l) get-suit-id) ace-suit))
                      ;; At the end; add Ace here
                      (ace-loop (cons ace pre) l)
                      ;; still looking for new spot for Ace
                      (loop (cons (car l) pre) (cdr l)))))]
               [else
                ;; Didn't find an ace; keep looking
                (ace-loop (cons (car l) pre) (cdr l))]))))))

;; A hand wins if the biggest gin configuration includes all the cards
(define (gin? cards)
  (= (gin-size cards) (length cards)))

;; This procedure is the second part of the machine's strategy. If the machine
;; sees two choices that are equally good according to gin-size, then it
;; computes a rating based on pairs, i.e., cards that might eventually go
;; together in a set.
(define (pair-rating cards gone-cards)
  (let ([suits (map (lambda (card) (send card get-suit-id)) cards)]
        [values (map (lambda (card) (send card get-value)) cards)])
    ;; Its O(n*n), but n is always 10 or 11
    (apply
     + (map (lambda (suit value)
              (apply
               + (map (lambda (suit2 value2)
                        (cond [(= value value2)
                               (- 2 (count-gone value gone-cards))]
                              [(= suit suit2)
                               (rate-straight suit value value2 gone-cards)]
                              [else 0]))
                      suits values)))
            suits values))))

;; count-gone checks how many of a given value are known to be permanently
;; discarded
(define (count-gone value gone-cards)
  (cond [(null? gone-cards) 0]
        [(= value (send (car gone-cards) get-value))
         (+ 1 (count-gone value (cdr gone-cards)))]
        [else (count-gone value (cdr gone-cards))]))

;; count-avail checks whether a given value/suit is
;;  known to be discarded (returns 0) or not (returns 1)
(define (count-avail value suit gone-cards)
  (cond [(null? gone-cards) 1]
        [(and (= value (send (car gone-cards) get-value)) 
              (= suit (send (car gone-cards) get-suit-id))) 
         0]
        [else (count-avail value suit (cdr gone-cards))]))

;; rates the possibility for forming a straight given two card values in a
;; particular suit, and taking into account cards known to be discarded; the
;; rating is the number of non-discarded cards that would form a straight with
;; the given values
(define (rate-straight suit value value2 gone-cards)
  (let ([v1 (if (= value 1)
              (if (value2 . > . 6) 14 1)
              value)]
        [v2 (if (= value2 1)
              (if (value . > . 6) 14 1)
              value2)])
    (let ([delta (abs (- v1 v2))])
      (cond [(= delta 1)
             (cond [(or (= v1 1) (= v2 1))
                    ;; Might get the 3?
                    (count-avail 3 suit gone-cards)]
                   [(or (= v1 14) (= v2 14))
                    ;; Might get the queen?
                    (count-avail 12 suit gone-cards)]
                   [(or (= v1 13) (= v2 13))
                    ;; Might get the jack or ace?
                    (+ (count-avail 11 suit gone-cards)
                       (count-avail 1 suit gone-cards))]
                   [else
                    ;; Might get top or bottom?
                    (+ (count-avail (sub1 (min v1 v2)) suit gone-cards)
                       (count-avail (add1 (max v1 v2)) suit gone-cards))])]
            [(= delta 2)
             ;; Might get the middle one?
             (let ([middle (quotient (+ v1 v2) 2)])
               (count-avail middle suit gone-cards))]
            [else 0]))))

;; The procedure implements the machine's card-drawing choice
(define (machine-wants-card? machine-hand card gone-cards)
  ;; Simple strategy: the machine wants the card if taking it will make the
  ;; gin-size of its hand increase, or if taking it will not make the gin-size
  ;; decrease but will increase the pair rating.
  (let* ([orig-size (gin-size machine-hand)]
         [new-hand (remq (machine-discard (cons card machine-hand) gone-cards) 
                         (cons card machine-hand))]
         [new-size (gin-size new-hand)])
    (or (> new-size orig-size)
        (and (= new-size orig-size)
             (> (pair-rating new-hand gone-cards) 
                (pair-rating machine-hand gone-cards))))))

;; The procedure implements the machine's discard choice
(define (machine-discard machine-hand gone-cards)
  ;; Discard the card that leaves the hand with the largest gin-size.  If
  ;; multiple cards leave the same largest gin size, pick card leaving the best
  ;; pair rating.
  (let* ([gin-size-card-pairs
          (map (lambda (card) (cons (gin-size (remq card machine-hand)) card))
               machine-hand)]
         [most (apply max (map car gin-size-card-pairs))]
         [best (filter (lambda (x) (= most (car x))) gin-size-card-pairs)]
         [best-cards (map cdr best)]
         [rating-card-pairs
          (map (lambda (card)
                 (cons (pair-rating (remq card machine-hand) gone-cards) card))
               best-cards)]
         [most (apply max (map car rating-card-pairs))]
         [best (filter (lambda (x) (= most (car x))) rating-card-pairs)])
    (cdar best)))

;; ;;;;;; Game Loop  ;;;;;;;;

;; This procedure finalizes the display when the game is over
(define (end-of-game why)
  (send t set-status-text
        (format
         "~aGame over. ~a."
         why
         (cond [(and (gin? you-hand) (gin? machine-hand)) "Tie"] ; only on deal
               [(gin? you-hand) "You win"]
               [else "Opponent wins"])))
  (send t cards-face-up machine-hand))

;; Deck empty? Shuffle the discard pile (preserving the top discard)
(define (check-empty-deck)
  (when (null? deck)
    (set! deck (shuffle-list (cdr discards) 7))
    (set! discards (list (car discards)))
    (send t cards-face-down deck)
    (send t stack-cards deck)
    (send t move-cards deck draw-x draw-y)))

;; Check for starge start...
(if (or (gin? you-hand) (gin? machine-hand))
  ;; Someone was delt gin - game over
  (end-of-game "Dealt gin. ")

  ;; This is the main game loop
  (let loop ()
    (check-empty-deck)

    ;; Your turn; you can select the top card on the deck or on the discard
    ;; pile
    (send (car discards) user-can-move #t)
    (send (car discards) snap-back-after-move #t)
    (send (car deck) user-can-move #t)
    (send (car deck) snap-back-after-move #t)
    (send t set-status-text YOUR-TURN-MESSAGE)
    (let ([something-happened (make-semaphore 0)])
      ;; Set callback in your region to receive the deck/discard card
      (set-region-callback!
       you-region
       (lambda (cards)
         (let ([card (car cards)])
           ;; Adjust the deck, discard pile, and your hand
           (if (eq? card (car discards))
             (set! discards (cdr discards))
             (set! deck (cdr deck)))
           (set! you-hand (cons card you-hand))
           (send t card-face-up card))

         ;; Action done - clean up and move on
         (semaphore-post something-happened)
         (unless (null? deck)
           (send (car deck) user-can-move #f)
           (send (car deck) home-region #f))
         (unless (null? discards)
           (send (car discards) user-can-move #f)
           (send (car discards) home-region #f))
         (set-region-callback! you-region #f)
         (set-region-interactive-callback! you-region #f)))
      ;; Interactive callback: change home of card if region is hilited.  As a
      ;; result, the card snaps to where you put it instead of back to its
      ;; original position.
      (set-region-interactive-callback!
       you-region
       (lambda (on? cards)
         (send (car cards) snap-back-after-move (not on?))
         (send (car cards) home-region (and on? you-region))))
      ;; Wait for action (the action itself is handled by the callback
      ;; for you-region)
      (yield something-happened))

    ;; Time for you to discard something
    (send t set-status-text DISCARD-MESSAGE)
    (let ([something-happened (make-semaphore 0)])
      ;; This time, the discard pile is the active region
      (set-region-callback!
       discard-region
       (lambda (cards)
         (let ([card (car cards)])
           ;; Adjust the discard pile and your hand
           (set! you-hand (remq card you-hand))
           (set! discards (cons card discards))
           (send t card-to-front card)
           (send t move-card card discard-x discard-y)

           ;; Discarded card is now relatively immobile
           (send card user-can-move #t)
           (send card home-region #f))

         ;; Action done - clean up and move on
         (semaphore-post something-happened)
         (set-region-callback! discard-region #f)
         (set-region-interactive-callback! discard-region #f)))
      ;; Interactive callback: change home of card if region is hilited,
      ;; so the card you drag snaps to the discard pile.
      (set-region-interactive-callback!
       discard-region
       (lambda (on? cards)
         (send (car cards) home-region (if on? discard-region you-region))))
      ;; Wait for action
      (yield something-happened))

    (if (gin? you-hand)
      ;; Game over
      (end-of-game "")

      ;; Keep going; machine's turn
      (begin
        (check-empty-deck)
        ;; Machine picks a card
        (if (machine-wants-card? machine-hand (car discards) (cdr discards))
          (let ([card (car discards)])
            (set! discards (cdr discards))
            (send t card-face-down card)
            (send card user-can-move #f)
            (set! machine-hand (cons card machine-hand)))
          (let ([card (car deck)])
            (send t card-to-front card)
            (set! deck (cdr deck))
            (send card user-can-move #f)
            (set! machine-hand (cons card machine-hand))))
        (send t move-cards-to-region machine-hand machine-display-region)

        ;; Machine discards
        (let ([card (machine-discard machine-hand discards)])
          (send t card-face-up card)
          (send t card-to-front card)
          (send t move-card card discard-x discard-y)
          (set! discards (cons card discards))
          (set! machine-hand (remq card machine-hand))
          (send t move-cards-to-region machine-hand machine-display-region))

        (if (gin? machine-hand)
          ;; Game over
          (end-of-game "")

          ;; Next turn
          (loop))))))

))
