let's findout who tells the truth and who lies

lier.hs

import Data.Maybe
import Data.List
import Control.Monad.State
import Control.Monad

type Var = String
type Value = String

type Variables = [(Var, Value)]

data Predicate = Is Var Value
               | And Predicate Predicate
               | Or Predicate Predicate
               | Not Predicate
               | Boolean Bool

isNot :: Var -> Value -> Predicate
isNot u v = Not (u `Is` v)

implies :: Predicate -> Predicate -> Predicate
implies p q = Not (p `And` Not q)

orElse :: Predicate -> Predicate -> Predicate
orElse p q = (p `And` Not q) `Or` (Not p `And` q)

same :: Predicate -> Predicate -> Predicate
same p q = (p `implies` q) `And` (q `implies` p)

honest = "honset"
lier = "lier"

said :: Var -> Predicate -> Predicate
said u p =
    ((u `Is` honest) `implies` p) `And`
    ((u `Is` lier) `implies` Not p)

maybeAnd :: Maybe Bool -> Maybe Bool -> Maybe Bool
maybeAnd (Just False) _ = Just False
maybeAnd _ (Just False) = Just False
maybeAnd x y = liftM2 (&&) x y

maybeOr :: Maybe Bool -> Maybe Bool -> Maybe Bool
maybeOr (Just True) _ = Just True
maybeOr _ (Just True) = Just True
maybeOr x y = liftM2 (||) x y

check :: Variables -> Predicate -> Maybe Bool
check vs (u `Is` v) = do
    x <- lookup u vs
    return (x == v)
check vs (p `And` q) = maybeAnd (check vs p) (check vs q)
check vs (p `Or` q) = maybeOr (check vs p) (check vs q)
check vs (Not p) = not <$> check vs p
check vs (Boolean b) = Just b

data ProblemState = ProblemState { vars :: Variables, preds :: [Predicate] }

type NDS a = StateT ProblemState [] a

isConsistent :: Bool -> NDS Bool
isConsistent partial = do
    ps <- gets preds
    vs <- gets vars
    let results = map (check vs) ps
    return $ all (fromMaybe partial) results

getVar :: Var -> NDS (Maybe Value)
getVar u = do
    vs <- gets vars
    return $ lookup u vs

setVar :: Var -> Value -> NDS ()
setVar u val = do
    vs <- gets vars
    let vs' = filter ((/= u) . fst) vs
    st <- get
    put $ st {vars = (u,val):vs'}
    isConsistent True >>= guard

getResult :: NDS Variables
getResult = do
    isConsistent False >>= guard
    gets vars

tryAll :: Var -> [Value] -> NDS ()
u `tryAll` vs = msum (map (setVar u) vs)

tryPerson :: Var -> NDS ()
tryPerson = (`tryAll` [honest,lier])

runPS :: [Predicate] -> NDS a -> [Variables]
runPS preds s = evalStateT (s >> getResult) (ProblemState [] preds)

showSolution :: Variables -> String
showSolution = unlines . map go where
    go (p, s) = p ++ " is " ++ s

count :: [Predicate] -> Int -> Predicate
count ps 0 = foldr (And . Not) (Boolean True) ps
count [] _ = Boolean False
count (p:ps) n =
    (p `And` count ps (n-1)) `Or`
    (Not p `And` count ps n)

atleast :: [Predicate] -> Int -> Predicate
atleast _ 0 = Boolean True
atleast [] _ = Boolean False
atleast (p:ps) n =
    (p `And` atleast ps (n-1)) `Or`
    (Not p `And` atleast ps n)

atmost :: [Predicate] -> Int -> Predicate
atmost ps n = atleast (map Not ps) (length ps - n)

(.==) = Is
(.!=) = isNot
(.:) = said
(.&&) = And
(.||) = Or
(.^) = orElse
(.=>) = implies
(.<=>) = same

problem1 = runPS predicate init where
    predicate =
        [ "Leila" .: ("Maryam" .== lier)
        , "Maryam" .: ("Golnoosh" .== lier)
        , "Golnoosh" .: (("Maryam" .== lier) .&& ("Leila" .== lier))
        , "Ali" .: ("Ali" .== honest)
        ]
    init = do
        mapM_ tryPerson ["Leila","Maryam","Golnoosh","Ali"]

problem2 = runPS predicate init where
    statements = ["A","B","C","D"]
    predicate =
        [ "A" .: ("D" .== honest)
        , "B" .: ("A" .== lier)
        , "C" .: ("B" .== lier)
        , "D" .: ("C" .== honest)
        , map (.== lier) statements `count` 1
        ]
    init = do
        mapM_ tryPerson statements

problem3 = runPS predicate init where
    crowd = ["alan", "ben", "chris", "dave", "emma"]
    eater = "eater"
    predicate =
        [ (eater .!= "emma") .^ (eater .== "ben")
        , (eater .!= "chris") .^ (eater .!= "emma")
        , (eater .== "emma") .^ (eater .!= "alan")
        , (eater .== "chris") .^ (eater .== "ben")
        , (eater .== "dave") .^ (eater .!= "alan")
        ]
    init = do
        eater `tryAll` crowd

problem4 = runPS predicate init where
    crowd = ["white", "brown", "gray", "blue", "black"]
    predicate = zipWith go crowd [0..4] where
        go u i = u .: (map (.== honest) crowd `count` i)
    init = do
        mapM_ tryPerson crowd

problem5 = runPS [predicate] init where
    predicate = ["car" .== "box1", "car" .!= "box2", "car" .!= "box1"] `count` 1
    init = do
        "car" `tryAll` ["box1", "box2", "box3"]

problem6 = runPS predicate init where
    crowd = ["A", "B", "C"]
    predicate =
        [ "A" .: ("B" .== honest)
        , "B" .: ("guilty" .!= "A")
        , "C" .: ("guilty" .== "A")
        , map (.== honest) crowd `count` 1
        ]
    init = do
        mapM_ tryPerson crowd
        "guilty" `tryAll` crowd

problem7 = runPS predicate init where
    crowd = ["brian", "chris", "leroy", "mike"]
    predicate =
        [ "brian" .: (("brian" .== honest) .<=> ("mike" .== lier))
        , "chris" .: ("leroy" .== lier)
        , "leroy" .: ("chris" .== lier)
        , "mike"  .: (map (.== honest) crowd `atleast` 2)
        ]
    init = do
        mapM_ tryPerson crowd

problem8 = runPS predicate init where
    crowd = ["A", "B", "C"]
    predicate =
        [ "A" .: ("A" .== honest)
        , "B" .: ("B" .== lier)
        , "C" .: ("C" .== "spy")
        , map (.== honest) crowd `count` 1
        , map (.== lier) crowd `count` 1
        , map (.== "spy") crowd `count` 1
        ]
    init = do
        mapM_ (`tryAll` [honest,lier,"spy"]) crowd

problem9 = runPS predicate inits where
    crowd = ["first","second","third","forth","fifth"]
    alg x = "algebra of " ++ x
    failedalgs = map ((.== "failed") . alg) crowd
    predicate =
        [ map (.== honest) (init crowd) `count` 1
        , "first" .: (failedalgs `atleast` 1)
        , "second" .: (failedalgs `atleast` 2)
        , "third" .: (failedalgs `atleast` 3)
        , "forth" .: (failedalgs `atleast` 4)
        ]
    inits = do
        "fifth" `setVar` honest
        mapM_ tryPerson (init crowd)
        mapM_ ((`tryAll` ["failed","passed"]) . alg) crowd

problem10 = runPS predicate inits where
    str i = "person " ++ show i
    crowd = map str [1..10]
    predicate = map go crowd where
        go u = u .: (map (.== honest) (filter (/= u) crowd) `count` 3)
    inits = do
        mapM_ tryPerson crowd

run p = do
    forM_ p $ \sol -> do
        putStrLn "======"
        putStrLn . showSolution $ sol
    putStr "Number of Solutions: "
    print $ length p