Last active
February 28, 2024 12:32
-
-
Save gdejohn/8219e043c5f0070b502b to your computer and use it in GitHub Desktop.
Calculate exact equity for Texas hold 'em by exhaustive enumeration.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Poker (Rank(..), Suit(..), Card, rank, suit, Hand, hand, equity) where | |
import Control.Applicative ((<**>)) | |
import Data.Function (on) | |
import Data.List ((\\), foldl1', group, sortOn) | |
import Data.Ord (Down(Down)) | |
import Data.Ratio ((%)) | |
data Rank = Two | |
| Three | |
| Four | |
| Five | |
| Six | |
| Seven | |
| Eight | |
| Nine | |
| Ten | |
| Jack | |
| Queen | |
| King | |
| Ace | |
deriving (Eq, Ord, Enum, Bounded, Show, Read) | |
data Suit = Diamonds | |
| Clubs | |
| Hearts | |
| Spades | |
deriving (Eq, Enum, Bounded, Show, Read) | |
type Card = (Rank, Suit) | |
rank :: Card -> Rank | |
rank = fst | |
suit :: Card -> Suit | |
suit = snd | |
deck :: [Card] | |
deck = [Diamonds ..] <**> map (,) [Two ..] | |
data Hand = HighCard Rank Rank Rank Rank Rank | |
| OnePair Rank Rank Rank Rank | |
| TwoPair Rank Rank Rank | |
| Trips Rank Rank Rank | |
| Straight Rank | |
| Flush Rank Rank Rank Rank Rank | |
| FullHouse Rank Rank | |
| Quads Rank Rank | |
| StraightFlush Rank | |
deriving (Eq, Ord, Show) | |
hand :: [Card] -> Hand | |
hand cards = case ranks of | |
[[Ace],[Five],[_],[_],[_]] -> (if flush then StraightFlush else Straight) Five | |
[[a],[_],[_],[_],[e]] | straight a e -> (if flush then StraightFlush else Straight) a | |
[[a],[b],[c],[d],[e]] -> (if flush then Flush else HighCard) a b c d e | |
[[a,_],[c],[d],[e]] -> OnePair a c d e | |
[[a,_],[c,_],[e]] -> TwoPair a c e | |
[[a,_,_],[d],[e]] -> Trips a d e | |
[[a,_,_],[d,_]] -> FullHouse a d | |
[[a,_,_,_],[e]] -> Quads a e | |
where ranks = sortOn (Down . length) $ group $ sortOn Down $ rank <$> cards | |
flush = null $ drop 1 $ group $ suit <$> cards | |
straight high low = on (-) fromEnum high low == 4 | |
equity :: Int -> [Card] -> [Card] -> (Rational, Double) | |
equity opponents holeCards board = (q, fromRational q) where | |
q = uncurry (/) $ foldl1' (\(x, _) (y, n) -> (x + y, n)) $ flip zip [1 ..] | |
[ uncurry (on (%) toInteger) (foldr (split (board ++ board') holeCards) (1, 1) hands) | |
| ([[board'], hands], _) <- partition [(5 - length board, 1), (2, opponents)] (deck \\ (board ++ holeCards)) | |
] | |
split :: [Card] -> [Card] -> [Card] -> (Int, Int) -> (Int, Int) | |
split board player opponent ~(_, n) = | |
case on compare (maximum . map hand . choose 5 . (board ++)) player opponent of | |
LT -> (0, 1) | |
GT -> (1, n) | |
EQ -> (1, n + 1) | |
choose :: Int -> [a] -> [[a]] | |
choose 0 _ = [[]] | |
choose _ [] = [] | |
choose k (x : xs) = map (x :) (choose (k - 1) xs) ++ choose k xs | |
partition :: [(Int, Int)] -> [a] -> [([[[a]]], [a])] | |
partition (_ : _) [] = [] | |
partition [] xs = [([], xs)] | |
partition [(0, 1)] xs = [([[[]]], xs)] | |
partition [(1, 1)] (x : xs) = | |
([[[x]]], xs) : [(ysss, x : zs) | (ysss, zs) <- partition [(1, 1)] xs] | |
partition [(k, 1)] (x : xs) = | |
[([[x : ys]], zs) | ([[ys]], zs) <- partition [(k - 1, 1)] xs] ++ | |
[(ysss, x : zs) | (ysss, zs) <- partition [(k, 1)] xs] | |
partition [(k, n)] (x : xs) = | |
[ ([(x : ys) : yss], zs') | |
| ([[ys]], zs) <- partition [(k - 1, 1)] xs | |
, ([yss], zs') <- partition [(k, n - 1)] zs | |
] ++ | |
[(ysss, x : zs) | (ysss, zs) <- partition [(k, n)] xs] | |
partition (k : ks) xs = | |
[ (yss : ysss, zs') | |
| ([yss], zs) <- partition [k] xs | |
, (ysss, zs') <- partition ks zs | |
] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment