
(module crazy8s mzscheme
  (require (lib "cards.ss" "games" "cards")
	   (lib "mred.ss" "mred")
	   (lib "class.ss")
           (lib "unit.ss")
           (lib "etc.ss")
	   (lib "list.ss")
           (lib "async-channel.ss")
	   (lib "file.ss"))

  ;; Player record
  (define-struct player (r hand-r  ; region
                         hand))    ; cards
      
  ;; Messages
  (define YOUR-NAME "You")
  (define OPPONENT-X-NAME "Opponent ~a")
  (define OPPONENT-NAME "Opponent")
  (define YOUR-TURN-MESSAGE "Your turn - discard a ~a or crazy 8, or else ~a")
  (define PICK-A-SUIT "Pick a suit")
  (define GAME-OVER-YOU-WIN "Game over - you win!")
  (define GAME-OVER-STUCK "Game over - no one wins")
  (define GAME-OVER "Game over - opponent wins")
  (define NEW-GAME "New Game")
  
  ;; Region layout constants
  (define MARGIN 10)
  (define SUBMARGIN 10)
  (define LABEL-H 15)
  (define BUTTON-HEIGHT 18)
  (define PASS-W 40)
  (define NEW-GAME-W 80)
  (define SEL-WIDTH 32)
  (define SEL-HEIGHT 32)
            
  (provide game-unit)
  
  ;; This unit drives multiple Crazy 8 instances:
  (define game-unit
    (unit
      (import)
      (export)

      ;; Configuration
      (define opponents-count (get-preference 'crazy8s:num-opponents (lambda () 1)))
      (define init-hand-size (get-preference 'crazy8s:hand-size (lambda () 7)))
      (define drag-mode? (get-preference 'crazy8s:drag-mode (lambda () #f)))
      
      (define (start-new-game opponents-count init-hand-size drag-mode?)
	(define orig-eventspace (current-eventspace))
	;; Procedure for a game to use to start a sibling game
	(define (new-game oc ihs dm?)
	  (parameterize ([current-eventspace orig-eventspace])
	    (queue-callback
	     (lambda ()
	       (start-new-game oc ihs dm?)))))
	;; Start a new game as a child process:
	(parameterize ([current-custodian (make-custodian)])
	  (parameterize ([exit-handler (lambda (v)
					 (custodian-shutdown-all (current-custodian)))])
	    (parameterize ([current-eventspace (make-eventspace)])
	      (queue-callback
	       (lambda ()
		 (invoke-unit configured-game-unit 
			      opponents-count 
			      init-hand-size
                              drag-mode?
			      new-game)))))))

      ;; Start the initial child game:
      (start-new-game opponents-count init-hand-size drag-mode?)))
  
  ;; This unit is for a particular Crazy 8 instance:
  (define configured-game-unit
    (unit
      (import opponents-count init-hand-size drag-mode? new-game)
      (export)

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

      ;; Set up the table
      (define t (make-table "Crazy 8s" 8 5.5))

      ;; Add status line and buttons:
      (define status-pane (send t create-status-pane))
      (new button% 
	   (parent status-pane)
	   (label "Options...")
	   (callback (lambda (b e) (configure-dialog))))
      (send t add-help-button status-pane (list "games" "crazy8s") "Crazy 8s Help" #f)

      ;; The "Options.." button opens a configuration dialog that
      ;;  starts a new game:
      (define (configure-dialog)
	(define d (new dialog%
		       [parent t]
		       [label "Crazy 8 Options"]))
        (define kinds (new radio-box%
			   [label #f]
			   [choices '("1 opponent, 10 cards"
				      "1 opponent, 7 cards"
				      "2 opponents, 7 cards"
				      "3 opponents, 7 cards")]
			   [parent (new group-box-panel%
					[parent d]
					[label "Players and Cards"])]
			   [callback void]))
	(define drag-mode-check
          (new check-box%
               [parent d]
               [label "Drag cards instead of single-click"]
               [callback void]))
	(define button-panel (new horizontal-pane%
				  [parent d]
				  [alignment '(right center)]))
	(new button%
	     [label "Close"]
	     [parent button-panel]
	     [callback (lambda (b e)
			 (send d show #f))])
	(new button%
	     [label "New Game"]
	     [parent button-panel]
	     [callback (lambda (b e)
			 (let-values ([(oc ihs)
				       (case (send kinds get-selection)
					 [(0) (values 1 10)]
					 [(1) (values 1 7)]
					 [(2) (values 2 7)]
					 [(3) (values 3 7)])]
                                      [(dm?) (send drag-mode-check get-value)])
			   (put-preferences
			    '(crazy8s:num-opponents crazy8s:hand-size crazy8s:drag-mode)
			    (list oc ihs dm?)
			    void)
			   (new-game oc ihs dm?)
			   (send d show #f)))]
	     [style '(border)])
	(send kinds set-selection
	      (case opponents-count
		[(1) (if (= init-hand-size 7) 1 0)]
		[(2) 2]
		[(3) 3]))
        (send drag-mode-check set-value drag-mode?)
	(send d show #t))

      ;; Show the table
      (send t show #t)

      ;; ========== Cards setup ========================================

      ;; Set the default card actions:
      (send t set-double-click-action #f)
      (send t set-button-action 'left 'drag-raise/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 all-cards (shuffle-list (make-deck) 7))
      (define deck all-cards)
      (define discards null)
      (for-each
       (lambda (card)
	 (send card user-can-flip #f))
       deck)

      ;; We'll need an 8 of each suit for substitutions later
      (define (find-8 suit)
	(ormap (lambda (c)
		 (and (= 8 (send c get-value))
		      (eq? suit (send c get-suit))
		      (send c copy)))
	       deck))
      (define 8-hearts (find-8 'hearts))
      (define 8-spades (find-8 'spades))
      (define 8-clubs (find-8 'clubs))
      (define 8-diamonds (find-8 'diamonds))
      
      ;; 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))
      
      ;; Make regions for deck and descard
      (define deck-region
	(make-region (- (/ (- w cw) 2) (/ (+ cw MARGIN) 2))
		     (/ (- h ch) 2)
		     cw ch
		     #f #f))
      (define discard-region
	(make-region (+ (region-x deck-region) cw MARGIN)
		     (region-y deck-region)
		     cw ch
		     #f #f))
      (define discard-target-region
	(make-region (- (region-x discard-region) (/ MARGIN 2))
		     (- (region-y discard-region) (/ MARGIN 2))
		     (+ cw MARGIN) (+ ch MARGIN)
		     "" #f))
      (when drag-mode?
        (send t add-region discard-target-region))

      ;; Put the cards on the table
      (send t add-cards-to-region deck deck-region)      
      
      ;; Make regions for choosing a suit
      (define (make-suit-region x y label card)
	(let ([bm (make-object bitmap%
			       (build-path (collection-path "games" "crazy8s")
					   "images"
					   (format "~a.png" label))
			       'unknown/mask)])
	  (make-button-region x y
			      SEL-WIDTH SEL-HEIGHT
			      bm
			      ;; The callback for the region sends
			      ;;  a clonable card to the game driver
			      (lambda ()
				(async-channel-put msg card)))))
      (define hearts-region
	(make-suit-region (+ (region-x discard-target-region) cw (* 2 MARGIN))
			  (+ (region-y discard-target-region)
			     (/ (- ch (* 2 SEL-HEIGHT) (/ MARGIN 2)) 2))
			  "heart" 8-hearts))
      (define spades-region
	(make-suit-region (+ (region-x hearts-region) SEL-WIDTH (/ MARGIN 2))
			  (region-y hearts-region)
			  "spade" 8-spades))
      (define clubs-region
	(make-suit-region (region-x hearts-region)
			  (+ (region-y hearts-region) SEL-HEIGHT (/ MARGIN 2))
			  "club" 8-clubs))
      (define diamonds-region
	(make-suit-region (region-x spades-region)
			  (region-y clubs-region)
			  "diamond" 8-diamonds))

      ;; Make the "Pass" button:
      (define pass-button
	(make-button-region (+ (region-x deck-region)
			       (/ (- cw PASS-W) 2))
			    (+ (region-y deck-region)
			       (/ (- ch BUTTON-HEIGHT) 2))
			    PASS-W BUTTON-HEIGHT
			    "Pass" (lambda ()
				     (async-channel-put msg 'pass))))

      ;; Player region size
      (define pw (/ (- w (* opponents-count MARGIN)) opponents-count))
      (define ph (- (/ (- h ch) 2) (* 2 MARGIN)))
      
      ;; Define the players with their regions
      (define (make-a-player x y w h lbl)
	(let ([r (make-region x y w h lbl #f)])
	  (send t add-region r)
	  (make-player
	   r
	   (make-region (+ x SUBMARGIN) (+ y SUBMARGIN LABEL-H)
			(- w (* 2 SUBMARGIN))
			(- h (* 2 SUBMARGIN) LABEL-H)
			#f #f)
	   null)))
      (define players
	(cons
	 ;; You
	 (make-a-player
	  (/ MARGIN 2) (- h ph (/ MARGIN 2))
	  (- w MARGIN) ph
	  YOUR-NAME)
	 (build-list
	  opponents-count
	  (lambda (delta)
	    (make-a-player
	     (+ (* (+ pw MARGIN) delta) (/ MARGIN 2)) (/ MARGIN 2)
	     pw ph
	     (if (= opponents-count 1)
		 OPPONENT-NAME
		 (format OPPONENT-X-NAME (+ 1 delta))))))))
      (define you (car players))
      (define opponents (cdr players))

      ;; Add the "Clean" and "Sort" buttons:
      (define (sort-hand! card<)
        (let ([sorted
               (quicksort
                (player-hand you)
                card<)])
          (set-player-hand! you sorted)
          (send t stack-cards sorted)
          (send t move-cards-to-region
                sorted
                (player-hand-r you))))
      (define clean-button
        (make-button-region (region-x (player-r you))
                            (- (region-y (player-r you))
                               (+ BUTTON-HEIGHT MARGIN))
                            PASS-W BUTTON-HEIGHT
                            "Clean" (lambda ()
                                      (sort-hand!
                                       (lambda (a b)
                                         (let-values ([(ax ay) (send t card-location a)]
                                                      [(bx by) (send t card-location b)])
                                           (> ax bx)))))))
      (send t add-region clean-button)
      (define (remap v)
        ;; So that black and red suits are interleaved
        (case v [(2) 1][(1) 2][else v]))
      (define (card< a b)
	(cond
	 [(= 8 (send a get-value))
	  (or (not (= 8 (send b get-value)))
	      (< (remap (send a get-suit-id))
		 (remap (send b get-suit-id))))]
	 [(= 8 (send b get-value))
	  #f]
	 [(= (send a get-suit-id)
	     (send b get-suit-id))
	  (< (send a get-value)
	     (send b get-value))]
	 [else 
	  (< (remap (send a get-suit-id))
	     (remap (send b get-suit-id)))]))
      (when drag-mode?
        (send t add-region
              (make-button-region (+ (region-x clean-button) PASS-W MARGIN)
                                  (region-y clean-button)
                                  PASS-W BUTTON-HEIGHT
                                  "Sort" (lambda ()
                                           (sort-hand! card<)))))
      
      ;; ========== Game engine ========================================

      ;; Callbacks communicate back to the main loop
      (define msg (make-async-channel))
      
      ;; Utility: Determine whether a list of cards corresponds to a
      ;; valid discard; return one card or #f
      (define (get-discard-card cs)
	(and (= 1 (length cs))
	     (let ([c (car cs)])
	       (and (memq c (player-hand you))
		    (or (= (send (car discards) get-value)
			   (send c get-value))
			(= (send (car discards) get-suit-id)
			   (send c get-suit-id))
			(= (send c get-value) 8))
		    c))))

      ;; Utility: detect a stuck game
      (define (stuck-game?)
	(and (null? deck)
	     (not (ormap (lambda (p)
                           (and (pair? (player-hand p))
                                (ormap (lambda (c)
                                         (get-discard-card (list c)))
                                       (player-hand p))))
			 players))))
      
      ;; Auto-player strategy: Choose which valid card to discard
      (define (pick-to-discard cards)
	(let ([non-8s (filter (lambda (c)
				(not (= 8 (send c get-value))))
			      cards)])
	  (if (null? non-8s)
	      (car cards)
	      (car non-8s))))
      
      ;; Auto-player: take a turn
      (define (play-opponent p)
	(let ([suit-id (send (car discards) get-suit-id)]
	      [value (send (car discards) get-value)])
	  ;; Which cards can we discard?
	  (let ([matches (filter (lambda (c)
				   (or (= suit-id (send c get-suit-id))
				       (= value (send c get-value))
				       (= 8 (send c get-value))))
				 (player-hand p))])
	    (if (null? matches)
		;; Can't discard, so draw or pass
		(if (pair? deck)
		    ;; Draw
		    (begin
		      (send t card-to-front (car deck))
		      (set-player-hand! p (append (deal 1) (player-hand p)))
		      (send t move-cards-to-region (player-hand p) (player-hand-r p))
		      (play-opponent p))
		    ;; Pass
		    (begin
		      (send t hilite-region (player-r p))
		      (send t pause 0.25)
		      (send t unhilite-region (player-r p))
		      #t))
		;; Discard
		(let ([c (pick-to-discard matches)])
		  (set-player-hand! p (remq c (player-hand p)))
		  (send t flip-card c)
		  (send t card-to-front c)
		  (send t move-cards-to-region (list c) discard-region)
		  (send t move-cards-to-region (player-hand p) (player-hand-r p))
		  (set! discards (cons c discards))
		  ;; Did we just discard an 8? (And we still have cards?)
		  (when (and (= 8 (send (car discards) get-value))
			     (pair? (player-hand p)))
		    ;; Pick a suit based on our hand
		    (let ([counts (map (lambda (v)
					 (cons v
					       (length (filter (lambda (c)
								 (and (= v (send c get-suit-id))
								      (not (= 8 (send c get-value)))))
							       (player-hand p)))))
				       '(1 2 3 4))])
		      (let ([suit-id
			     ;; Sort based on counts, then pick the first one:
			     (sub1 (caar (quicksort counts (lambda (a b) (> (cdr a) (cdr b))))))])
			;; Find the clonable 8 for the chosen suit, and reset the discard
			(reset-8
			 (list-ref
			  (list 8-clubs 8-diamonds 8-hearts 8-spades)
			  suit-id)))))
		  ;; Return #f if this player has just won:
		  (pair? (player-hand p)))))))            
      
      ;; Utility: disables cards for "you"
      (define (allow-cards on?)
        (when (pair? deck)
          (send (car deck) user-can-move (and drag-mode? on?)))
        (for-each (lambda (c)
                    (send c user-can-move (and drag-mode? on?)))
                  (player-hand you))
        (send t set-single-click-action (if (and on? (not drag-mode?))
                                            click-card
                                            (if drag-mode?
                                                void
						(lambda (x) (bell)))))
	(when (null? deck)
	  (if on?
	      (send t add-region pass-button)
	      (send t remove-region pass-button))))
      
      ;; Utility: replaces the top discard, which is an 8, with an 8
      ;; of a particular suit (possibly the same).
      (define (reset-8 got-8)
	(unless (eq? (send (car discards) get-suit)
		     (send got-8 get-suit))
	  (let ([c (send got-8 copy)])
	    (send c user-can-move #f)
	    (send t flip-card (car discards))
	    (send t add-cards-to-region (list c) discard-region)
	    (send t card-to-front c)
	    (send t remove-card (car discards))
	    (set! discards (cons c (cdr discards)))
	    (send t flip-card c))))
      
      ;; Sub-game: the user just discarded an 8, so pick a suit:
      (define (pick-suit)
	(allow-cards #f)
	(send t add-region hearts-region)
	(send t add-region spades-region)
	(send t add-region clubs-region)
	(send t add-region diamonds-region)
	(send t set-status PICK-A-SUIT)
	;; Clicking one of these regions returns a clonable 8 card:
	(let ([got-8 (yield msg)])
	  (reset-8 got-8))
	(send t remove-region hearts-region)
	(send t remove-region spades-region)
	(send t remove-region clubs-region)
	(send t remove-region diamonds-region)
	(allow-cards #t))

      ;; Install interactive callback for discard: accept the card
      ;; (from the player's hand) and release it from its home:
      (set-region-interactive-callback! 
       discard-target-region
       (lambda (in? cs)
	 (let ([c (get-discard-card cs)])
	   (when c
	     (send c home-region (if in? #f (player-r you)))))))

      ;; Install final callback for discard: perform the discard
      (set-region-callback! 
       discard-target-region
       (lambda (cs)
	 (let ([c (get-discard-card cs)])
	   (when c
             (you-discard c)))))
      
      (define (you-discard c)
        (send c home-region #f)
        (set! discards (cons c discards))
        (set-player-hand! you (remq c (player-hand you)))
        (send t card-to-front c)
        (send t move-cards-to-region (list c) discard-region)
        (send c user-can-move #f)
        (async-channel-put msg 'discard))

      ;; Install interactive callback for hand: accept the card
      ;; (from the deck) and release it from its home:
      (set-region-interactive-callback! 
       (player-r you)
       (lambda (in? cs)
	 (send (car cs) home-region 
	       (if in? (player-r you) deck-region))))

      ;; Install final callback for hand: draw the card:
      (set-region-callback! 
       (player-r you)
       (lambda (cs)
	 (let ([c (car cs)])
           (you-draw c))))
      
      (define (you-draw c)
        (send t flip-card c)
        (send c home-region (player-r you))
        (set-player-hand! you (let loop ([l (player-hand you)])
                                (cond
                                  [(null? l) (list c)]
                                  [(card< c (car l)) (cons c l)]
                                  [else (cons (car l) (loop (cdr l)))])))
        (deal 1)
        (unless drag-mode?
          (send t stack-cards (player-hand you))
          (send t move-cards-to-region (player-hand you) (player-hand-r you)))
        (async-channel-put msg 'draw))
      
      (define (click-card c)
        (cond
          [(memq c deck) (you-draw c)]
          [(memq c (player-hand you)) 
           (if (get-discard-card (list c))
               (you-discard c)
               (bell))]
          [else (bell)]))
      
      (unless drag-mode?
        (send t set-single-click-action click-card))

      ;; Run a loop for multiple games
      (let gloop ()

	;; Card setup: Deal the cards
	(for-each (lambda (player)
		    (set-player-hand! player (quicksort (deal init-hand-size) card<))
		    (send t stack-cards (player-hand player))
		    (send t move-cards-to-region 
			  (player-hand player)
			  (player-hand-r player)))
		  players)

	;; Opponents's cards and deck initally can't be moved
	(for-each
	 (lambda (card) (send card user-can-move #f))
	 (append
	  (apply append
		 (map player-hand (if drag-mode? opponents players)))
	  deck))
	;; Your cards stay home:
	(for-each (lambda (c) 
		    (send c home-region (player-r you))
		    (send c user-can-move drag-mode?))
		  (player-hand you))
      
	;; Initial discard
	;;  If it's an eight, then shuffle and try again
	(let loop ()
	  (when (= 8 (send (car deck) get-value))
	    (set! deck (shuffle-list deck 1))
	    (send t stack-cards deck)
	    (loop)))
	(set! discards (deal 1))
	(send t flip-cards discards)
	(send t move-cards-to-region discards discard-region)
      
	;; Show your cards
	(send t flip-cards (player-hand you))
      
	;; Run a single-game loop
	(let loop ()
	  ;; Ready deck and/or pass button:
	  (when (pair? deck)
	    (when drag-mode?
	      (send (car deck) user-can-move #t))
	    (send (car deck) home-region deck-region))
	  (when (null? deck)
	    (send t add-region pass-button))
	  ;; Tell the player what to do:
	  (send t set-status (format YOUR-TURN-MESSAGE
				     (let ([v (send (car discards) get-value)]
					   [suit (case (send (car discards) get-suit)
						   [(hearts) "heart"]
						   [(spades) "spade"]
						   [(diamonds) "diamond"]
						   [(clubs) "club"])])
				       (if (= v 8)
					   suit
					   (format "~a, ~a," 
						   suit
						   (case v
						     [(1) "ace"]
						     [(11) "jack"]
						     [(12) "queen"]
						     [(13) "king"]
						     [else v]))))
				     (if (null? deck)
					 "pass"
					 "draw")))
	  ;; What for something to happen:
	  (let ([what (yield msg)])
	    ;; Discarded a crazy 8? (And not as our last card?)
	    (when (and (eq? what 'discard)
		       (= 8 (send (car discards) get-value))
		       (pair? (player-hand you)))
	      ;; Yes, so pick suit before continuing
	      (pick-suit))
	    ;; What did we do?
	    (case what
	      [(draw)
	       ;; Go again
	       (loop)]
	      [(discard pass)
	       ;; Hide pass button...
	       (when (null? deck)
		 (send t remove-region pass-button))
	       ;; ... and run opponents
	       (send t set-status "Opponent's turn...")
	       (unless (null? (player-hand you))
		 (let oloop ([l opponents])
		   (cond
		    [(null? l) 
		     ;; Check for a stuck game here:
		     (unless (stuck-game?)
		       (loop))]
		    [else (when (play-opponent (car l))
			    (oloop (cdr l)))])))])))
      
	;; Game over: disable player:
	(allow-cards #f)
	
	;; Report result:
	(send t set-status (cond
			    [(null? (player-hand you))
			     GAME-OVER-YOU-WIN]
			    [(stuck-game?)
			     GAME-OVER-STUCK]
			    [else
			     GAME-OVER]))

	(let ([button
	       (make-button-region 
		(+ (region-x discard-region) cw (* 2 MARGIN))
		(+ (region-y discard-region) (/ (- ch LABEL-H) 2))
		NEW-GAME-W LABEL-H
		NEW-GAME (lambda ()
			   (async-channel-put msg 'new-game)))])
	  (send t add-region button)
	  (yield msg)
	  (send t remove-region button))

	(let ([all (send t all-cards)])
	  ;; Gather up cards, with animation
	  (let ([flip (filter
		       (lambda (c)
			 (not (send c face-down?)))
		       all)])
	    (send t flip-cards flip)
	    (send t move-cards-to-region all deck-region))
	  ;; Reset all cards (no animation)
	  (send t begin-card-sequence)
	  (send t remove-cards all)
	  (send t add-cards-to-region all-cards deck-region)
	  (set! deck (shuffle-list all-cards 7))
	  (for-each (lambda (c)
		      (unless (send c face-down?)
			(send c flip)))
		    deck)
	  (send t stack-cards deck)
	  (send t end-card-sequence))

	;; Re-enable player:
	(allow-cards #t)

	(gloop)))))

