;;;
;;; 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 cards
;; result: a list of 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)))