fork download
copy 
  1. module Main where
  2.  
  3. import Control.Applicative ((<$>), (<*>))
  4. import Control.Monad (foldM, forM_)
  5. import Data.List ((\\))
  6.  
  7. -- types
  8. data House = House   
  9.     { color :: Color      -- <trait> :: House -> <Trait>
  10.     , man   :: Man
  11.     , pet   :: Pet
  12.     , drink :: Drink
  13.     , smoke :: Smoke
  14.     }
  15.     deriving (Eq, Show)
  16.  
  17. data Color = Red | Green | Blue | Yellow | White
  18.     deriving (Eq, Show, Enum, Bounded)
  19.  
  20. data Man = Eng | Swe | Dan | Nor | Ger
  21.     deriving (Eq, Show, Enum, Bounded)
  22.  
  23. data Pet = Dog | Birds | Cats | Horse | Zebra
  24.     deriving (Eq, Show, Enum, Bounded)
  25.  
  26. data Drink = Coffee | Tea | Milk | Beer | Water
  27.     deriving (Eq, Show, Enum, Bounded)
  28.  
  29. data Smoke = PallMall | Dunhill | Blend | BlueMaster | Prince
  30.     deriving (Eq, Show, Enum, Bounded)
  31.  
  32. type Solution = [House]
  33.  
  34. main :: IO ()
  35. main = do
  36.   forM_ solutions $ \sol -> mapM_ print sol
  37.                             >> putStrLn "----"
  38.   putStrLn "No More Solutions"
  39.  
  40.  
  41. solutions :: [Solution]
  42. solutions = foldM next [] [1..6]
  43.     where
  44.       next :: Solution -> Int -> [Solution]
  45.       next sol pos | pos <= 5  = [h:sol | h <- newHouses sol, consistent h pos]
  46.                    | otherwise = [r | let r = reverse sol, finalCheck r]
  47.  
  48.  
  49. newHouses :: Solution -> Solution
  50. newHouses sol =    -- all combinations of traits not yet used
  51.     House <$> new color <*> new man <*> new pet <*> new drink <*> new smoke
  52.     where
  53.       new trait = [minBound ..] \\ map trait sol  -- :: [<Trait>]
  54.  
  55.  
  56. consistent :: House -> Int -> Bool
  57. consistent house pos = and                  -- consistent with the rules:
  58.     [ man   `is` Eng     <=>   color `is` Red              --  2
  59.     , man   `is` Swe     <=>   pet   `is` Dog              --  3
  60.     , man   `is` Dan     <=>   drink `is` Tea              --  4
  61.     , color `is` Green   <=>   drink `is` Coffee           --  6
  62.     , pet   `is` Birds   <=>   smoke `is` PallMall         --  7
  63.     , color `is` Yellow  <=>   smoke `is` Dunhill          --  8
  64.     , const (pos == 3)   <=>   drink `is` Milk             --  9
  65.     , const (pos == 1)   <=>   man   `is` Nor              -- 10
  66.     , drink `is` Beer    <=>   smoke `is` BlueMaster       -- 13
  67.     , man   `is` Ger     <=>   smoke `is` Prince           -- 14
  68.     ]
  69.     where
  70.       infix 4 <=>
  71.       p <=> q  =  p house == q house   -- both True or both False
  72.  
  73.  
  74. is :: Eq a => (House -> a) -> a -> House -> Bool
  75. (trait `is` value) house  =  trait house == value
  76.  
  77.  
  78. finalCheck :: [House] -> Bool
  79. finalCheck solution = and                    -- fulfills the rules:
  80.     [ (color `is` Green)   `leftOf` (color `is` White)  --  5
  81.     , (smoke `is` Blend  ) `nextTo` (pet   `is` Cats )  -- 11
  82.     , (smoke `is` Dunhill) `nextTo` (pet   `is` Horse)  -- 12
  83.     , (color `is` Blue   ) `nextTo` (man   `is` Nor  )  -- 15
  84.     , (smoke `is` Blend  ) `nextTo` (drink `is` Water)  -- 16
  85.     ]
  86.     where
  87.       nextTo :: (House -> Bool) -> (House -> Bool) -> Bool
  88.       nextTo p q = leftOf p q || leftOf q p
  89.       leftOf p q 
  90.           | (_:h:_) <- dropWhile (not . p) solution = q h
  91.           | otherwise                               = False
Success #stdin #stdout 0.01s 8388607KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
House {color = Yellow, man = Nor, pet = Cats, drink = Water, smoke = Dunhill}
House {color = Blue, man = Dan, pet = Horse, drink = Tea, smoke = Blend}
House {color = Red, man = Eng, pet = Birds, drink = Milk, smoke = PallMall}
House {color = Green, man = Ger, pet = Zebra, drink = Coffee, smoke = Prince}
House {color = White, man = Swe, pet = Dog, drink = Beer, smoke = BlueMaster}
----
No More Solutions
https://ideone.com/ZaKfWC
Zebra puzzle at Rosetta Code
language:
Haskell (ghc 8.4.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!