
(require-library "cards.ss" "games" "cards")

(invoke-unit/sig
 (unit/sig ()
   (import cards^ mzlib:function^ mred^)

   ; 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 "Gin Rummy" 8 4.5))
   (send t create-status-line)
   (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 Gin 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 (quicksort 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)
			(quicksort 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 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 value-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)
     (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)
				   (if (or (= value value2)
					   (and (= suit suit2)
						(> 2 (abs (- value value2)))))
				       1
				       0))
				 suits values)))
		   suits values))))

   ; The procedure implements the machine's card-drawing choice
   (define (machine-wants-card? machine-hand card)
     ; 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)) 
			    (cons card machine-hand))]
	    [new-size (gin-size new-hand)])
       (or (> new-size orig-size)
	   (and (= new-size orig-size)
		(> (pair-rating new-hand) (pair-rating machine-hand))))))
   
   ; The procedure implements the machine's discard choice
   (define (machine-discard machine-hand)
     ; 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))
				       card))
		  machine-hand)]
	    [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))
		   (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)])
		 (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))))))

   ;; Done
   (yield (make-semaphore 0)))
 cards^ mzlib:function^ mred^)
