A solution to the 3 gods puzzle

3gods.hs

#!/usr/bin/env stack
{-
  stack
  --resolver lts-10.1
  --install-ghc
  --package random-extras
  --package random-fu
  script
-}

{-# LANGUAGE OverloadedStrings #-}

import System.Random
import Control.Monad
import Data.Random.Extras
import Data.Random.RVar
import Data.Random.Source.DevRandom

data GodType = T | F | R deriving (Eq, Show)
type GodID = Int
type Permutation = [GodType]
data PrimQ =
  PrimQ GodID GodID GodType -- (X, Y, Z): ask god X "Is god Y of type Z?"
  deriving (Eq, Show)
data Eng = Yes | No deriving (Eq, Show)
data Urk = Da | Ja deriving (Eq, Show)
data LangMap = DaMeansYes | DaMeansNo deriving (Eq, Show)
type Question = ([GodType], GodType, LangMap) -> Eng
data Strategy =
  SDone Permutation
  | SQuestion
    GodID -- who to ask
    Question
    Strategy -- when the repsonse is "da"
    Strategy -- when the repsonse is "ja"

boolToEng :: Bool -> Eng
boolToEng True = Yes
boolToEng False = No

solution :: Strategy
solution =
  let
    q about theType (types, ty, langMap) =
      boolToEng
      $ (case ty of
        T -> id
        F -> not
        R -> id)
      $ (if langMap == DaMeansYes then id else not)
      $ (types !! about) == theType
  in
    SQuestion 0 (q 1 R)
      (SQuestion 2 (q 0 R)
        (SQuestion 2 (q 2 T)
          (SDone [R, F, T])
          (SDone [R, T, F]))
        (SQuestion 2 (q 2 T)
          (SDone [F, R, T])
          (SDone [T, R, F])))
      (SQuestion 1 (q 0 R)
        (SQuestion 1 (q 1 T)
          (SDone [R, T, F])
          (SDone [R, F, T]))
        (SQuestion 1 (q 1 T)
          (SDone [F, T, R])
          (SDone [T, F, R])))

sampleRun :: Strategy -> IO ()
sampleRun s = do
  perm <- runRVar (shuffle [T, F, R]) DevRandom
  langMap <- fmap ([DaMeansYes, DaMeansNo] !!) $ randomRIO (0, 1)

  let
    flipEng Yes = No
    flipEng No = Yes

    engToUrk DaMeansYes Yes = Da
    engToUrk DaMeansYes No = Ja
    engToUrk DaMeansNo Yes = Ja
    engToUrk DaMeansNo No = Da

    answerAs T eng = return $ engToUrk langMap eng
    answerAs F eng = return $ engToUrk langMap (flipEng eng)
    answerAs R eng = fmap ([Da, Ja] !!) $ randomRIO (0, 1)

    go (SDone p) = print (p == perm, p, perm)
    go (SQuestion to q whenDa whenJa) = do
      answer <- answerAs (perm !! to) (q (perm, perm !! to, langMap))
      case (answer :: Urk) of
        Da -> go whenDa
        Ja -> go whenJa

  go s

main :: IO ()
main = replicateM_ 10 $ sampleRun solution