;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;                          Blackjack
;; 
;; The standard rules apply. Specifics:
;; 
;;   1 player (not counting the dealer)
;; 
;;   4 decks, reshuffled after 3/4 of the cards are used
;; 
;;   Dealer stands on soft 17s
;; 
;;   Splitting allowed only on the first two cards, and only if they
;;    are equal; 10 and the face cards are all considered equal for
;;    splitting
;; 
;;   Doubling allowed on all unsplit hands, not on split hands
;; 
;;   No blackjacks after splitting
;; 
;;   No surrender
;; 
;;   No insurance
;; 
;;   No maximum under-21 hand size
;; 
;;   Dealer's second card is not revealed if the player busts (or
;;     both halves of a split hand bust)
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

   ; Number of decks to use
   (define DECK-COUNT 4)

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

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

   ; Reshuffle when 3/4 of the deck is used
   (define min-deck-size (/ (* DECK-COUNT 52) 4))

   ; Set up the table
   (define t (make-table "Blackjack" 6 3))
   (send t create-status-line)
   (send t show #t)
   (send t set-double-click-action #f)
   (send t set-button-action 'left 'drag/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))

   ; Build the deck
   (define deck 
     (let loop ([n DECK-COUNT])
       (if (zero? n)
	   null
	   (append (make-deck) (loop (sub1 n))))))

   ; Card width & height
   (define cw (send (car deck) card-width))
   (define ch (send (car deck) card-height))

   ; Size of buttons
   (define BUTTON-HEIGHT 16)
   (define BUTTON-WIDTH cw)

   ; Cards are not movable
   (for-each
    (lambda (card)
      (send card user-can-move #f)
      (send card user-can-flip #f))
    deck)

   ; Set up card regions
   (define deck-region 
     (make-region MARGIN MARGIN
		  cw ch #f #f))

   (define discard-region 
     (make-region (- w cw MARGIN) MARGIN
		  cw ch #f #f))

   (define dealer-region 
     (make-region (+ cw (* 2 MARGIN)) MARGIN
		  (- w (* 2 cw) (* 4 MARGIN)) ch 
		  #f #f))

   (define player-region 
     (make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT)
		  (- w (* 2 cw) (* 4 MARGIN)) ch
		  #f #f))

   ; In case of split, we need more regions
   (define ww (* 3/2 cw))
   (define player-2-region 
     (make-region MARGIN (region-y player-region)
		  (- w ww (* 3 MARGIN)) (region-h player-region)
		  #f #f))
   (define player-2-wait-region 
     (make-region (region-x player-2-region) (region-y player-2-region)
		  ww (region-h player-2-region)
		  #f #f))
   (define player-1-region 
     (make-region (- w MARGIN (region-w player-2-region)) (region-y player-2-region)
		  (region-w player-2-region) (region-h player-2-region)
		  #f #f))
   (define player-1-wait-region 
     (make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww)
		  (region-y player-1-region)
		  ww (region-h player-1-region)
		  #f #f))
   (define (make-border-region r)
     (define hm (/ MARGIN 2))
     (make-region (- (region-x r) hm) (- (region-y r) hm)
		  (+ (region-w r) MARGIN) (+ (region-h r) MARGIN) 
		  "" #f))
   (define player-1-border (make-border-region player-1-region))
   (define player-2-border (make-border-region player-2-region))

   ; Player buttons
   (define (make-button title pos)
     (make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2)
			    (* pos (+ BUTTON-WIDTH MARGIN)))
			 (- h MARGIN BUTTON-HEIGHT)
			 BUTTON-WIDTH BUTTON-HEIGHT
			 title void))
   (define hit-button (make-button "Hit" 1))
   (define stand-button (make-button "Stand" 2))
   (define split-button (make-button "Split" 0))
   (define double-button (make-button "Double" 3))

   ; Put the cards on the table
   (send t add-cards-to-region deck deck-region)

   ; Function to compute the normal or minimum value of a card
   (define (min-card-value c)
     (let ([v (send c get-value)])
       (if (> v 10)
	   10
	   v)))

   ; Function to compute the value of a hand, counting aces as 1 or 11
   ;  to get the highest total possible under 21
   (define (best-total l)
     (let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))]
	    [aces (filter (ace? #t) l)]
	    [others (filter (ace? #f) l)]
	    [base (apply + (map min-card-value others))])
       (let loop ([l aces][base base])
	 (cond
	  [(null? l) base]
	  [(<= (+ base (* (length aces) 11)) 21)
	   (+ base (* (length aces) 11))]
	  [else (loop (cdr l) (add1 base))]))))

   ; Function to test whether a hand is a bust
   (define (bust? p)
     (> (best-total p) 21))

   ; Very simple betting...
   (define money 100)
   (define (update-money! d)
     (set! money (+ money d))
     (send t set-status-text (format "You have $~a. (Each bet is $2.)" money)))

   ; Let's play!
   (let shuffle-loop ()
     ; Shuffle the cards, none are discarded, yet
     (let* ([deck (shuffle-list deck 7)]
	    [discard null]
	    [deal (lambda (n)
		    (let deal ([n n])
		      (if (zero? n)
			  null
			  (let ([c (car deck)])
			    (set! deck (cdr deck))
			    (cons c (deal (sub1 n)))))))])
       ; Put the shuffled deck in place
       (send t move-cards-to-region deck deck-region)
       (send t stack-cards deck)
       ; Loop rounds over while there's enough cards in the deck
       (let loop ()
	 ; All bets are $2
	 (update-money! -2)
	 ; Deal to player
	 (let ([p (deal 2)]
	       [p2 null] ; in case of splitting
	       [double? #f]) ; in case of doubling (flag is needed to adjust money)
	   ; Move the player's cards into place and show them
	   (send t move-cards-to-region p player-region)
	   (send t cards-face-up p)
	   ; Deal to dealer
	   (let ([d (deal 2)])
	     ; Move the dealer's cards into place and show one
	     (send t move-cards-to-region d dealer-region)
	     (send t card-face-up (car d))
	     (let* ([continue (make-semaphore)]
		    ; Make a button in the center to show results
		    [make-status
		     (lambda (title continue)
		       (let ([r (make-button-region 
				 (/ (- w (* 2 cw)) 2) 
				 (region-y hit-button)
				 (* 2 cw) BUTTON-HEIGHT
				 title #f)])
			 (set-region-callback! r (lambda () 
						   (send t remove-region r)
						   (semaphore-post continue)))
			 r))]
		    ; Done with hand:
		    [done 
		     (lambda (title continue)
		       (send t remove-region hit-button)
		       (send t remove-region stand-button)
		       (send t add-region (make-status title continue)))]
		    ; Compute winnings (not called for busts by the player)
		    [finish
		     (lambda (p blackjack?)
		       (let ([pt (best-total p)]
			     [dt (best-total d)]
			     [continue (make-semaphore)])
			 (cond
			  [(or (> dt 21) (> pt dt))
			   (update-money! (if blackjack? 5 (if double? 8 4)))
			   (done (if blackjack?
				     "Blackjack"
				     "You Win")
				 continue)]
			  [(> dt pt) 
			   (done (if blackjack?
				     "Dealer Blackjack"
				     "You Lose")
				 continue)]
			  [else (update-money! (if double? 4 2))
				(done "Push" continue)])
			 (yield continue)))]
		    ; Done with the first hand of a split
		    [finish-split
		     (lambda (p player-region player-wait-region player-border)
		       (unless (bust? p)
			 (send t move-cards-to-region p player-region)
			 (send t add-region player-border)
			 (finish p #f)
			 (send t remove-region player-border)
			 (send t move-cards-to-region p player-wait-region)))]
		    ; Player busts
		    [bust (lambda ()
			    (done "Bust" continue))]
		    ; Bust in one hand of a split
		    [local-bust (lambda ()
				  (let ([cont (make-semaphore)])
				    (done "Bust" cont)
				    (yield cont)))]
		    ; Callback for the hit button; the button's callback
		    ;  is changed for diferent modes: normal, split part 1, or split part 2
		    [make-hit-callback
		     (lambda (get-p set-p! player-region bust)
		       (lambda ()
			 (send t remove-region double-button)
			 (send t remove-region split-button)
			 (set-p! (append (deal 1) (get-p)))
			 (send t stack-cards (get-p))
			 (send t move-cards-to-region (get-p) player-region)
			 (send t cards-face-up (get-p))
			 ; Check for bust
			 (when (bust? (get-p))
			   (bust))))])
	       ; Blackjack by player or dealer?
	       (if (or (= 21 (best-total p))
		       (= 21 (best-total d)))
		   (begin
		     ; Show the dealers cards...
		     (send t cards-face-up d)
		     ; ... and compute the result
		     (finish p #t))
		   (begin
		     ; Three basic actions are allowed:
		     (send t add-region hit-button)
		     (send t add-region stand-button)
		     (send t add-region double-button)
		     ; Set the callbacks for normal (unsplit) hands
		     (set-region-callback! hit-button
					   (make-hit-callback
					    (lambda () p)
					    (lambda (v) (set! p v))
					    player-region
					    bust))
		     (set-region-callback! stand-button
					   (lambda ()
					     (semaphore-post continue)))
		     (set-region-callback! double-button
					   (lambda ()
					     ; Note the double for adjusting money on a win
					     (set! double? #t)
					     ; Double the bet
					     (update-money! -2)
					     ; Deal one more card
					     ((region-callback hit-button))
					     ; No more cards or actions, but if the player busted, the hit 
					     ;  callback has already continued
					     (unless (bust? p)
					       (semaphore-post continue))))
		     ; Split allowed?
		     (when (= (min-card-value (car p)) (min-card-value (cadr p)))
		       ; Yes, we can split. If the player hits the split button,
		       ;  we have to split the cards, deal one more to each split
		       ;  half and adjust the callbacks for hit and stand.
		       ; (If aces are split, the round is over.)
		       (send t add-region split-button)
		       (set-region-callback! split-button
					     (lambda ()
					       ; Double our bet...
					       (update-money! -2)
					       ; Split the hand
					       (set! p2 (list (cadr p)))
					       (set! p (list (car p)))
					       ; Move the split halves to the "waiting" area. The
					       ;  active area is reserved for hands that are being
					       ;  played
					       (send t move-cards-to-region p player-1-wait-region)
					       (send t move-cards-to-region p2 player-2-wait-region)
					       ; Deal one more card to each half and move them into place
					       (set! p (append (deal 1) p))
					       (set! p2 (append (deal 1) p2))
					       (send t stack-cards p)
					       (send t stack-cards p2)
					       (send t move-cards-to-region p player-1-wait-region)
					       (send t move-cards-to-region p2 player-2-wait-region)
					       ; Show the newly dealt cards
					       (send t flip-cards (list (car p) (car p2)))
					       ; No more splits, no doubling
					       (send t remove-region split-button)
					       (send t remove-region double-button)
					       ;       Function called when the last split hand is done
					       (let* ([close-split
						       (lambda ()
							 ; Unhilite the second hand
							 (send t remove-region player-2-border)
							 (send t move-cards-to-region p2 player-2-wait-region)
							 ; Let the main loop finish up
							 (semaphore-post continue))]
						      ; Callback to swicth from the first split hand to the second
						      [switch
						       (lambda ()
							 ; Unhilite the first hand
							 (send t remove-region player-1-border)
							 (send t move-cards-to-region p player-1-wait-region)
							 ; Hilite the second hand
							 (send t move-cards-to-region p2 player-2-region)
							 (send t add-region player-2-border)
							 ; Adjust callbacks to operate on the second hand
							 (set-region-callback! 
							  hit-button
							  (make-hit-callback (lambda () p2)
									     (lambda (v) (set! p2 v))
									     player-2-region
									     (lambda ()
									       (local-bust)
									       (close-split))))
							 (set-region-callback!
							  stand-button
							  close-split))])
						 ; Did we split aces?
						 (if (= 1 (send (cadr p) get-value))
						     ; Split aces; no more cards
						     (semaphore-post continue)
						     (begin
						       ; The first of the split hands is ready to go
						       (send t move-cards-to-region p player-1-region)
						       ; Hilite the first hand
						       (send t add-region player-1-border)
						       ; Adjust callbacks to work on the first of a split hand
						       (set-region-callback!
							hit-button
							(make-hit-callback (lambda () p)
									   (lambda (v) (set! p v))
									   player-1-region
									   (lambda ()
									     (local-bust)
									     (switch)
									     (send t add-region hit-button)
									     (send t add-region stand-button))))
						       (set-region-callback! 
							stand-button
							switch)))))))
		     ; Wait until the player is done
		     (yield continue)
		     ; No more player actions; get rid of the buttons
		     (send t remove-region hit-button)
		     (send t remove-region stand-button)
		     (send t remove-region double-button)
		     (send t remove-region split-button)
		     ; If all the player's hards are bust, the dealer doesn't do anything
		     (unless (and (bust? p)
				  (or (null? p2)
				      (bust? p2)))
		       ; Show the dealer's starting hand
		       (send t card-face-up (cadr d))
		       (let loop ()
			 ; Hit on 16 or lower, stand on 17 and higher
			 (when (< (best-total d) 17)
			   ; Hit the dealer
			   (set! d (append (deal 1) d))
			   (send t stack-cards d)
			   (send t move-cards-to-region d dealer-region)
			   (send t cards-face-up d)
			   (loop)))
		       (if (null? p2)
			   ; Finish normal game (adjusts winnings)
			   (finish p #f)
			   ; Finish split game (adjusts winnings for each hand)
			   (begin
			     (finish-split p player-1-region player-1-wait-region player-1-border)
			     (finish-split p2 player-2-region player-2-wait-region player-2-border))))))
	       ; Move all the discarded cards to the back
	       (unless (null? discard)
		 (send t card-to-back (car discard))
		 (send t stack-cards discard))
	       ; Discard all the cards we used
	       (set! discard (append p p2 d discard))
	       (send t cards-face-down discard)
	       (send t move-cards-to-region discard discard-region)
	       ; Go again. Check whether we should reshuffle the deck or keep going with this one
	       (if (< (length deck) min-deck-size)
		   (begin
		     (send t move-cards-to-region deck discard-region)
		     (shuffle-loop))
		   (loop)))))))))
 cards^ mzlib:function^ mred^)

