public
Created

Hoodlums logic puzzle homework / variable-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
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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.