Knave small task

knave.hs

import Prelude hiding (or,and)
import qualified Data.Map as Map
import Data.List (sort)
import Control.Monad (replicateM)

data Type = Insane | Sane | Usual | Undecided deriving (Eq, Ord, Show)
type Name = String
data Person = Person {ptype :: Type, pname :: Name} deriving (Eq, Show, Ord)

type Persons = Map.Map Name Person
makePersons :: [Person] -> Persons
makePersons ps = Map.fromList $ map (\p -> (pname p,p)) ps
showPersons ps = [(name, ptype p) | (name, p) <- Map.toList ps ]

data Opinion =  OR Opinion Opinion
              | AND Opinion Opinion
              | Assert Name Type
                deriving (Eq, Show)

data Thought = Thought Name Opinion deriving (Show)

getType :: Name -> Persons -> Type
getType n ps = case Map.lookup n ps of
      Just p -> ptype p
      _ -> error $ "don't know person with the name " ++ n

correct :: Opinion -> Persons -> Bool
correct (OR op1 op2) ps     = correct op1 ps || correct op2 ps
correct (AND op1 op2) ps    = correct op1 ps && correct op2 ps
correct (Assert n type2) ps = decide type1 type2
  where
    type1 = getType n ps
    decide a b | a == b = True
               | otherwise = False

allThoughtsCorrect :: [Thought] -> Persons -> Bool
allThoughtsCorrect ts ps = all thoughtCorrect ts
  where
    thoughtCorrect (Thought name opinion) = result
      where
        cur_type = getType name ps
        correctness = correct opinion ps
        result = case (correctness, cur_type) of
          (True, Sane) -> True
          (False, Insane)    -> True
          (_,    Usual)    -> True
          (_,    _)        -> False

replace :: Persons -> Person -> Persons
replace ps p = Map.alter f (pname p) ps
  where f _ = Just p

checkVariants :: [Thought] -> [Name] -> [[(Name, Type)]]
checkVariants ts names = map showPersons answers
  where answers = filter (allThoughtsCorrect ts) (variants names)

variants :: [Name] -> [Persons]
variants names = res
  where
    types = [Insane, Sane, Usual]
    combinations = replicateM (length names) types
    res = [ makePersons [ Person t n | (t,n) <- zip comb names]
        | comb <- combinations ]

names = [
  "2", "3", "4", "5", "6", "7",
  "knave", "ace" ]

ts = [
  "3" `Thought` (Assert "ace" Insane),
  "4" `Thought` (Assert "3" Sane `AND` Assert "2" Sane),
  "5" `Thought` ((Assert "4" Insane `AND` Assert "ace" Insane)
    `OR` (Assert "4" Sane `AND` Assert "ace" Sane)),
  "6" `Thought` (Assert "ace" Sane `AND` Assert "2" Sane),
  "7" `Thought` Assert "5" Insane,
  "knave" `Thought` (Assert "6" Sane `AND` Assert "7" Sane)
  ]

main = mapM_ print numbers
  where
    knaves = concatMap (filter (\(n,_) -> n == "knave")) $ checkVariants ts names
    find t = length $ filter (\(_,tt) -> t == tt) knaves
    numbers = map (\t -> (t,find t)) [Insane, Sane, Usual]

{-
 - Программа выдает в этом случае
 - (Insane,284)
 - (Sane,4)
 - (Usual,288)
 - Варианты: S -> Sane, I -> Insane, U -> Usual
 - [("2",S),("3",U),("4",I),("5",I),("6",I),("7",U),("ace",I),("knave",U)]
 - [("2",S),("3",I),("4",U),("5",I),("6",S),("7",S),("ace",S),("knave",S)]
 -}

Makefile

all:
	ghc --make knave.hs