Data commit

Task/Zebra-puzzle/Haskell/zebra-puzzle-1.hs

@@ -0,0 +1,91 @@
+module Main where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (foldM, forM_)
+import Data.List ((\\))
+
+-- types
+data House = House
+    { color :: Color      -- <trait> :: House -> <Trait>
+    , man   :: Man
+    , pet   :: Pet
+    , drink :: Drink
+    , smoke :: Smoke
+    }
+    deriving (Eq, Show)
+
+data Color = Red | Green | Blue | Yellow | White
+    deriving (Eq, Show, Enum, Bounded)
+
+data Man = Eng | Swe | Dan | Nor | Ger
+    deriving (Eq, Show, Enum, Bounded)
+
+data Pet = Dog | Birds | Cats | Horse | Zebra
+    deriving (Eq, Show, Enum, Bounded)
+
+data Drink = Coffee | Tea | Milk | Beer | Water
+    deriving (Eq, Show, Enum, Bounded)
+
+data Smoke = PallMall | Dunhill | Blend | BlueMaster | Prince
+    deriving (Eq, Show, Enum, Bounded)
+
+type Solution = [House]
+
+main :: IO ()
+main = do
+  forM_ solutions $ \sol -> mapM_ print sol
+                            >> putStrLn "----"
+  putStrLn "No More Solutions"
+
+
+solutions :: [Solution]
+solutions = filter finalCheck . map reverse $ foldM next [] [1..5]
+    where
+      -- NOTE: list of houses is generated in reversed order
+      next :: Solution -> Int -> [Solution]
+      next sol pos = [h:sol | h <- newHouses sol, consistent h pos]
+
+
+newHouses :: Solution -> Solution
+newHouses sol =    -- all combinations of traits not yet used
+    House <$> new color <*> new man <*> new pet <*> new drink <*> new smoke
+    where
+      new trait = [minBound ..] \\ map trait sol  -- :: [<Trait>]
+
+
+consistent :: House -> Int -> Bool
+consistent house pos = and                  -- consistent with the rules:
+    [ man   `is` Eng     <=>   color `is` Red              --  2
+    , man   `is` Swe     <=>   pet   `is` Dog              --  3
+    , man   `is` Dan     <=>   drink `is` Tea              --  4
+    , color `is` Green   <=>   drink `is` Coffee           --  6
+    , pet   `is` Birds   <=>   smoke `is` PallMall         --  7
+    , color `is` Yellow  <=>   smoke `is` Dunhill          --  8
+    , const (pos == 3)   <=>   drink `is` Milk             --  9
+    , const (pos == 1)   <=>   man   `is` Nor              -- 10
+    , drink `is` Beer    <=>   smoke `is` BlueMaster       -- 13
+    , man   `is` Ger     <=>   smoke `is` Prince           -- 14
+    ]
+    where
+      infix 4 <=>
+      p <=> q  =  p house == q house   -- both True or both False
+
+
+is :: Eq a => (House -> a) -> a -> House -> Bool
+(trait `is` value) house  =  trait house == value
+
+
+finalCheck :: [House] -> Bool
+finalCheck solution = and                    -- fulfills the rules:
+    [ (color `is` Green)   `leftOf` (color `is` White)  --  5
+    , (smoke `is` Blend  ) `nextTo` (pet   `is` Cats )  -- 11
+    , (smoke `is` Dunhill) `nextTo` (pet   `is` Horse)  -- 12
+    , (color `is` Blue   ) `nextTo` (man   `is` Nor  )  -- 15
+    , (smoke `is` Blend  ) `nextTo` (drink `is` Water)  -- 16
+    ]
+    where
+      nextTo :: (House -> Bool) -> (House -> Bool) -> Bool
+      nextTo p q = leftOf p q || leftOf q p
+      leftOf p q
+          | (_:h:_) <- dropWhile (not . p) solution = q h
+          | otherwise                               = False

Task/Zebra-puzzle/Haskell/zebra-puzzle-2.hs

@@ -0,0 +1,60 @@
+import Control.Monad
+import Data.List
+
+values :: (Bounded a, Enum a) => [[a]]
+values = permutations [minBound..maxBound]
+
+data Nation = English   | Swede     | Dane  | Norwegian     | German
+    deriving (Bounded, Enum, Eq, Show)
+data Color  = Red       | Green     | White | Yellow        | Blue
+    deriving (Bounded, Enum, Eq, Show)
+data Pet    = Dog       | Birds     | Cats  | Horse         | Zebra
+    deriving (Bounded, Enum, Eq, Show)
+data Drink  = Tea       | Coffee    | Milk  | Beer          | Water
+    deriving (Bounded, Enum, Eq, Show)
+data Smoke  = PallMall  | Dunhill   | Blend | BlueMaster    | Prince
+    deriving (Bounded, Enum, Eq, Show)
+
+answers = do
+    color <- values
+    leftOf  color  Green       color White    -- 5
+
+    nation <- values
+    first   nation Norwegian                  -- 10
+    same    nation English     color Red      -- 2
+    nextTo  nation Norwegian   color Blue     -- 15
+
+    drink <- values
+    middle  drink  Milk                       -- 9
+    same    nation Dane        drink Tea      -- 4
+    same    drink  Coffee      color Green    -- 6
+
+    pet <- values
+    same    nation Swede       pet   Dog      -- 3
+
+    smoke <- values
+    same    smoke  PallMall    pet   Birds    -- 7
+    same    color  Yellow      smoke Dunhill  -- 8
+    nextTo  smoke  Blend       pet   Cats     -- 11
+    nextTo  pet    Horse       smoke Dunhill  -- 12
+    same    nation German      smoke Prince   -- 14
+    same    smoke  BlueMaster  drink Beer     -- 13
+    nextTo  drink  Water       smoke Blend    -- 16
+
+    return $ zip5 nation color pet drink smoke
+
+  where
+    same    xs x  ys y  =  guard $ (x, y) `elem` zip xs ys
+    leftOf  xs x  ys y  =  same  xs x  (tail ys) y
+    nextTo  xs x  ys y  =  leftOf  xs x  ys y  `mplus`
+                           leftOf  ys y  xs x
+    middle  xs x        =  guard $ xs !! 2 == x
+    first   xs x        =  guard $ head xs == x
+
+main = do
+    forM_ answers $ (\answer ->  -- for answer in answers:
+      do
+        mapM_ print answer
+        print [nation | (nation, _, Zebra, _, _) <- answer]
+        putStrLn "" )
+    putStrLn "No more solutions!"