Calculate exact equity for Texas hold 'em by exhaustive enumeration.

Poker.hs

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
    ]