Jack.hs

module Jack where

data Tell = Lie | CanLie | Truth
data State = Insane | Sane

data Card = Ace | Two | Three | Four | Five | Six | Seven | Jack
data About = About
data As = As
data Not = Not
data Both = Both

insane card = card `can` Lie
sane card = card `only` Truth

only :: Card -> Tell -> Bool
card `only` tell =
    foldl (&&) True $ opinions card tell

can :: Card -> Tell -> Bool
card `can` tell =
    foldl (||) False $ opinions card tell

opinions :: Card -> Tell -> [Bool]
opinions card tell =
    map (\other -> has card tell About other) $ tell_about card

has :: Card -> Tell -> About -> Card -> Bool
has card Lie About other =
    let thought = card `think` other
    in thought Sane == insane other && thought Insane == sane other
has card Truth About other =
    not (has card Lie About other)

think :: Card -> Card -> State -> Bool
Three `think` Ace = is Insane
Seven `think` Five = is Insane
Six `think` Ace = is Sane
Six `think` Two = is Sane
Five `think` Ace = same As Four
Five `think` Four = same As Ace
Four `think` Three = with Two Not Both
Four `think` Two = with Three Not Both
Jack `think` Six = with Seven Not Both
Jack `think` Seven = with Six Not Both

card `think` other =
    card `not_think` other

is :: State -> State -> Bool
is Insane Insane = True
is Sane Sane = True
is _ _ = False

same :: As -> Card -> (State -> Bool)
same As card Insane = insane card
same As card Sane = sane card

with :: Card -> Not -> Both -> State -> Bool
with card Not Both Insane = sane card
with card Not Both Sane = True

not_think :: Card -> Card -> State -> Bool
not_think card other state =
    not $ (card `think` other) (not' state)

not' :: State -> State
not' Sane = Insane
not' Insane = Sane

tell_about :: Card -> [Card]
tell_about Three = [Ace]
tell_about Seven = [Five]
tell_about Six = [Ace,Two]
tell_about Four = [Three,Two]
tell_about Five = [Ace,Four]
tell_about Jack = [Six,Seven]
tell_about _ = []