# petermarks / Puzzle.hs Created April 29, 2012

### SSH clone URL

You can clone with HTTPS or SSH.

Logic Puzzle Solver

View Puzzle.hs
 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)) ```
to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.