-- |
-- Module      : Poker.Holdem.Simulate
-- Description : Monte Carlo simulation of a poker holdem game.
-- Copyright   : (c) Ghais Issa, 2021
--
-- Uses Monte Carlo Methods to determine the probability for each player in a game winning.
-- The simulation randomize each of the unknown cards in the game, this could include any
-- number of players' cards as well as flop, turn and river.
module Poker.Holdem.Simulate
  (
    Player(..)
  , Game(..)
  , simulate
  ) where

import           Data.Random (RVar, RandomSource, runRVar)

import           Control.Monad.State
import           Data.List (transpose)

import           Data.Random.Source.DevRandom (DevRandom (DevRandom))
import           Poker.Deck
import qualified Poker.Deck as Deck (shuffle)
import           Poker.Holdem
import           Poker.Holdem.Evaluate (HandRank, evaluate)

-- | A player can have 0, 1, 2 known cards.
data Player = Player
  {
    Player -> Maybe Card
card1 :: Maybe Card
  , Player -> Maybe Card
card2 :: Maybe Card
  }

-- | An abstraction that represents a poker game, with some unknowns.
--This allows us to simulate a game from any possible state.
data Game = Game
  {
    Game -> [Player]
players :: [Player]      -- ^ Players.
  , Game -> Maybe Flop
flop    :: Maybe Flop    -- ^ The flop if known. Nothing otherwise.
  , Game -> Maybe Turn
turn    :: Maybe Turn    -- ^ The turn if known. Nothing otherwise.
  , Game -> Maybe Street
street  :: Maybe Street  -- ^ The street if known. Nothing otherwise.
  }

-- | Run a Monte Carlo simulation of a game returning the probability of winning for each player.
simulate :: (RandomSource m DevRandom) =>
     Int        -- ^ Number of trajectories.
  -> Game         -- ^ State of the game before simulation.
  -> m [Double] -- ^ Probability for each player winning the game.
simulate :: Int -> Game -> m [Double]
simulate Int
n Game
game = do
  [[Double]]
gameHands <- Int -> m [Double] -> m [[Double]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (m [Double] -> m [[Double]]) -> m [Double] -> m [[Double]]
forall a b. (a -> b) -> a -> b
$ Game -> m [Double]
forall (m :: * -> *).
RandomSource m DevRandom =>
Game -> m [Double]
simulateWinners Game
game
  [Double] -> m [Double]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Double] -> m [Double]) -> [Double] -> m [Double]
forall a b. (a -> b) -> a -> b
$ ([Double] -> Double) -> [[Double]] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Double -> Double) -> ([Double] -> Double) -> [Double] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum) ([[Double]] -> [[Double]]
forall a. [[a]] -> [[a]]
transpose [[Double]]
gameHands)

dealtCards :: Game -> [Card]
dealtCards :: Game -> [Card]
dealtCards Game{[Player]
Maybe Street
Maybe Turn
Maybe Flop
street :: Maybe Street
turn :: Maybe Turn
flop :: Maybe Flop
players :: [Player]
street :: Game -> Maybe Street
turn :: Game -> Maybe Turn
flop :: Game -> Maybe Flop
players :: Game -> [Player]
..} = let playerCards :: [Card]
playerCards = (Player -> [Card]) -> [Player] -> [Card]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Player -> [Card]
dealtHands [Player]
players
                          dealtHands :: Player -> [Card]
dealtHands (Player Maybe Card
Nothing Maybe Card
Nothing)     = []
                          dealtHands (Player (Just Card
c1) Maybe Card
Nothing)   = [Card
c1]
                          dealtHands (Player Maybe Card
Nothing (Just Card
c2))   = [Card
c2]
                          dealtHands (Player (Just Card
c1) (Just Card
c2)) = [Card
c1, Card
c2]
                          flopCards :: [Card]
