Instantly share code, notes, and snippets.

# sztupi/Main.hs Created May 23, 2012

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