Blackjack simple simulation

blackjack.hs

{-# Language GeneralizedNewtypeDeriving #-}
import Data.Maybe                  (fromJust)
import System.Random               (randomIO)
import Control.Applicative
import Control.Monad.State.Strict

newtype GameAction s a = GameAction { getAction :: StateT s Maybe a }
    deriving (Monad, Applicative, Functor, MonadState s, Alternative)

condition :: (s -> Bool) -> GameAction s ()
condition f = do
  b <- f <$> get
  if b then return () else bail

bail :: GameAction s a
bail = GameAction $ lift Nothing

choice :: (Alternative m) => [m a] -> m a
choice = foldl1 (<|>)

data Turn = Dealer | Player | Final
          deriving (Show, Eq)

data BJState = BJState { dealer :: [Int]
                       , player :: [Int]
                       , turn :: Turn
                       , cards :: [Int] }
             deriving Show

playerStand :: GameAction BJState ()
playerStand = modify $ \s -> s { turn = Dealer }

playerDraw :: GameAction BJState ()
playerDraw = modify $ \s -> s { player = head (cards s) : player s
                              , cards = tail (cards s) }

dealerStand :: GameAction BJState ()
dealerStand = modify $ \s -> s { turn = Final }

dealerDraw :: GameAction BJState ()
dealerDraw = modify $ \s -> s { dealer = head (cards s) : dealer s
                              , cards = tail (cards s) }

-- | Dealer's strategies
dealerStrat :: GameAction BJState ()
dealerStrat = choice [ holdOnSoft17, dealerDraw ]

holdOnSoft17 :: GameAction BJState ()
holdOnSoft17 = condition ((>=17) . softSum . dealer) >> dealerStand

-- | Player's strategies
playerStrat :: GameAction BJState ()
playerStrat = choice [ playerHard >>
                       choice [ inInterval player (2, 11) >> playerDraw
                              , choice [ inInterval dealer (2, 6) >> playerStand
                                       , inInterval player (12, 16) >> playerDraw
                                       , playerStand ] ]
                     , inInterval player (2, 18) >> playerDraw
                     , playerStand ]

playerMimicDealer :: GameAction BJState ()
playerMimicDealer = choice [ condition (\s -> softSum (player s) >= 17) >> playerStand
                           , playerDraw ]

playerHard :: GameAction BJState ()
playerHard = ensureHard player

inInterval :: (BJState -> [Int]) -> (Int, Int) -> GameAction BJState ()
inInterval character (a, b) = condition (\s -> cardSum s <= b && cardSum s >= a)
    where cardSum = softSum . character

-- | Auxiliary functions
ensureHard :: (BJState -> [Int]) -> GameAction BJState ()
ensureHard role = condition (isHard . role)

isSoft :: [Int] -> Bool
isSoft cs = any (==1) cs && sum (aceAs11 cs) <= 21

isHard :: [Int] -> Bool
isHard = not . isSoft

aceAs11 :: [Int] -> [Int]
aceAs11 [] = []
aceAs11(1:xs) = 11 : xs
aceAs11 (x:xs) = x : aceAs11 xs

softSum :: [Int] -> Int
softSum xs | isSoft xs = sum (aceAs11 xs)
           | otherwise = sum xs

-- | Simulations
execStrat :: GameAction BJState () -> BJState -> BJState
execStrat strat = fromJust . execStateT (getAction strat)

nextPlay :: BJState -> BJState
nextPlay s@(BJState _ _ Dealer _) = execStrat dealerStrat s
nextPlay s@(BJState _ _ Player _) = execStrat playerStrat s
nextPlay s@(BJState _ _ Final _) = s

gameRun :: BJState -> IO BJState
gameRun s | turn s == Final = return s
          | otherwise       = gameRun (nextPlay s)

winner :: BJState -> Int
winner (BJState d p _ _) | softSum p > 21        = -1
                         | softSum d > 21        =  1
                         | softSum d < softSum p =  1
                         | softSum d > softSum p = -1
                         | otherwise             = 0

getCardIO :: IO Int
getCardIO = do
  x <-  ((+ 1) . (`mod` 13)) <$> randomIO
  return $ if x >= 10 then 10 else x

simulate :: IO BJState
simulate = do
  d <- forM [1..2] (const getCardIO)
  p <- forM [1..2] (const getCardIO)
  cs <- forM [1..50] (const getCardIO)
  let st = BJState d p Player cs
  gameRun st

report :: Float -> Float -> IO ()
report n acc = do
  putStr (show (acc / n))
  putStr " "
  putStr (show n)
  putStr " "
  ss <- forM [1..10000] (const simulate)
  let r = fromIntegral $ sum $ map winner ss
  putStrLn (show r)
  report (n + 1) (acc + r)

main = report 0.0000001 0.0