Created
May 23, 2012 21:03
-
-
Save sztupi/2777815 to your computer and use it in GitHub Desktop.
Hoodlums logic puzzle homework / variable-length backtrack
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Main where | |
import Prelude | |
import Control.Applicative | |
import Data.Maybe | |
import Control.Monad | |
import Control.Arrow | |
import Data.Map as M | |
import Data.List as L | |
ellie = "Ellie" | |
emily = "Emily" | |
jessica = "Jessica" | |
girls = [ellie, emily, jessica] | |
elephant = "Elephant" | |
zebra = "Zebra" | |
giraffe = "Giraffe" | |
animals = [elephant, zebra, giraffe] | |
grunge = "Grunge" | |
plooper = "Plooper" | |
zinger = "Zinger" | |
lollies = [grunge, plooper, zinger] | |
aunt = "Aunt" | |
grandma = "Grandma" | |
mum = "Mum" | |
adults = [aunt, grandma, mum] | |
type Choices = Map Int [String] | |
choices = M.fromAscList $ zip [0..] [girls, animals, lollies, adults] | |
type Row = Map Int String | |
type Table = [Row] | |
main :: IO () | |
main = print $ solve | |
(==>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) | |
f ==> g = \x -> (not $ f x) || (g x) | |
have :: Int -> String -> Row -> Bool | |
have idx value row = (M.lookup idx row) == (Just value) | |
mayHave :: Int -> String -> Row -> Bool | |
mayHave idx value row = | |
case (M.lookup idx row) of | |
Just v | v /= value -> False | |
_ -> True | |
checkRules :: Row -> Bool | |
checkRules row = | |
all ($row) rules | |
where | |
rules = [ (have 0 ellie) ==> (not . (have 2 zinger)) | |
, (have 1 giraffe) ==> (not . (have 2 plooper)) | |
, (have 3 aunt) ==> (not . (have 0 jessica)) | |
, (have 0 ellie) ==> (mayHave 3 grandma) | |
, (have 3 mum) ==> (mayHave 1 elephant) | |
, (have 2 grunge) ==> (mayHave 3 aunt) ] | |
solve :: [Table] | |
solve = do | |
table <- goodTables checkRules choices | |
return table | |
isValid :: Choices -> Bool | |
isValid = L.all (/=[]) . M.elems | |
goodTables :: (Row -> Bool) -> Choices -> [Table] | |
goodTables check choices = do | |
row <- goodRows check choices | |
case remains choices row of | |
remainingChoices | (isValid remainingChoices) -> do | |
rows <- goodTables check remainingChoices | |
return $ row:rows | |
_ -> return [row] | |
goodRows :: (Row -> Bool) -> Choices -> [Row] | |
goodRows check choices = | |
goodRows' (M.empty) 0 | |
where | |
goodRows' :: Row -> Int -> [Row] | |
goodRows' start idx | idx == M.size choices = [start] | |
goodRows' start idx = do | |
pick <- choices ! idx | |
let row = M.insert idx pick start | |
guard $ check row | |
goodRows' row (idx+1) | |
remains :: Choices -> Row -> Choices | |
remains original row = | |
M.foldWithKey copyWithoutRowValue M.empty original | |
where | |
copyWithoutRowValue :: Int -> [String] -> Choices -> Choices | |
copyWithoutRowValue key value acc = M.insert key (L.delete (row ! key) value) acc |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment