public
Created

Logic Puzzle Solver

  • Download Gist
Puzzle.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
{-# 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))

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.