Instantly share code, notes, and snippets.

# petermarks/Puzzle.hs Created Apr 29, 2012

What would you like to do?
Logic Puzzle Solver
 {-# 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))