fork(1) download
copy 
  1. import Control.Applicative ((<$>), (<*>))
  2. import Control.Monad
  3. import Data.List ((\\), isInfixOf)
  4.  
  5. -- types
  6. data House = House
  7.     { color :: Color
  8.     , man   :: Man
  9.     , pet   :: Pet
  10.     , drink :: Drink
  11.     , smoke :: Smoke
  12.     }
  13.     deriving (Eq, Show)
  14.  
  15. data Color = Red | Green | Blue | Yellow | White
  16.     deriving (Eq, Show, Enum, Bounded)
  17.  
  18. data Man = Eng | Swe | Dan | Nor | Ger
  19.     deriving (Eq, Show, Enum, Bounded)
  20.  
  21. data Pet = Dog | Birds | Cats | Horse | Zebra
  22.     deriving (Eq, Show, Enum, Bounded)
  23.  
  24. data Drink = Coffee | Tea | Milk | Beer | Water
  25.     deriving (Eq, Show, Enum, Bounded)
  26.  
  27. data Smoke = PallMall | Dunhill | Blend | BlueMaster | Prince
  28.     deriving (Eq, Show, Enum, Bounded)
  29.  
  30.  
  31. main :: IO ()
  32. main = do
  33.   mapM_ (\x-> mapM_ print (reverse x) >> putStrLn "----") solutions
  34.   putStrLn "No More Solutions"
  35.  
  36. solutions :: [[House]]
  37. solutions = filter (and . postChecks) $ foldM next [] [1..5]
  38.     where
  39.       next :: [House] -> Int -> [[House]]
  40.       next xs pos = [x:xs | x <- iterHouse xs, and $ checks pos x]
  41.  
  42.  
  43. iterHouse :: [House] -> [House]
  44. iterHouse xs =
  45.     House <$> new color <*> new man <*> new pet <*> new drink <*> new smoke
  46.     where
  47.       new getter = [minBound ..] \\ map getter xs
  48.  
  49.  
  50. -- immediate checks
  51. checks :: Int -> House -> [Bool]
  52. checks pos house =
  53.     [ man   `is` Eng    <=> color `is` Red              --  2
  54.     , man   `is` Swe    <=> pet   `is` Dog              --  3
  55.     , man   `is` Dan    <=> drink `is` Tea              --  4
  56.     , color `is` Green  <=> drink `is` Coffee           --  6
  57.     , pet   `is` Birds  <=> smoke `is` PallMall         --  7
  58.     , color `is` Yellow <=> smoke `is` Dunhill          --  8
  59.     , const (pos == 3)  <=> drink `is` Milk             --  9
  60.     , const (pos == 1)  <=> man   `is` Nor              -- 10
  61.     , drink `is` Beer   <=> smoke `is` BlueMaster       -- 13
  62.     , man   `is` Ger    <=> smoke `is` Prince           -- 14
  63.     ]
  64.     where
  65.       infix 4 <=>
  66.       p <=> q = p house == q house  -- both True or both False
  67.  
  68.  
  69. -- final checks
  70. postChecks :: [House] -> [Bool]
  71. postChecks houses =
  72.     -- NOTE: list of houses is generated "from tail"
  73.     [ [White, Green] `isInfixOf` map color houses       --  5
  74.     , (smoke `is` Blend  ) `nextTo` (pet   `is` Cats )  -- 11
  75.     , (smoke `is` Dunhill) `nextTo` (pet   `is` Horse)  -- 12
  76.     , (color `is` Blue   ) `nextTo` (man   `is` Nor  )  -- 15
  77.     , (smoke `is` Blend  ) `nextTo` (drink `is` Water)  -- 16
  78.     ]
  79.     where
  80.       nextTo :: (House -> Bool) -> (House -> Bool) -> Bool
  81.       nextTo p q
  82.           | (_:x:_) <- dropWhile (not . match) houses = match x
  83.           | otherwise                                 = False
  84.           where
  85.             match x = p x || q x
  86.  
  87.  
  88. is :: Eq a => (House -> a) -> a -> House -> Bool
  89. getter `is` value = (== value) . getter
  90.  
  91. {-
  92. Success	 time: 0.04 memory: 6284 signal:0
  93. House {color = Yellow,man = Nor, pet = Cats,  drink = Water, smoke = Dunhill }
  94. House {color = Blue,  man = Dan, pet = Horse, drink = Tea,   smoke = Blend   }
  95. House {color = Red,   man = Eng, pet = Birds, drink = Milk,  smoke = PallMall}
  96. House {color = Green, man = Ger, pet = Zebra, drink = Coffee,smoke = Prince  }
  97. House {color = White, man = Swe, pet = Dog,   drink = Beer,  smoke=BlueMaster}
  98. ----
  99. No More Solutions
  100. -}
Success #stdin #stdout 0.05s 6328KB
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/XaQH1Z
code from http://r...content-available-to-author-only...e.org/wiki/Zebra_puzzle#Haskell
language:
Haskell (ghc 8.4.4)
created:
10 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!