Solving the Einstein's Puzzle by Haskell

Prelude

Not so long ago I read an article on Habré that reminded me of an interesting puzzle, which is called the “ Einstein 's Mystery ” or the “Zebra puzzle”. Probably many of you solved this problem on a piece of paper and were proud to be part of a few percent of the world's population who are capable of it.

After reading the article, I thought about the software solution of this problem. The approach given in the article was interesting and fully justified the name of the blog, but it seemed to me not quite clear. At the moment I'm interested in the Haskell programming language, which is perfect for warming up brains by itself, but solving the puzzle on it seemed like a great challenge.

Algorithm

In general, the task looks like this:

• there is an ordered set of objects (in the condition there are five of them and these are houses on one street)
• Each object has a set of attributes, which in turn can take a fixed set of values ​​(there are also five such attributes: the nationality of the owner, the color of the house, a pet, a favorite drink, and the brand of the owner’s cigarettes);
• attribute values ​​cannot be the same for different objects and the number of values ​​for each attribute is equal to the number of objects.
• In addition, a number of restrictions (15) are given, which describe combinations of attribute values ​​(the full text of the condition can be found at one of the links at the beginning of the article).

It is necessary to restore the values ​​of the attributes of all objects (or some of them, which are otherwise the same), which would not contradict the restrictions.
')
The first thought was a complete enumeration of options with checking the fulfillment of the conditions of the task, but simple calculations show that the number of combinations is equal
5! 5 = 24.883.200.000 5! 5 = 24.883.200.000 , which is quite a lot.

In the course of some reflections, the following approach was born: there is an admissible solution space, constraints describe subsets of solutions, correct solutions lie at the intersection of such subsets (that is, in the area where all conditions are fulfilled).

The next step was the decision to describe the subsets of solutions in the form of a set of patterns: decisions in which some attributes of some objects are fixed, and the rest can take any valid values. And having such a description you only need to learn how to intersect the sets described in this way.

Decision

When compiling and rewriting a solution in the Haskell language, I was guided not only by the desire to find a solution to the problem, but also by the desire to write an understandable program that would easily demonstrate both the algorithm and the excellent Haskell language.

Therefore, I tried to minimally use approaches that prevent unprepared people from reading the program. The solution does not claim complete universality, however, some tools for solving this class of problems have been described.

However, read for yourself - I left a lot of comments for you.
But your comments, I will be glad.

2. import data . List ( lookup , nub)
3. import data . Maybe (fromMaybe , catMaybes)
5. -----------------------------------------------
6. - The Mystery of Einstein -
7. - by Atamur -
8. -----------------------------------------------
10. ---------------------------
11. - General description of the task -
12. ---------------------------
14. - The solution is a sequence of objects
15. type Solution = [Object]
16. - Each object is described by a set of attribute pairs and their values.
17. type Object = [( String , String )]
19. - indicating the attribute-value pair with the = sign:
20. attr = : value = (attr , value)
22. attributes = [ "nationality" , "house" , "pet" , "drink" , "smoke" ]
23. size = 5
25. - We will solve the problem of finding a solution that satisfies some
26. - restrictions
27. - We will do this starting from the set of all solutions and gradually refining
28. - this is a set until it decreases to one solution, which will be
29. - true.
31. - Therefore, an object can immediately describe a set of real objects
32. - which have some attributes set, and the rest (not set)
33. - can be any. Therefore, an empty object is a template of all possible
34. - objects:
35. anyObject = [] :: Object
36. - A set of empty objects - the set of all solutions for a given
37. - dimensions:
38. anySolution = [anyObject | n ← [1 .. size]]
40. - Each solution describes a compatible set of solutions, for example, a solution
41. - [["nationality" =: "Englishman"], anyObject, anyObject]
42. - describes all three objects, the first of which has an attribute
43. - "nationality is English"
44. “But when refining solutions, we will need to have sets of incompatible
45. - decisions (for example, “Englishman or first or second but not at the same time”):
46. type Solutions = [Solution]
48. empty = [] :: Solutions
50. - To solve the problem, we need to impose restrictions on the solution
51. - Each constraint will transform a variety of solutions.
52. - As a result, there may be several unrelated sets or
53. - empty solution set
54. type Restriction = Solution → Solutions
56. - applying a constraint to a set of solutions
57. - when transforming a set of solutions, we will check for
58. - uniqueness of attribute values:
59. apply :: Restriction → Solutions → Solutions
60. apply restrict sols =
61. concat [ filter ( not . duplicates) (restrict solution) | solution ← sols]
62. where
63. duplicates sols = any duplicateValues ​​( map (values ​​sols) attributes)
64. values ​​sols attr = map ( lookup attr) sols
65. duplicateValues ​​vals' =
66. let vals = catMaybes vals'
67. in (vals ≠ nub vals)
69. - the intersection of two patterns describing objects
70. - can be a template containing attributes from both source templates,
71. - or it may be incompatible if the source templates contain different
72. - values ​​of the same attributes
73. both :: Object → Object → Maybe Object
74. both obj obj ' = foldl join (Just []) attributes - combine by attributes
75. where
76. - if we already have an empty set then the result is also empty
77. join Nothing _ = Nothing
78. - otherwise compare values ​​of attributes by attributes.
79. join (Just rest) attr =
80. case ( lookup attr obj , lookup attr obj ') of
81. (Nothing , Nothing) → Just rest
82. (Just value , Nothing) → Just ((attr = : value): rest)
83. (Nothing , Just value) → Just ((attr = : value): rest)
84. (Just value , Just value ') →
85. if value == value '
86. then Just ((attr = : value): rest)
87. else Nothing
89. - basic restriction - the object in some position must coincide with
90. - set by template
91. objectAt :: Int → Object → Restriction
92. objectAt n obj solution =
93. case both obj (solution !! (n - 1)) of
94. Nothing → empty - if the template is not compatible with the one already there
95. Just res → [replace n res solution]
96. where
97. replace nx xs = take (n - 1) xs ++ [x] ++ drop n xs
99. - Operations on constraints ---------------------------------------------
101. - intersection - both restrictions are true
102. ( < & > ) rs rs 'solution = apply rs (rs' solution)
103. r _ all = foldl1 ( < & > ) - all restrictions from the set
105. - association - one or the other is true
106. ( <|> ) rs rs 'solution = rs solution ++ rs' solution
107. r _ any = foldl1 ( <|> ) - one of the limitations
109. - Derived constraints ---------------------------------------------- -
111. - there is some object (either in the first position, or in the second, etc.)
112. exists obj = r _ any [objectAt n obj | n ← [1 .. 5]]
114. - one object always follows another
115. before obj obj ' = r _ any [
116. objectAt n obj < & > objectAt (n + 1) obj ' | n ← [1 .. size - 1]]
118. - near (or one before the second, or second before the first)
119. near obj obj ' = (obj `before` obj') <|> (obj 'before` obj)
121. ------------------------------------------------
122. - Description of the specific problem
123. ------------------------------------------------
125. restrictions =
126. objectAt 1 [ "nationality" = : "Norwegian" ] < & >
127. exists [ "nationality" = : "Englishman" , "house" = : "Red" ] < & >
128. ([ "house" = : "Green" ] `before` [ " house " = : " White " ]) < & >
129. exists [ "nationality" = : "Dane" , "drink" = : "Tea" ] < & >
130. ([ "smoke" = : "Malboro" ] `near` [ " pet " = : " Cat " ]) < & >
131. exists [ "smoke" = : "Dunhill" , "house" = : "Yellow" ] < & >
132. exists [ "nationality" = : "German" , "smoke" = : "Rothmans" ] < & >
133. objectAt 3 [ "drink" = : "Milk" ] < & >
134. ([ "smoke" = : "Malboro" ] `near` [ " drink " = : " Water " ]) < & >
135. exists [ "smoke" = : "Pallmall" , "pet" = : "Bird" ] < & >
136. exists [ "nationality" = : "Swede" , "pet" = : "Dog" ] < & >
137. ([ "nationality" = : "Norwegian" ] `near` [ " house " = : " Blue " ]) < & >
138. exists [ "pet" = : "Horse" , "house" = : "Blue" ] < & >
139. exists [ "smoke" = : "Winfield" , "drink" = : "Beer" ] < & >
140. exists [ "house" = : "Green" , "drink" = : "Coffee" ] < & >
141. exists [ "pet" = : "Fish" ]
142. - the fish does not appear anywhere, you need to ask what it is
144. main = let solutions = apply restrictions [anySolution]
145. in if length solutions > 1
146. then putStrLn ( "Total solution sets:" ++ show ( length solutions))
147. else putStrLn $ descrSolution $ head solutions
149. -----------------------------
150. - String views -
151. -----------------------------
153. - a string representation of a person:
154. descrMan man = descr "nationality" ++ "lives in" ++
155. descr "house" ++ "house, owns" ++
156. descr "pet" ++ ", drinks" ++
157. descr "drink" ++ "and smokes" ++
158. descr "smoke"
159. where descr attr = fromMaybe "?" ( lookup attr man)
161. - string representation of the solution:
162. descrSolution sol = concat [descrMan man ++ " \ n " | man ← sol]