;;;
;;; poker.scm
;;; CS150 Fall 2007
;;;
;;; Version 1.02: Updated for DrScheme 352 (sort changed)
;;; Version 1.01: corrects higher-hand? implementation for two-pair
;;;

(require (lib "list.ss"))
(require (lib "trace.ss"))

;; Special card values
(define Ace 14)
(define King 13)
(define Queen 12)
(define Jack 11)

;; Suits
(define Hearts "H")
(define Diamonds "D")
(define Clubs "C")
(define Spades "S")

;;; Procedures for single cards

(define (make-card rank suit) 
  (cons rank suit))

(define card-rank car)
(define card-suit cdr)

(define (display-rank rank)
  (if (equal? rank Ace) "A"
      (if (equal? rank King) "K"
          (if (equal? rank Queen) "Q"
              (if (equal? rank Jack) "J"
                  (number->string rank))
                  ))))

(define (display-suit suit)
  (if (equal? suit Hearts) "h"
      (if (equal? suit Diamonds) "d"
          (if (equal? suit Clubs) "c"
              (if (equal? suit Spades) "s"
                  (string-append "[Error: " suit "]"))))))

(define (display-card card)
  (string-append (display-rank (card-rank card)) (display-suit (card-suit card))))

(define (next-rank? rank1 rank2)
  (= (+ 1 (card-rank rank1)) (card-rank rank2)))

(define (same-rank? rank1 rank2)
  ;;; Evaluates to #t iff the first rank is better than the second rank
  (= (card-rank rank1) (card-rank rank2)))

(define (same-suit? rank1 rank2)
  ;;; Evaluates to #t iff the first rank is better than the second rank
  (eq? (card-suit rank1) (card-suit rank2)))

(define (same-card? c1 c2)
  (and (same-rank? c1 c2) (same-suit? c1 c2)))

;;;
;;; Hands - a hand is a list of cards
;;;

(define make-hand list)

(define (display-cards hand)
  ;;; operand: a hand (a list of cards)
  ;;; result: a string that represents the list of cards compactly
  (if (null? hand) ""
      (if (null? (cdr hand))
          (display-card (car hand))
          (string-append (display-card (car hand)) " " (display-cards (cdr hand))))))

(define (display-sorted-cards hand)
  (display-cards (flatten-list (sort-by-ranks hand))))        

(define (combine-adjacent-matches cf lst)
  ;;; operands: a comparison function, a list
  ;;; result: a list of lists where the subelements are the elements of the input lst,
  ;;;            and all elements for which cf is true when adjacent elements are compared
  ;;;            are combined into a sub-list.  For example, 
  ;;;                  (combine-adjacent-matches = (list 1 1 2 3 3 3)) 
  ;;;              ==> (list (list 1 1) (list 2) (list 3 3 3))
  (define (combine-adjacent-matches-helper cf work lst)
    (if (null? lst)
        (list work)
        (if (null? work)
            (combine-adjacent-matches-helper cf (list (car lst)) (cdr lst))
            (if (cf (car work) (car lst))
                (combine-adjacent-matches-helper cf (cons (car lst) work) (cdr lst))
                (cons (reverse work) (combine-adjacent-matches-helper cf null lst))))))
  (combine-adjacent-matches-helper cf null lst))

(define (sort-by-ranks cards)
  ;;; operand: a list of cards
  ;;; result: a sorted list of the cards into lists of cards of each rank, ordered by most 
  ;;;          cards and highest cards within group
  (sort (combine-adjacent-matches same-rank?
                                  (sort-hand cards)) ;; first, sort by rank
	(lambda (r1 r2) 
          (if (= (length r1) (length r2))
              (higher-card? (car r1) (car r2))
              (> (length r1) (length r2))))))
        

;;;
;;; Hand ranking rules
;;;

;;; Identifying hand categories

(define (straight-flush? hand)
  (and (any-straight? hand) (flush? hand)))

(define (four-of-a-kind? hand)
  (= (length (car (sort-by-ranks hand))) 4))

(define (full-house? hand)
  (and
   (= (length (car (sort-by-ranks hand))) 3)
   (= (length (car (cdr (sort-by-ranks hand)))) 2)))

(define (flush? hand) ; All 5 cards are of the same suit
  (= (length (car (combine-adjacent-matches same-suit? (sort-by-suit hand)))) 5))

(define (any-straight? hand)
  (or (straight? hand) (wheel-straight? hand)))
 