flopCards = case Maybe Flop
flop of
                            (Just (Flop Card
c1 Card
c2 Card
c3)) -> [Card
c1, Card
c2, Card
c3]
                            Maybe Flop
_                      -> []
                          turnCard :: [Card]
turnCard = case Maybe Turn
turn of
                            (Just (Turn Card
c)) -> [Card
c]
                            Maybe Turn
_               -> []
                          streetCard :: [Card]
streetCard = case Maybe Street
street of
                            (Just (Street Card
c)) -> [Card
c]
                            Maybe Street
_                 -> []
                      in [Card]
playerCards [Card] -> [Card] -> [Card]
forall a. [a] -> [a] -> [a]
++  [Card]
flopCards [Card] -> [Card] -> [Card]
forall a. [a] -> [a] -> [a]
++ [Card]
turnCard [Card] -> [Card] -> [Card]
forall a. [a] -> [a] -> [a]
++ [Card]
streetCard

completeHands :: Game -> StateT Deck Maybe [[Card]]
completeHands :: Game -> StateT Deck Maybe [[Card]]
completeHands Game{[Player]
Maybe Street
Maybe Turn
Maybe Flop
street :: Maybe Street
turn :: Maybe Turn
flop :: Maybe Flop
players :: [Player]
street :: Game -> Maybe Street
turn :: Game -> Maybe Turn
flop :: Game -> Maybe Flop
players :: Game -> [Player]
..} = do
  [Hole]
playersCards <- (Player -> StateT Deck Maybe Hole)
-> [Player] -> StateT Deck Maybe [Hole]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Player -> StateT Deck Maybe Hole
getPlayersCards [Player]
players
  (Community (Flop Card
c3 Card
c4 Card
c5) (Turn Card
c6) (Street Card
c7)) <- Maybe Flop
-> Maybe Turn -> Maybe Street -> StateT Deck Maybe Community
getCommunityCards Maybe Flop
flop Maybe Turn
turn Maybe Street
street
  [[Card]] -> StateT Deck Maybe [[Card]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Card
c1, Card
c2, Card
c3, Card
c4, Card
c5, Card
c6, Card
c7] | (Hole Card
c1 Card
c2) <- [Hole]
playersCards]

getPlayersCards :: Player -> StateT Deck Maybe Hole
getPlayersCards :: Player -> StateT Deck Maybe Hole
getPlayersCards Player
player = do
  Deck
