Various evaulation strategies for the Monty Hall problem with good and bad performance.

MontyHall.hs

{-# LANGUAGE BangPatterns #-}
module Main (main) where

import Control.Concurrent.Async (mapConcurrently)
import Control.Monad.Writer (Writer, runWriter, execWriter, tell)
import Control.Parallel (pseq, par)
import Data.Foldable (foldl', fold)
import Data.Monoid ((<>))
import Data.Vector (Vector)
import Data.Vector.Generic ((!))
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import System.Environment (getArgs)
import System.Random (StdGen, mkStdGen, getStdGen, randomR)


main :: IO ()
main = do

  i:r:_ <- getArgs
  let iterations = read i

  Result stay swap <- case r of
    "f" -> runFold iterations
    "s" -> pure $ runSeed iterations
    "c" -> runConcurrent iterations
    "p" -> pure $ runPar iterations
    "pv" -> pure $ runParVector iterations
    _ -> error "usage: ITERATIONS [p, f, s, c]"

  putStrLn $ "Stay: " <> percentize iterations stay
  putStrLn $ "Swap: " <> percentize iterations swap


play :: StdGen -> Result
play = execWriter . playAlgo

runFold :: Int -> IO Result
runFold iterations = do
  gen <- getStdGen
  pure . snd $ foldl' play' (gen, mempty) [1..iterations]
  where
    play' (!gen, !acc) _ = fmap (<> acc) . runWriter $ playAlgo gen

runSeed :: Int -> Result
runSeed iterations = foldl' play' mempty [1..iterations]
  where
    play' acc i = (<> acc) . play $ mkStdGen i

runConcurrent :: Int -> IO Result
runConcurrent iterations = do
  fmap fold $ mapConcurrently (pure . play . mkStdGen) [1..iterations]

runPar :: Int -> Result
runPar iterations =
  parFoldMap (play . mkStdGen) [1..iterations]

runParVector :: Int -> Result
runParVector iterations =
  vparFoldMap (play . mkStdGen) $ U.enumFromN 1 iterations

percentize :: Int -> Int -> String
percentize t x = show (fromIntegral x / (fromIntegral t) * 100) <> "%"



data Prize = Car | Goat

data Option = Door1 | Door2 | Door3 deriving (Eq, Show)

data Doors = Doors !Prize !Prize !Prize

data Result = Result !Int !Int

instance Monoid Result where
  mempty = Result 0 0
  Result x y `mappend` Result x' y' = Result (x + x') (y + y')

type PickDoor = Doors -> Prize



playAlgo :: StdGen -> Writer Result StdGen
playAlgo gen = do
  let (door, gen') = takeRand gen doors
      (pick, gen'') = takeRand gen' options
      others = filters pick options
      (reveal, gen''') = takeRand gen'' . filters pick $ monty door
      swap = G.head $ filters reveal others

  -- Try staying
  case openDoor pick door of
    Goat -> tell mempty
    Car -> tell $ Result 1 0

  -- Try swapping
  case openDoor swap door of
    Goat -> tell mempty
    Car -> tell $ Result 0 1

  pure gen'''

door1, door2, door3 :: PickDoor
door1 (Doors x _ _) = x
door2 (Doors _ x _) = x
door3 (Doors _ _ x) = x

options :: Vector Option
options= G.fromList [Door1, Door2, Door3]

openDoor :: Option -> PickDoor
openDoor x = case x of
  Door1 -> door1
  Door2 -> door2
  Door3 -> door3

doors :: Vector Doors
doors = G.fromList [Doors Car Goat Goat, Doors Goat Car Goat, Doors Goat Goat Car]

monty :: Doors -> Vector Option
monty ds = case ds of
  (Doors Goat Goat Car) -> G.fromList [Door1, Door2]
  (Doors Goat Car Goat) -> G.fromList [Door1, Door3]
  (Doors Car Goat Goat) -> G.fromList [Door2, Door3]
  _ -> error "monty: impossible: Non conforming door."

filters :: Eq x => x -> Vector x -> Vector x
filters x = G.filter (/= x)



takeRand :: G.Vector v a => StdGen -> v a -> (a, StdGen)
takeRand gen xs =
  let (i, gen') = randomR (0, G.length xs - 1) gen
  in (xs ! i, gen')

parFoldMap :: Monoid b => (a -> b) -> [a] -> b
parFoldMap _ [] = mempty
parFoldMap f [x] = f x
parFoldMap f xs = (ys `par` zs) `pseq` (ys <> zs)
  where (ys', zs') = splitAt (length xs `div` 2) xs
        ys = parFoldMap f ys'
        zs = parFoldMap f zs'

vparFoldMap :: (G.Vector v a, Monoid b) => (a -> b) -> v a -> b
vparFoldMap f xs
  | G.null xs = mempty
  | G.length xs == 1 = f $ G.head xs
  | otherwise = 
      let (ys', zs') = G.splitAt (G.length xs `div` 2) xs
          ys = vparFoldMap f ys'
          zs = vparFoldMap f zs'
      in (ys `par` zs) `pseq` (ys <> zs)