(define (straight? hand)
  (= (length (car (combine-adjacent-matches next-rank? (reverse (sort-hand hand))))) 5))

(define (wheel-straight? hand)
   ; need a special test for Wheel straight (a-2-3-4-5)
  (and (= (card-rank (car (sort-hand hand))) Ace)
       (= (card-rank (car (cdr (sort-hand hand)))) 5)
       (= (length (car (combine-adjacent-matches next-rank? (reverse (cdr (sort-hand hand)))))) 4)))

(define (three-of-a-kind? hand)
  (= (length (car (sort-by-ranks hand))) 3))

(define (two-pair? hand)
  (and (= (length (car (sort-by-ranks hand))) 2)
       (= (length (car (cdr (sort-by-ranks hand)))) 2)))

(define (pair? hand)
  (= (length (car (sort-by-ranks hand))) 2))

(define (beats-flush? hand)
  (or (straight-flush? hand) (four-of-a-kind? hand) (full-house? hand)))

(define (beats-straight? hand)
  (or (beats-flush? hand) (flush? hand)))

(define (beats-trips? hand)
  (or (beats-straight? hand) (any-straight? hand)))

(define (beats-two-pair? hand)
  (or (beats-trips? hand) (three-of-a-kind? hand)))

(define (beats-pair? hand)
  (or (beats-two-pair? hand) (two-pair? hand)))

(define (beats-high-card? hand)
  (or (beats-pair? hand) (pair? hand)))

;; To allow sorting, we give the suits numbers, but there is no ordering.
(define (suit-num suit)
  (if (eq? suit Hearts) 0
      (if (eq? suit Diamonds) 1
          (if (eq? suit Clubs) 2
              (if (eq? suit Spades) 3
                  (assert false "Bad suit!"))))))
    
(define (sort-by-suit cards)
  (sort cards
	(lambda (card1 card2)
          (> (suit-num (card-suit card1)) (suit-num (card-suit card2))))))
  
(define (higher-hand? hand1 hand2)
  (cond
    ((straight-flush? hand1)     (or (not (straight-flush? hand2)) 
                                     (and (straight-flush? hand2) (higher-similar-hand? hand1 hand2))))
    ((four-of-a-kind? hand1)     (or (and (not (straight-flush? hand2)) (not (four-of-a-kind? hand2)))
                                     (and (four-of-a-kind? hand2) (higher-similar-hand? hand1 hand2))))
    ((full-house? hand1)         (or (and (not (straight-flush? hand2)) (not (four-of-a-kind? hand2)) (not (full-house? hand2)))
                                     (and (full-house? hand2) (higher-similar-hand? hand1 hand2))))
    ((flush? hand1)              (and (not (beats-flush? hand2))
                                      (or (and (flush? hand2) (higher-similar-hand? hand1 hand2))
                                          (not (flush? hand2)))))
    ((straight? hand1)           (and (not (beats-straight? hand2))
                                      (or (and (straight? hand2) (higher-similar-hand? hand1 hand2))
                                          (not (straight? hand2)))))
    ((wheel-straight? hand1)     (not (or (any-straight? hand2) (beats-straight? hand2))))
    ((three-of-a-kind? hand1)    (and (not (beats-trips? hand2))
                                      (or (and (three-of-a-kind? hand2) (higher-similar-hand? hand1 hand2))
                                          (not (three-of-a-kind? hand2)))))
    ((two-pair? hand1)           (and (not (beats-two-pair? hand2))
                                      (or (and (two-pair? hand2) (higher-similar-hand? hand1 hand2))
                                          (not (two-pair? hand2)))))
    ((pair? hand1)               (and (not (beats-pair? hand2))
                                      (or (and (pair? hand2) (higher-similar-hand? hand1 hand2))
                                          (not (pair? hand2)))))
    (#t                          (and (not (beats-high-card? hand2))
                                      (higher-similar-hand? hand1 hand2)))))

(define (compare-hands? hand1 hand2)
  (if (higher-hand? hand1 hand2)
      'higher
      (if (higher-hand? hand2 hand1) 'weaker 'equal)))
          
(define (choose-n n lst)
  ;; parameters: a number n and a list (of at least n elements)
  ;; result: evaluates to a list of all possible ways 
  ;;           of choosing n elements from lst
  (if (= n 0) 
      (list null) 
      (if (= (length lst) n) 
          (list lst) ; must use all elements
          (append (choose-n n (cdr lst)) ;; all possibilities not using the first element
                  (map (lambda (clst) (cons (car lst) clst)) 
                       (choose-n (- n 1) (cdr lst))))))) ;;; all possibilities using the first element
     
