sztupi / Main.hs

Created May 23, 2012


    
    View Main.hs 
  
  
      Main.hs
    
    
        Raw
      
    
    File suppressed. Click to show.
  
  
            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