Skip to content

@petermarks /Puzzle.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.