https://github.com/geophf/1HaskellADay/blob/master/exercises/HAD/Y2018/M11/D26/Exercise.hs

Exercise.hs

module Y2018.M11.D26.Exercise where

import qualified Data.Set as S
import Control.Monad(foldM)
import Data.List(sort)

{--
An IQ puzzler:

Four (A, B, C and D) suspects were interrogated:
A said: C won't cheat unless B cheated.
B said: Either A or B cheated.
C said: B didn't cheat, I cheated.
D said: B cheated.

Only one person is lying. Who is lying and who(st(s)) cheated?
--}

data Suspect = A | B | C | D
   deriving (Eq, Ord, Enum, Show)

type Cheated = Bool
type Liar = Bool

data Statement = Statement { suspect :: Suspect, declaration ::  Declaration } deriving (Show, Eq)

instance Ord Statement where
    compare (Statement _ a) (Statement _ b) = compare a b

data Declaration = HasCheated Suspect
                 | HasNotCheated Suspect
                 | And Declaration Declaration
                 | Or Declaration Declaration
                 | OnlyIf Declaration Declaration
                 deriving (Show, Eq)

instance Ord Declaration where
    compare a b = compare (index a) (index b)
      where index :: Declaration -> Int
            index x = case x of
                        HasCheated _ -> 0
                        HasNotCheated _ -> 1
                        And _ _ -> 2
                        Or _ _ -> 3
                        OnlyIf _ _ -> 4

statements :: [Statement]
statements = [
               Statement A $ OnlyIf (HasNotCheated B) (HasNotCheated C)
             , Statement B $ Or (HasCheated A) (HasCheated B)
             , Statement C $ And (HasNotCheated B) (HasCheated C)
             , Statement D $ HasCheated B
             ]

data Answer = Ans { liar :: Suspect, cheaters :: [Suspect] }
   deriving (Eq, Ord, Show)

data Status = Status { suspectedLiar :: Suspect, notCheated :: S.Set Suspect, cheated :: S.Set Suspect }

solver :: [Statement] -> [Answer]
solver xs = map extractAnswer $ concatMap (\i ->  foldM solve i statements') initialStatus
  where statements' :: [Statement]
        statements' = sort xs
        initialStatus :: [Status]
        initialStatus = map (\s -> Status s S.empty S.empty) allSuspects
        extractAnswer :: Status -> Answer
        extractAnswer x = Ans (suspectedLiar x) (S.elems $ cheated x)
        giveTruth :: Status -> Statement -> Declaration
        giveTruth s x = if suspectedLiar s == suspect x then reverseDeclaration (declaration x) else declaration x
        solve :: Status -> Statement -> [Status]
        solve s x = solve' s $ giveTruth s x
        solve' :: Status -> Declaration -> [Status]
        solve' s x = case x of
                        HasCheated v -> if S.notMember v (notCheated s) then [s { cheated = S.insert v (cheated s) }] else []
                        HasNotCheated v -> if S.notMember v (cheated s) then [s { notCheated = S.insert v (notCheated s) }] else []
                        And a b -> concatMap (flip solve' b) (solve' s a)
                        Or a b -> solve' s a ++ solve' s b
                        OnlyIf a b -> solve' s (And a b) ++ solve' s (And (reverseDeclaration a) (reverseDeclaration b))


allSuspects :: [Suspect]
allSuspects = enumFrom A

reverseDeclaration :: Declaration -> Declaration
reverseDeclaration x = case x of
                         HasCheated s -> HasNotCheated s
                         HasNotCheated s -> HasCheated s
                         And a b -> Or (reverseDeclaration a) (reverseDeclaration b)
                         Or a b -> And (reverseDeclaration a) (reverseDeclaration b)
                         OnlyIf a b -> Or (OnlyIf (reverseDeclaration a) b) (OnlyIf a (reverseDeclaration b))

Franchement Gauthier, ton code est très beau ! C'en est presque émouvant…