deck <- StateT Deck Maybe Deck
forall s (m :: * -> *). MonadState s m => m s
get
  ([Card]
cards, Deck
deck') <- Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck))
-> Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall a b. (a -> b) -> a -> b
$ Int -> Deck -> Maybe ([Card], Deck)
draw1 (Player -> Int
forall p. Num p => Player -> p
neededCards Player
player) Deck
deck
  Deck -> StateT Deck Maybe ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Deck
deck'
  Hole -> StateT Deck Maybe Hole
forall (m :: * -> *) a. Monad m => a -> m a
return (Player -> [Card] -> Hole
hole Player
player [Card]
cards)
  where neededCards :: Player -> p
neededCards (Player Maybe Card
Nothing Maybe Card
Nothing)   = p
2
        neededCards (Player (Just Card
_) Maybe Card
Nothing)  = p
1
        neededCards (Player Maybe Card
Nothing (Just Card
_))  = p
1
        neededCards (Player (Just Card
_) (Just Card
_)) = p
0
        hole :: Player -> [Card] -> Hole
hole (Player (Just Card
c1) (Just Card
c2)) []   = Card -> Card -> Hole
Hole  Card
c1 Card
c2
        hole (Player (Just Card
c1) Maybe Card
Nothing) [Card
c2]   = Card -> Card -> Hole
Hole Card
c1 Card
c2
        hole (Player Maybe Card
Nothing (Just Card
c2)) [Card
c1]   = Card -> Card -> Hole
Hole Card
c1 Card
c2
        hole (Player Maybe Card
Nothing Maybe Card
Nothing) [Card
c1, Card
c2] = Card -> Card -> Hole
Hole Card
c1 Card
c2
        hole Player
_ [Card]
_                               = Hole
forall a. HasCallStack => a
undefined


getCommunityCards :: Maybe Flop -> Maybe Turn -> Maybe Street -> StateT Deck Maybe Community
getCommunityCards :: Maybe Flop
-> Maybe Turn -> Maybe Street -> StateT Deck Maybe Community
getCommunityCards Maybe Flop
Nothing Maybe Turn
_ Maybe Street
_ = do
  Deck
deck <- StateT Deck Maybe Deck
forall s (m :: * -> *). MonadState s m => m s
get
  ([Card
c1, Card
c2, Card
c3, Card
c4, Card
c5], Deck
deck') <- Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck))
-> Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall a b. (a -> b) -> a -> b
$ Int -> Deck -> Maybe ([Card], Deck)
draw1 Int
5 Deck
deck
  Deck -> StateT Deck Maybe ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Deck
deck'
  Community -> StateT Deck Maybe Community
forall (m :: * -> *) a. Monad m => a -> m a
return (Flop -> Turn -> Street -> Community
Community (Card -> Card -> Card -> Flop
Flop Card
c1 Card
c2 Card
c3) (Card -> Turn
Turn Card
c4) (Card -> Street
Street Card
c5))

getCommunityCards (Just (Flop Card
c1 Card
c2 Card
c3)) Maybe Turn
Nothing Maybe Street
_ = do
  Deck
deck <- StateT Deck Maybe Deck
forall s (m :: * -> *). MonadState s m => m s
get
  ([Card
c4, Card
c5], Deck
deck') <- Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck))
-> Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall a b. (a -> b) -> a -> b
$ Int -> Deck -> Maybe ([Card], Deck)
draw1 Int
2 Deck
deck
  Deck -> StateT Deck Maybe ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Deck
deck'
  Community -> StateT Deck Maybe Community
forall (m :: * -> *) a. Monad m => a -> m a
return (Flop -> Turn -> Street -> Community
Community (Card -> Card -> Card -> Flop
Flop Card
c1 Card
c2 Card
c3) (Card -> Turn
Turn Card
c4) (Card -> Street
Street Card
c5))

getCommunityCards (Just (Flop Card
c1 Card
c2 Card
c3)) (Just(Turn Card
c4)) Maybe Street
Nothing = do
  Deck
deck <- StateT Deck Maybe Deck
forall s (m :: * -> *). MonadState s m => m s
get
  ([Card
c5], Deck
deck') <- Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck))
-> Maybe ([Card], Deck) -> StateT Deck Maybe ([Card], Deck)
forall a b. (a -> b) -> a -> b
$ Int -> Deck -> Maybe ([Card], Deck)
draw1 Int
1 Deck
deck
  Deck -> StateT Deck Maybe ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Deck
deck'
  Community -> StateT Deck Maybe Community
forall (m :: * -> *) a. Monad m => a -> m a
return (Flop -> Turn -> Street -> Community
Community (Card -> Card -> Card -> Flop
Flop Card
c1 Card
c2 Card
c3) (Card -> Turn
Turn Card
c4) (Card -> Street
Street Card
c5))
getCommunityCards (Just (Flop Card
c1 Card
c2 Card
c3)) (Just(Turn Card
c4)) (Just (Street Card
c5)) = do
  Community -> StateT Deck Maybe Community
forall (m :: * -> *) a. Monad m => a -> m a
return (Flop -> Turn -> Street -> Community
Community (Card -> Card -> Card -> Flop
Flop Card
c1 Card
c2 Card
c3) (Card -> Turn
Turn Card
c4) (Card -> Street
Street Card
c5))



playerHands :: Game -> RVar [[Card]]
playerHands :: Game -> RVar [[Card]]
playerHands Game
game = do
  Deck
deck <- Deck -> RVar Deck
Deck.shuffle (Game -> Deck
gameDeck Game
game)
  case StateT Deck Maybe [[Card]] -> Deck -> Maybe [[Card]]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Game -> StateT Deck Maybe [[Card]]
completeHands Game
game) Deck
deck of
    (Just [[Card]]
cards) -> [[Card]] -> RVar [[Card]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Card]]
cards
    Maybe [[Card]]
_            -> [[Card]] -> RVar [[Card]]
forall (m :: * -> *) a. Monad m => a -> m a
return []

gameDeck :: Game -> Deck
gameDeck :: Game -> Deck
gameDeck Game
game = [Card] -> Deck -> Deck
remove (Game -> [Card]
dealtCards Game
game) Deck
stdDeck



winners :: [HandRank] -> [Bool]
winners :: [HandRank] -> [Bool]
winners [HandRank]
scores = (HandRank -> Bool) -> [HandRank] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (HandRank -> HandRank -> Bool
forall a. Eq a => a -> a -> Bool
== HandRank
minRank) [HandRank]
scores where
  minRank :: HandRank
minRank = [HandRank] -> HandRank
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [HandRank]
scores

averageScore :: [Bool] -> [Double]
averageScore :: [Bool] -> [Double]
averageScore [Bool]
winnerList = (Bool -> Double) -> [Bool] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> if Bool
x then Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numWinners else Double
0) [Bool]
winnerList where
  numWinners :: Int
numWinners = [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True) [Bool]
winnerList)


