

The Problem

 100 prisoners are individually numbered 1 to 100
 A room having a cupboard of 100 opaque drawers numbered 1 to 100, that cannot be seen from outside.
 Cards numbered 1 to 100 are placed randomly, one to a drawer, and the drawers all closed; at the start.
 Prisoners start outside the room
 They can decide some strategy before any enter the room.
 Prisoners enter the room one by one, can open a drawer, inspect the card number in the drawer, then close the drawer.
 A prisoner can open no more than 50 drawers.
 A prisoner tries to find his own number.
 A prisoner finding his own number is then held apart from the others.
 If all 100 prisoners find their own numbers then they will all be pardoned. If any don't then all sentences stand. 


The task

 Simulate several thousand instances of the game where the prisoners randomly open drawers
 Simulate several thousand instances of the game where the prisoners use the optimal strategy mentioned in the Wikipedia article, of:
 First opening the drawer whose outside number is his prisoner number.
 If the card within has his number then he succeeds otherwise he opens the drawer with the same number as that of the revealed card. (until he opens his maximum).


Show and compare the computed probabilities of success for the two strategies, here, on this page.




References

 The unbelievable solution to the 100 prisoner puzzle standupmaths (Video).
 wp:100 prisoners problem
 100 Prisoners Escape Puzzle DataGenetics.
 Random permutation statistics#One hundred prisoners on Wikipedia.


import System.Random
import Control.Monad.State
 
numRuns        = 10000
numPrisoners   = 100
numDrawerTries = 50
type Drawers   = [Int]
type Prisoner  =  Int
type Prisoners = [Int]
 
main = do
  gen <- getStdGen
  putStrLn $ "Chance of winning when choosing randomly: "  ++ (show $ evalState runRandomly gen)
  putStrLn $ "Chance of winning when choosing optimally: " ++ (show $ evalState runOptimally gen)
 
 
runRandomly :: State StdGen Double
runRandomly =
  let runResults = replicateM numRuns $ do
         drawers <- state $ shuffle [1..numPrisoners]
         allM (\prisoner -> openDrawersRandomly drawers prisoner numDrawerTries) [1..numPrisoners]
   in  ((/ fromIntegral numRuns) . fromIntegral . sum . map fromEnum) `liftM` runResults
 
openDrawersRandomly :: Drawers -> Prisoner -> Int -> State StdGen Bool
openDrawersRandomly drawers prisoner triesLeft = go triesLeft []
  where go 0 _ = return False
        go triesLeft seenDrawers = do
          try <- state $ randomR (1, numPrisoners)
          case try of
            x | x == prisoner        -> return True
              | x `elem` seenDrawers -> go triesLeft seenDrawers
              | otherwise            -> go (triesLeft - 1) (x:seenDrawers)
 
runOptimally :: State StdGen Double
runOptimally =
  let runResults = replicateM numRuns $ do
         drawers <- state $ shuffle [1..numPrisoners]
         return $ all (\prisoner -> openDrawersOptimally drawers prisoner numDrawerTries) [1..numPrisoners]
   in  ((/ fromIntegral numRuns) . fromIntegral . sum . map fromEnum) `liftM` runResults
 
openDrawersOptimally :: Drawers -> Prisoner -> Int -> Bool
openDrawersOptimally drawers prisoner triesLeft = go triesLeft prisoner
  where go 0 _ = False
        go triesLeft drawerToTry =
          let thisDrawer = drawers !! (drawerToTry - 1)
           in if thisDrawer == prisoner then True else go (triesLeft - 1) thisDrawer
 
 
-- Haskel stdlib is lacking big time, so here some necessary 'library' functions
 
-- make a list of 'len' random values in range 'range' from 'gen'
randomLR :: Integral a => Random b => a -> (b, b) -> StdGen -> ([b], StdGen)
randomLR 0 range gen = ([], gen)
randomLR len range gen =
  let (x, newGen) = randomR range gen
      (xs, lastGen) = randomLR (len - 1) range newGen
  in (x : xs, lastGen)
 
 
-- shuffle a list by a generator
shuffle :: [a] -> StdGen -> ([a], StdGen)
shuffle list gen = (shuffleByNumbers numbers list, finalGen)
  where
    n = length list
    (numbers, finalGen) = randomLR n (0, n-1) gen
    shuffleByNumbers :: [Int] -> [a] -> [a]
    shuffleByNumbers [] _ = []
    shuffleByNumbers _ [] = []
    shuffleByNumbers (i:is) xs = let (start, x:rest) = splitAt (i `mod` length xs) xs
                                 in x : shuffleByNumbers is (start ++ rest)
 
-- short-circuit monadic all
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM func [] = return True
allM func (x:xs) = func x >>= \res -> if res then allM func xs else return False
 