-- |
-- Module      : Poker.Holdem.Evaluate
-- Description : Texas Hold'em poker hand evaluator.
-- Copyright   : (c) Ghais Issa, 2021
--
-- A Poker Hand Evaluator based on a perfect hash algorithm based
-- on the work of Henry Lee. The original CPP implementation can be
-- found here: [PokerHandEvaluator](https://github.com/HenryRLee/PokerHandEvaluator)
{-# LANGUAGE DerivingVia #-}
module Poker.Holdem.Evaluate
  (
    HandRank(..)
  , evaluate
  , evaluateHand
  )
where

import           Data.Array.Base (unsafeAccumArray, unsafeAt)
import qualified Data.Array.Unboxed as Array
import           Data.Bits (shift, (.&.), (.|.))
import           Data.Ord
import           Poker.Deck
import           Poker.Holdem
import qualified Poker.Holdem.Table.DP as Holdem
import qualified Poker.Holdem.Table.Flush as Holdem
import qualified Poker.Holdem.Table.NoFlush as Holdem
import qualified Poker.Holdem.Table.Suit as Holdem


-- | Rank of a hand.
--
-- if @(evaluate hand1) > (evaluate hand2)@ then hand1 is better than hand2
newtype HandRank = HandRank Int deriving newtype (HandRank -> HandRank -> Bool
(HandRank -> HandRank -> Bool)
-> (HandRank -> HandRank -> Bool) -> Eq HandRank
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HandRank -> HandRank -> Bool
$c/= :: HandRank -> HandRank -> Bool
== :: HandRank -> HandRank -> Bool
$c== :: HandRank -> HandRank -> Bool
Eq, Int -> HandRank -> ShowS
[HandRank] -> ShowS
HandRank -> String
(Int -> HandRank -> ShowS)
-> (HandRank -> String) -> ([HandRank] -> ShowS) -> Show HandRank
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HandRank] -> ShowS
$cshowList :: [HandRank] -> ShowS
show :: HandRank -> String
$cshow :: HandRank -> String
showsPrec :: Int -> HandRank -> ShowS
$cshowsPrec :: Int -> HandRank -> ShowS
Show, ReadPrec [HandRank]
ReadPrec HandRank
Int -> ReadS HandRank
ReadS [HandRank]
(Int -> ReadS HandRank)
-> ReadS [HandRank]
-> ReadPrec HandRank
-> ReadPrec [HandRank]
-> Read HandRank
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HandRank]
$creadListPrec :: ReadPrec [HandRank]
readPrec :: ReadPrec HandRank
$creadPrec :: ReadPrec HandRank
readList :: ReadS [HandRank]
$creadList :: ReadS [HandRank]
readsPrec :: Int -> ReadS HandRank
$creadsPrec :: Int -> ReadS HandRank
Read)
                                deriving newtype (Integer -> HandRank
HandRank -> HandRank
HandRank -> HandRank -> HandRank
(HandRank -> HandRank -> HandRank)
-> (HandRank -> HandRank -> HandRank)
-> (HandRank -> HandRank -> HandRank)
-> (HandRank -> HandRank)
-> (HandRank -> HandRank)
-> (HandRank -> HandRank)
-> (Integer -> HandRank)
-> Num HandRank
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> HandRank
$cfromInteger :: Integer -> HandRank
signum :: HandRank -> HandRank
$csignum :: HandRank -> HandRank
abs :: HandRank -> HandRank
$cabs :: HandRank -> HandRank
negate :: HandRank -> HandRank
$cnegate :: HandRank -> HandRank
* :: HandRank -> HandRank -> HandRank
$c* :: HandRank -> HandRank -> HandRank
- :: HandRank -> HandRank -> HandRank
$c- :: HandRank -> HandRank -> HandRank
+ :: HandRank -> HandRank -> HandRank
$c+ :: HandRank -> HandRank -> HandRank
Num)
                                deriving Eq HandRank