simulateOne :: (RandomSource m DevRandom) => Game -> m [([Card], HandRank)]
simulateOne :: Game -> m [([Card], HandRank)]
simulateOne Game
game = do
  [[Card]]
cards <- RVar [[Card]] -> DevRandom -> m [[Card]]
forall (m :: * -> *) s a. RandomSource m s => RVar a -> s -> m a
runRVar (Game -> RVar [[Card]]
playerHands Game
game) DevRandom
DevRandom
  let scores :: [HandRank]
scores = ([Card] -> HandRank) -> [[Card]] -> [HandRank]
forall a b. (a -> b) -> [a] -> [b]
map [Card] -> HandRank
evaluate' [[Card]]
cards
  [([Card], HandRank)] -> m [([Card], HandRank)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Card], HandRank)] -> m [([Card], HandRank)])
-> [([Card], HandRank)] -> m [([Card], HandRank)]
forall a b. (a -> b) -> a -> b
$ [[Card]] -> [HandRank] -> [([Card], HandRank)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Card]]
cards [HandRank]
scores
  where evaluate' :: [Card] -> HandRank
evaluate' [Card
c1, Card
c2, Card
c3, Card
c4, Card
c5, Card
c6, 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' [Card]
_                            = HandRank
forall a. HasCallStack => a
undefined

simulateWinners :: (RandomSource m DevRandom) => Game -> m [Double]
simulateWinners :: Game -> m [Double]
simulateWinners Game
game = do
  [HandRank]
scores <- (([Card], HandRank) -> HandRank)
-> [([Card], HandRank)] -> [HandRank]
forall a b. (a -> b) -> [a] -> [b]
map ([Card], HandRank) -> HandRank
forall a b. (a, b) -> b
snd ([([Card], HandRank)] -> [HandRank])
-> m [([Card], HandRank)] -> m [HandRank]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Game -> m [([Card], HandRank)]
forall (m :: * -> *).
RandomSource m DevRandom =>
Game -> m [([Card], HandRank)]
simulateOne Game
game
  let gameWinners :: [Bool]
gameWinners = [HandRank] -> [Bool]
winners [HandRank]
scores
  [Double] -> m [Double]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Double] -> m [Double]) -> [Double] -> m [Double]
forall a b. (a -> b) -> a -> b
$ [Bool] -> [Double]
averageScore [Bool]
gameWinners