(define (flatten-list lst)
  ;; See if you can figure out what this does
  (if (null? lst) lst
      (append (car lst) (flatten-list (cdr lst)))))
  
(define (remove-card card deck)
  ;; precondition: card must be in deck
  ;; remove the card from the deck
  (if (null? deck)
      (assert #f "Error: card not in deck")
      (if (same-card? (car deck) card)
          (cdr deck) ; keep the rest of the deck
          (cons (car deck) (remove-card card (cdr deck))))))
  
(define (remove-cards cards deck)
  (if (null? cards)
      deck
      (remove-cards (cdr cards) (remove-card (car cards) deck))))

(define full-deck
  (flatten-list
   (map (lambda (rank) (map (lambda (suit) (make-card rank suit))
                            (list Hearts Diamonds Clubs Spades)))
        (list 2 3 4 5 6 7 8 9 10 Jack Queen King Ace))))

(define (accumulate-outs lst)
  ;; operand: lst is a list of triples representing <winner, chopper, loser> cards
  ;; result: a list of <winning-outs, chopping-outs, losers> accumulating the corresponding
  ;;         elements from the input sub-lists
  (if (null? lst) (list null null null)
      (let ((rest-outs (accumulate-outs (cdr lst))))
        (list (append (car (car lst)) (car rest-outs))
              (append (car (cdr (car lst))) (car (cdr rest-outs)))
              (append (car (cdr (cdr (car lst)))) (car (cdr (cdr rest-outs))))))))
      
(define (show-analysis outs)
  (printf "Winning outs (~a): ~a~nChopping outs (~a): ~a~nLosers (~a): ~a~n"
          (length (car outs)) (display-cards (car outs))
          (length (car (cdr outs))) (display-cards (car (cdr outs)))
          (length (car (cdr (cdr outs)))) (display-cards (car (cdr (cdr outs))))))                      

(define (analyze-turn-situation hole1 hole2 community)
  ;; operands: hole cards for player 1 and play 2 and community cards
  ;;     there must be 2 cards in each players hole cards and 4 community cards
  ;; result: a list of three elements (winning-outs, chopping-outs, loser) showing
  ;;     the river cards that will lead for the each outcome for player 1.
  (let ((current-deck (remove-cards (append hole1 hole2 community) full-deck)))
    ;; we want to find out how many of the remaining cards produce each result
    (accumulate-outs
     (map (lambda (river-card) 
            (let ((outcome (compare-hands?
                                    (find-best-hand hole1 (cons river-card community))
                                    (find-best-hand hole2 (cons river-card community)))))
              (if (eq? outcome 'higher)
                  (list (list river-card) null null)
                  (if (eq? outcome 'equal)
                      (list null (list river-card) null) ; chop
                      (list null null (list river-card))))))
          current-deck))))

(define (show-flop-analysis outs)
  (printf "Winning outs (~a): ~a~nChopping outs (~a): ~a~nLosers (~a): ~a~n"
          (length (car outs)) 
          (map (lambda (cards) (string-append (display-cards cards) " ")) (car outs))
          (length (car (cdr outs))) 
          (map (lambda (cards) (string-append (display-cards cards) " ")) (car (cdr outs)))
          (length (car (cdr (cdr outs)))) 
          (map (lambda (cards) 
                 (string-append (display-cards cards) " "))
               (car (cdr (cdr outs))))))                      

(define (show-flop-analysis outs)
  (define (analyze-flop-outs flist)
    (apply + (map (lambda (turn river) 
                    (printf "Turn: ~a Rivers: ~a~n" (display-card turn) (display-cards river))
                    (length river))
                  (map car (map append flist)) (map cdr (map append flist)))))
  (let ((winning-outs (begin (display "Winners:") (analyze-flop-outs (map car outs))))
        (chopping-outs (begin (display "Choppers:") (analyze-flop-outs (map cadr outs))))
        (losers (begin (display "Losers:") (analyze-flop-outs (map caddr outs)))))
    (let ((total (+ winning-outs chopping-outs losers)))
      (printf "Winning odds (~a): ~a  Chopping odds (~a): ~a  Losing odds (~a): ~a~n"
              winning-outs (exact->inexact (/ winning-outs total))
              chopping-outs (exact->inexact (/ chopping-outs total))
              losers (exact->inexact (/ losers total))))))

(define (analyze-flop-situation hole1 hole2 community)
  ;; operands: hole cards for player 1 and play 2 and community cards
  ;;     there must be 2 cards in each players hole cards and 3 community cards
  ;; result: a list of three elements (winning-outs, chopping-outs, loser) showing
  ;;     the turn and river cards that will lead for the each outcome for player 1.
  (let ((current-deck (remove-cards (append hole1 hole2 community) full-deck)))
    ;; we want to find out how many of the remaining cards produce each result
    (map (lambda (turn-card) 
           (map (lambda (outs)
                  (cons turn-card outs))
                (analyze-turn-situation hole1 hole2 (cons turn-card community))))
         current-deck)))

;;; Here are some sample hands defined in order from strongest to weakest. 
;;; You will also want to make your own hands for testing.

(define royal-flush
  (list (make-card Ace Hearts) (make-card King Hearts) (make-card Queen Hearts)
        (make-card Jack Hearts) (make-card 10 Hearts)))

(define quad-sixes
  (make-hand (make-card 6 Clubs) (make-card 6 Spades) (make-card 6 Diamonds)
             (make-card 6 Hearts) (make-card 4 Clubs)))

(define kings-full-of-aces
  (make-hand (make-card King Spades) (make-card King Spades) (make-card King Diamonds)
             (make-card Ace Clubs) (make-card Ace Spades)))

(define kings-full-of-jacks
  (make-hand (make-card King Spades) (make-card King Spades) (make-card King Diamonds)
             (make-card Jack Clubs) (make-card Jack Spades)))

(define king-straight
  (list (make-card 9 Spades) (make-card 10 Spades) (make-card Jack Diamonds)
        (make-card Queen Clubs) (make-card King Clubs)))

(define wheel-straight
  (list (make-card Ace Spades) (make-card 2 Spades) (make-card 3 Diamonds)
        (make-card 4 Clubs) (make-card 5 Clubs)))

(define trip-nines
  (make-hand (make-card 9 Clubs) (make-card 9 Spades) (make-card 9 Diamonds)
            (make-card 3 Clubs) (make-card 4 Clubs)))

(define queens-up
  (make-hand (make-card Queen Clubs) (make-card Queen Spades) (make-card 7 Diamonds)
             (make-card 3 Clubs) (make-card 3 Clubs)))

(define pair-kings
  (make-hand (make-card 2 Spades) (make-card King Spades) (make-card King Diamonds)
             (make-card 7 Clubs) (make-card 8 Clubs)))

(define pair-jacks
  (make-hand (make-card 4 Clubs) (make-card Jack Spades) (make-card 7 Diamonds)
             (make-card Ace Clubs) (make-card Jack Clubs)))

(define ace-higher
  (list (make-card 3 Spades) (make-card 10 Spades) (make-card Ace Diamonds)
        (make-card 7 Clubs) (make-card 8 Clubs)))

(define ace-high
  (list (make-card 2 Spades) (make-card 10 Spades) (make-card Ace Diamonds)
        (make-card 7 Clubs) (make-card 8 Clubs)))

;;; Partial hands

;;; Some hole cards:

(define aces-in-hole
  (list (make-card Ace Hearts) (make-card Ace Diamonds)))

(define queens-in-hole
  (list (make-card Queen Hearts) (make-card Queen Diamonds)))

(define big-slick
  (list (make-card Ace Clubs) (make-card King Spades)))

(define connect67
  (list (make-card 6 Clubs) (make-card 7 Clubs)))

(define connect59
  (list (make-card 5 Clubs) (make-card 9 Clubs)))

(define junk72
  (list (make-card 7 Clubs) (make-card 2 Hearts)))

;;; Some partial community cards

(define community-clubs4
  (list (make-card Queen Clubs) (make-card Jack Clubs) (make-card 10 Spades)
        (make-card 7 Clubs) (make-card 5 Clubs)))

(define three-clubs4
  (list (make-card Queen Clubs) (make-card Jack Clubs) (make-card 10 Spades)
        (make-card 7 Clubs)))

(define straight-draw4
  (list (make-card 4 Clubs) (make-card 8 Clubs) (make-card 9 Spades)
        (make-card Jack Hearts)))

(define straight-draw3
  (list (make-card 4 Clubs) (make-card 8 Clubs) (make-card 9 Spades)))