Logic Puzzle Solver

Puzzle.hs

{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses  #-}
module Puzzle where

import Data.List


--------------------------------------------------------------------------------
-- Specific to this puzzle

main :: IO ()
main = print $ solve Row rules

data Girl   = Ellie | Emily | Jessica
    deriving (Show, Eq, Enum, Bounded)

data Animal = Elephant | Zebra | Giraffe
    deriving (Show, Eq, Enum, Bounded)

data Lolly  = Grunge | Plooper | Zinger
    deriving (Show, Eq, Enum, Bounded)

data Adult  =  Aunt | Grandma | Mum
    deriving (Show, Eq, Enum, Bounded)

data Row = Row { girl  :: Girl,  animal :: Animal,
                 lolly :: Lolly, adult  :: Adult }
  deriving Show

instance Atom Row Girl   where get = girl
instance Atom Row Animal where get = animal
instance Atom Row Lolly  where get = lolly
instance Atom Row Adult  where get = adult

rules = [ Ellie   `With`    Grandma
        , Ellie   `NotWith` Zinger
        , Mum     `With`    Elephant
        , Giraffe `NotWith` Plooper
        , Aunt    `With`    Grunge
        , Aunt    `NotWith` Jessica
        ]


--------------------------------------------------------------------------------
-- Generic solver

class (Enum a, Bounded a, Eq a) => Atom r a where
  get :: r -> a

data Rule r = forall a b . (Atom r a, Atom r b) => With a b
            | forall a b . (Atom r a, Atom r b) => NotWith a b

enums :: (Enum a, Bounded a) => [a]
enums = [minBound .. maxBound]

solve :: (Atom r a, Atom r b, Atom r c, Atom r d) =>
            (a -> b -> c -> d -> r) -> [Rule r] -> [[r]]
solve mkRow rules =
  [ table 
  | ans  <- permutations enums
  , lols <- permutations enums
  , ads  <- permutations enums
  , let table = zipWith4 mkRow enums ans lols ads
  , all (flip check table) rules
  ]

check :: Rule r -> [r] -> Bool
check (With l r)    = any (\row -> get row == l && get row == r)
check (NotWith l r) = all (\row -> not (get row == l && get row == r))