public
Created

Hoodlums logic puzzle homework / fixed-length backtrack

  • Download Gist
Main.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 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
{-# 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.