September 2017 Update

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

@@ -1,10 +1,12 @@
+module Main where
+
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad (foldM, forM_)
-import Data.List ((\\), isInfixOf)
+import Data.List ((\\))
 
 -- types
 data House = House
-    { color :: Color
+    { color :: Color      -- <trait> :: House -> <Trait>
     , man   :: Man
     , pet   :: Pet
     , drink :: Drink
@@ -27,51 +29,55 @@ data Drink = Coffee | Tea | Milk | Beer | Water
 data Smoke = PallMall | Dunhill | Blend | BlueMaster | Prince
     deriving (Eq, Show, Enum, Bounded)
 
+type Solution = [House]
 
 main :: IO ()
 main = do
-  forM_ solutions $ \x -> mapM_ print (reverse x)
-                       >> putStrLn "----"
+  forM_ solutions $ \sol -> mapM_ print sol
+                            >> putStrLn "----"
   putStrLn "No More Solutions"
 
 
-solutions :: [[House]]
-solutions = filter (and . postChecks) $ foldM next [] [1..5]
+solutions :: [Solution]
+solutions = filter finalCheck . map reverse $ foldM next [] [1..5]
     where
-      next xs pos = [x:xs | x <- iterHouse xs, and $ checks pos x]
+      -- NOTE: list of houses is generated in reversed order
+      next :: Solution -> Int -> [Solution]
+      next sol pos = [h:sol | h <- newHouses sol, consistent h pos]
 
 
-iterHouse :: [House] -> [House]
-iterHouse xs =
+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 getter = [minBound ..] \\ map getter xs
+      new trait = [minBound ..] \\ map trait sol  -- :: [<Trait>]
 
 
--- immediate checks
-checks :: Int -> House -> [Bool]
-checks pos house =
-    [ 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
+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
+      p <=> q  =  p house == q house   -- both True or both False
 
 
--- final checks
-postChecks :: [House] -> [Bool]
-postChecks houses =
-    -- NOTE: list of houses is generated in reversed order
-    [ [White, Green] `isInfixOf` map color houses       --  5
+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
@@ -79,12 +85,7 @@ postChecks houses =
     ]
     where
       nextTo :: (House -> Bool) -> (House -> Bool) -> Bool
-      nextTo p q
-          | (_:x:_) <- dropWhile (not . match) houses = match x
-          | otherwise                                 = False
-          where
-            match x = p x || q x
-
-
-is :: Eq a => (House -> a) -> a -> House -> Bool
-getter `is` value = (== value) . getter
+      nextTo p q = leftOf p q || leftOf q p
+      leftOf p q
+          | (_:h:_) <- dropWhile (not . p) solution = q h
+          | otherwise                               = False