Eq HandRank
-> (HandRank -> HandRank -> Ordering)
-> (HandRank -> HandRank -> Bool)
-> (HandRank -> HandRank -> Bool)
-> (HandRank -> HandRank -> Bool)
-> (HandRank -> HandRank -> Bool)
-> (HandRank -> HandRank -> HandRank)
-> (HandRank -> HandRank -> HandRank)
-> Ord HandRank
HandRank -> HandRank -> Bool
HandRank -> HandRank -> Ordering
HandRank -> HandRank -> HandRank
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HandRank -> HandRank -> HandRank
$cmin :: HandRank -> HandRank -> HandRank
max :: HandRank -> HandRank -> HandRank
$cmax :: HandRank -> HandRank -> HandRank
>= :: HandRank -> HandRank -> Bool
$c>= :: HandRank -> HandRank -> Bool
> :: HandRank -> HandRank -> Bool
$c> :: HandRank -> HandRank -> Bool
<= :: HandRank -> HandRank -> Bool
$c<= :: HandRank -> HandRank -> Bool
< :: HandRank -> HandRank -> Bool
$c< :: HandRank -> HandRank -> Bool
compare :: HandRank -> HandRank -> Ordering
$ccompare :: HandRank -> HandRank -> Ordering
$cp1Ord :: Eq HandRank
Ord via (Down Int)

-- | Evaluate a 7-card Texas Hold'em hand returning the rank of the hand.
evaluateHand :: Hand -> HandRank
evaluateHand :: Hand -> HandRank
evaluateHand (Hand (Hole Card
c1 Card
c2) (Community (Flop Card
c3 Card
c4 Card
c5) (Turn Card
c6) (Street Card
c7))) =
  Card -> Card -> Card -> Card -> Card -> Card -> Card -> HandRank
evaluate Card
c1 Card
c2 Card
c3 Card
c4 Card
c5 Card
c6 Card
c7

-- | Evaluate a 7-card hand and return the rank of that hand.
evaluate ::
     Card  -- ^ c1
  -> Card  -- ^ c2
  -> Card  -- ^ c3
  -> Card  -- ^ c4
  -> Card  -- ^ c5
  -> Card  -- ^ c6
  -> Card  -- ^ c7
  -> HandRank -- ^ The rank of the hand.
evaluate :: Card -> Card -> Card -> Card -> Card -> Card -> Card -> HandRank
evaluate (Card Int
c1) (Card Int
c2) (Card Int
c3) (Card Int
c4) (Card Int
c5) (Card Int
c6) (Card Int
c7) =
  if Int -> Int
Holdem.suitsLookup Int
hash Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
    Int -> HandRank
HandRank (Int -> HandRank) -> Int -> HandRank
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
handleFlush Int
c1 Int
c2 Int
c3 Int
c4 Int
c5 Int
c6 Int
c7 Int
hash
  else
    Int -> HandRank
HandRank (Int -> HandRank) -> Int -> HandRank
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
handleNonFlush Int
c1 Int
c2 Int
c3 Int
c4 Int
c5 Int
c6 Int
c7
  where
    hash :: Int
hash = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
suitHash Int
c1 Int
c2 Int
c3 Int
c4 Int
c5 Int
c6 Int
c7

suitHash :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
suitHash :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
suitHash Int
c1 Int
c2 Int
c3 Int
c4 Int
c5 Int
c6 Int
c7 =
  let b1 :: Int
b1 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c1
      b2 :: Int
b2 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c2
      b3 :: Int
b3 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c3
      b4 :: Int
b4 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c4
      b5 :: Int
b5 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c5
      b6 :: Int
b6 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c6
      b7 :: Int
b7 = UArray Int Int
suitBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c7
  in Int
b1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b6 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b7


hashQuinary :: Array.UArray Int Int -> Int
hashQuinary :: UArray Int Int -> Int
hashQuinary UArray Int Int
q = Int -> Int -> Int -> Int
go Int
7 Int
0 Int
0
  where
    go :: Int -> Int -> Int -> Int
go Int
k Int
i Int
s
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
13 = Int
s
      | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Int
s
      | Bool
