Monty Hall Problem

README.md

Required tools

This requires cabal 3.0 or newer and ghc 8.4 or newer to be installed and available to build with. Both of those can be installed via ghcup. If you don't have a preference for specific versions of those tools, ghcup's recommended versions will work fine.

Building and Running

Download this via one of the methods github provides above.

You may rename the directory/folder if you want - nothing depends on the name. Compile and run this code with

cabal run

LICENSE

Copyright (c) 2023-2024 chowells

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Main.hs

module Main where

import Control.Monad (when)
import Data.Maybe (fromMaybe)
import Debug.Trace (trace)

import Probability

-- Can we just get this in base? I rewrite it so often...
extractEach :: [a] -> [(a, [a])]
extractEach (x:xs) = (x, xs) : [ (y, x:ys) | (y, ys) <- extractEach xs ]
extractEach [] = []


data Prize = Goat | Car deriving (Show, Eq, Ord)
type Strategy = Int -> (Int, Prize) -> Int

-- Calculate the probabilities of each result based on your strategy
-- function. The strategy function takes the index of the door you
-- chose (1, 2, or 3) and the pair of Monty's door index and the prize
-- he revealed. It returns the index of the door you want to open.
simMonty :: Strategy -> Prob Prize
simMonty makeChoice = canonicalizeP $ do
    -- a prize layout is selected in advance and the doors are numbered
    prizes <- zip [1..3] <$> uniformP layouts

    -- you select a door
    ((selectedIndex, _), montyOptions) <- uniformP $ extractEach prizes

    -- Monty opens a door revealing a Goat
    montyChoice@(_, Goat) <- uniformP montyOptions

    -- You are presented with a situation in which you picked a door
    -- and Monty revealed a goat behind a different door. You may now
    -- switch to any door you like. If your door choice is out of
    -- bounds, you get a goat.
    let finalIndex = makeChoice selectedIndex montyChoice
        yourPrize = fromMaybe Goat $ lookup finalIndex prizes

    pure $! yourPrize
  where
    layouts = [ [Car, Goat, Goat], [Goat, Car, Goat], [Goat, Goat, Car] ]


-- The default strategies. Let's make them resilient to changes in the
-- simulation such that if Monty reveals a car, you just choose it.
keep, switch :: Strategy

keep _ (montyChoice, Car) = montyChoice
keep myChoice _ = myChoice

switch _ (montyChoice, Car) = montyChoice
switch myChoice (montyChoice, _) = 6 - myChoice - montyChoice


-- In case you want to see what the strategy functions are being
-- called with, here's an example that prints its arguments and result
spy :: Strategy
spy myChoice monty@_ = trace msg result
  where
    msg = "I chose " ++ show myChoice ++ " and Monty chose " ++ show monty ++
        ". I chose to take door " ++ show result ++ "."
    result = min (keep myChoice monty) (switch myChoice monty)


main :: IO ()
main = do
    putStr "When keeping original choice: "
    print $ simMonty keep
    putStr "When switching to the other:  "
    print $ simMonty switch

    -- Extra example(s) you can enable if you want:
    when runExtras $ do
        print $ simMonty spy
  where
    runExtras = False

montyhall.cabal

cabal-version:      3.0
name:               montyhall
version:            0.1.0.0
license:            MIT
license-file:       LICENSE
build-type:         Simple

executable montyhall
    -- should build on GHC 8.4 or newer
    build-depends:    base >=4.11.0.0 && < 5.0

    hs-source-dirs:   .
    main-is:          Main.hs
    other-modules:    Probability

    default-language: Haskell2010
    ghc-options:      -Wall

Probability.hs

-- | A sort of slapdash but obviously correct implementation of
-- compositional discrete probability calculations. This module is
-- broadly unconcerned with efficiency. Use a real library for large
-- probability calculations.
module Probability
  ( Prob
  , fromProb
  , uniformP
  , canonicalizeP
  ) where

import Control.Monad (ap)
import Control.Applicative (Alternative(..))
import Data.Bifunctor (bimap)
import Data.Ratio (numerator, denominator)
import GHC.Conc (pseq)

import qualified Data.List.NonEmpty as NE


-- | Represents a rational-weighted set of discrete outcomes that can
-- arise from a probabilistic process. The set of outcomes may be
-- empty, representing an impossible situation.
--
-- This module exports only tools that enforce that the sum of the
-- weights is 0 (if there are no possible outcomes) or 1.
newtype Prob a = Prob { fromProb :: [(Rational, a)] }

instance Show a => Show (Prob a) where
    show (Prob []) = "Contradiction"
    show (Prob (x:xs)) = (++) "Distribution [" . pair x . remaining xs $ "]"
      where
        pair (w, o) = (:) '(' . shows o . (++) ": " . weight w . (:) ')'
        weight w = shows (numerator w) . (:) '/' . shows (denominator w)
        remaining = foldr (\p r -> (:) ',' . pair p . r) id

instance Functor Prob where
    fmap f (Prob xs) = Prob $ map (fmap f) xs

instance Applicative Prob where
    pure x = Prob [(1, x)]
    (<*>) = ap

-- | Models non-deterministic exploration of a weighted decision tree.
instance Monad Prob where
    Prob xs >>= f = Prob $ norm outcomes
      where
        outcomes = [ (wx * wy, y) | (wx, x) <- xs, (wy, y) <- fromProb $ f x ]

instance MonadFail Prob where
    fail _ = empty

-- | This instance provides catch-like semantics. (<|>) is
-- left-biased, returning the left argument unless it's the empty
-- outcome set. In that case, the right argument is returned.
instance Alternative Prob where
    empty = Prob []
    Prob [] <|> p = p
    p <|> _ = p


-- | Uniform probability of each element from a list
--
-- Produces a contradiction if the input was empty
uniformP :: [a] -> Prob a
uniformP xs = Prob $ norm [ (1, x) | x <- xs ]


-- Normalize weights.
--
-- Precondition: All input weights are positive.
-- Postconditions:
--
--   the output list contains the same sequence of `a' values as the
--   input
--
--   the output list weights sum to 1 if the output is non-empty
--
-- Space invariants:
--
--   only evaluating an `a' value in the output list causes evaluation
--   of the corresponding value in the input list
--
--   evaluating the outermost output list constructor causes
--   evaluation of the spine of the input list, all weights in the
--   input list, the spine of the output list, and the weights in the
--   output list
norm :: [(Rational, a)] -> [(Rational, a)]
norm = snd . go 0
  where
    go acc [] = (acc, [])
    go acc ((weight, x) : xs) = w `seq` (total, (w, x) : updated)
      where
        (total, updated) = a `pseq` go a xs
        w = weight / total
        a = acc + weight


-- | Sort the internal storage and coalesce multiple entries for equal
-- outcomes
canonicalizeP :: Ord a => Prob a -> Prob a
canonicalizeP xs = Prob $ map (bimap sum NE.head . NE.unzip) grouped
  where
    grouped = NE.groupAllWith snd $ fromProb xs