Skip to content

@sztupi /Main.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Hoodlums logic puzzle homework / fixed-length backtrack
{-# LANGUAGE MultiParamTypeClasses #-}
module Main where
import Prelude
import Control.Applicative
import Data.Maybe
import Control.Monad
import Control.Arrow
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 :: Maybe Girl
, animal :: Maybe Animal
, lolly :: Maybe Lolly
, adult :: Maybe Adult }
deriving Show
data Choices = Choices
{ girls :: [Girl]
, animals :: [Animal]
, lollies :: [Lolly]
, adults :: [Adult] }
allChoice = Choices enums enums enums enums
remains :: Choices -> Row -> Choices
remains original row =
Choices
((girls original) `except` (girl row))
((animals original) `except` (animal row))
((lollies original) `except` (lolly row))
((adults original) `except` (adult row))
where
except :: Eq a => [a] -> Maybe a -> [a]
except xs (Just x) = filter (/= x) xs
except xs Nothing = xs
class (Enum a, Bounded a, Eq a) => Atom r a where
get :: r -> Maybe a
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
main :: IO ()
main = print $ solve
-- main = print $ permits $ Row (Just Ellie) Nothing (Just Zinger) Nothing
enums :: (Enum a, Bounded a) => [a]
enums = [minBound .. maxBound]
(==>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)
f ==> g = \x -> (not $ f x) || (g x)
have :: Atom r a => a -> r -> Bool
have value row = (get row) == (Just value)
mayHave :: Atom r a => a -> r -> Bool
mayHave value row =
case get row of
Just x | x == value -> True
Nothing -> True
_ -> False
checkRules :: Row -> Bool
checkRules row =
all ($row) rules
where
rules = [ (have Ellie) ==> (not . (have Zinger))
, (have Giraffe) ==> (not . (have Plooper))
, (have Aunt) ==> (not . (have Jessica))
, (have Ellie) ==> (mayHave Grandma)
, (have Mum) ==> (mayHave Elephant)
, (have Grunge) ==> (mayHave Aunt) ]
solve :: [[Row]]
solve = do
r1 <- solveOne allChoice
let set1 = remains allChoice r1
r2 <- solveOne set1
let set2 = remains set1 r2
r3 <- solveOne set2
return [r1,r2,r3]
solveOne :: Choices -> [Row]
solveOne choices = do
let g = head $ girls choices
a <- animals choices
guard $ checkRules $ Row (Just g) (Just a) Nothing Nothing
l <- lollies choices
guard $ checkRules $ Row (Just g) (Just a) (Just l) Nothing
d <- adults choices
let row = Row (Just g) (Just a) (Just l) (Just d)
guard $ checkRules $ row
return row
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.