otherwise =
        let sum' :: Int
sum' = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ UArray Int Int -> Int -> Int -> Int
Holdem.dpLookup UArray Int Int
q Int
i Int
k
            k' :: Int
k' = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- (UArray Int Int
q UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
i)
            i' :: Int
i' = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
         in Int -> Int -> Int -> Int
go Int
k' Int
i' Int
sum'

handleFlush :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
handleFlush :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
handleFlush Int
c1 Int
c2 Int
c3 Int
c4 Int
c5 Int
c6 Int
c7 Int
hash =
  let
    suitBinary :: Array.UArray Int Int
    suitBinary :: UArray Int Int
suitBinary = (Int -> Int -> Int)
-> Int -> (Int, Int) -> [(Int, Int)] -> UArray Int Int
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(Int, e')] -> a i e
unsafeAccumArray Int -> Int -> Int
forall a. Bits a => a -> a -> a
(.|.) Int
0 (Int
0, Int
3) [
        (Int
c1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c1),
        (Int
c2 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c2),
        (Int
c3 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c3),
        (Int
c4 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c4),
        (Int
c5 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c5),
        (Int
c6 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c6),
        (Int
c7 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x3, UArray Int Int
rankBit UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` Int
c7)]
    idx :: Int
idx = UArray Int Int
suitBinary UArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Int -> e
`unsafeAt` (Int -> Int
Holdem.suitsLookup Int
hash Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  in Int -> Int
Holdem.flushLookup Int
idx



handleNonFlush :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
handleNonFlush :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
handleNonFlush Int
c1 Int
c2 Int
c3 Int
c4 Int
c5 Int
c6 Int
c7 =
  let
    idxs :: [(Int, Int)]
    idxs :: [(Int, Int)]
idxs = [ (Int
c1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1),
             (Int
c2 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1),
             (Int
c3 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1),
             (Int
c4 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1),
             (Int
c5 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1),
             (Int
c6 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1),
             (Int
c7 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shift` (-Int
2), Int
1)
           ]
    quinary :: Array.UArray Int Int
    quinary :: UArray Int Int
quinary = (Int -> Int -> Int)
-> Int -> (Int, Int) -> [(Int, Int)] -> UArray Int Int
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(Int, e')] -> a i e
unsafeAccumArray Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 (Int
0, Int
12) [(Int, Int)]
idxs
    hash :: Int
hash =  UArray Int Int -> Int
hashQuinary UArray Int Int
quinary
  in Int -> Int
Holdem.noFlushLookup Int
hash

rankBit :: Array.UArray Int Int
rankBit :: UArray Int Int
rankBit = (Int, Int) -> [Int] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0, Int
51)
    [ Int
0x1,      Int
0x1,      Int
0x1,      Int
0x1,
      Int
0x2,      Int
0x2,      Int
0x2,      Int
0x2,
      Int
0x4,      Int
0x4,      Int
0x4,      Int
0x4,
      Int
0x8,      Int
0x8,      Int
0x8,      Int
0x8,
      Int
0x10,     Int
0x10,     Int
0x10,     Int
0x10,
      Int
0x20,     Int
0x20,     Int
0x20,     Int
0x20,
      Int
0x40,     Int
0x40,     Int
0x40,     Int
0x40,
      Int
0x80,     Int
0x80,     Int
0x80,     Int
0x80,
      Int
0x100,    Int
0x100,    Int
0x100,    Int
0x100,
      Int
0x200,    Int
0x200,    Int
0x200,    Int
0x200,
      Int
0x400,    Int
0x400,    Int
0x400,    Int
0x400,
      Int
0x800,    Int
0x800,    Int
0x800,    Int
0x800,
      Int
0x1000,   Int
0x1000,   Int
0x1000,    Int
0x1000
    ]

suitBit :: Array.UArray Int Int
suitBit :: UArray Int Int
suitBit =
  (Int, Int) -> [Int] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Array.listArray (Int
0,Int
51)
    [ Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200,
      Int
0x1,      Int
0x8,      Int
0x40,      Int
0x200
    ]