Решение загадки Эйнштейна на Haskell

Прелюдия

Не так давно я прочитал на Хабре статью, которая напомнила мне про интересную головоломку, которую называют «Загадкой Эйнштейна» или «Zebra puzzle». Вероятно многие из вас решали эту задачку на листке бумаги и гордились тем, что входят в несколько процентов населения земли, способных на это.

Прочитав статью, я задумался над программным решением этой задачи. Подход, приведенный в статье был интересен и вполне оправдал название блога, но показался мне не совсем понятным. В данный момент я интересуюсь языком программирования Haskell, который прекрасно подходит и сам по себе для разминки мозгов, решение же головоломки на нем показалось мне прекрасным вызовом.

Алгоритм

В общем виде задача выглядит так:

• существует упорядоченный набор объектов (в условии их пять и это дома на одной улице);
• каждый объект обладает набором атрибутов, которые в свою очередь могут принимать фиксированный набор значений (в условии таких атрибутов так же пять: национальность владельца, цвет дома, домашнее животное, любимый напиток и марка сигарет владельца);
• значения атрибутов не могут совпадать у разных объектов и количество значений каждого атрибута равно соответственно количеству объектов.
• Кроме того дан ряд ограничений (15), которые описывают сочетания значений атрибутов (полный текст условия можно прочитать по одной из ссылок в начале статьи).

Необходимо восстановить значения атрибутов всех объектов (или некоторых из них, что в прочем одно и то же), которые бы не противоречили ограничениям.

Первой мыслью был полный перебор вариантов с проверкой выполнения условий задачи, но несложные подсчеты показывают, что количество комбинаций равно
5!5 = 24.883.200.000, что довольно много.

В ходе некоторых размышлений был рожден следующий подход: существует допустимое пространство решений, ограничения описывают подмножества решений, верные решения лежат на пересечении таких подмножеств (т.е. в области, где выполняются все условия).

Следующим шагом было решение описывать подмножества решений в виде набора шаблонов: решений, в которых некоторые атрибуты некоторых объектов фиксированы, а остальные могут принимать любые допустимые значения. А имея такое описание нужно только научиться делать пересечение множеств, описанных таким образом.

Решение

Составляя и переписывая решение на языке Haskell я руководствовался не только желанием найти решение задачи, но и желанием написать понятную программу, которая легко демонстрировала бы как алгоритм так и прекрасный язык Haskell.

Поэтому я старался минимально использовать подходы, мешающие чтение программы неподготовленными людьми. Решение не претендует на полную всеобщность, однако некоторый инструментарий для решения данного класса задач был описан.

Впрочем, читайте сами — я оставил для вас немало комментариев.
Но и вашим комментариям я буду рад.

1.  
2. import Data.List (lookup,nub)
3. import Data.Maybe (fromMaybe,catMaybes)
4.  
5. -----------------------------------------------
6. --            Загадка Эйнштейна              --
7. --                by Atamur                  --
8. -----------------------------------------------
9.  
10. ---------------------------
11. -- Общее описание задачи --
12. ---------------------------
13.  
14. -- Решением задачи является последовательность объектов
15. type Solution = [Object]
16. -- Каждый объект описывается набором пар аттрибутов и их значений
17. type Object = [ (String, String) ]
18.  
19. -- указание пары "атрибут-значение" знаком =:
20. attr =: value = (attr, value)
21.  
22. attributes = ["nationality", "house", "pet", "drink", "smoke"]
23. size = 5
24.  
25. -- Будем решать задачу поиска решения удовлетворяющего некоторым
26. -- ограничениям
27. -- Делать это будем начиная от множества всех решений и постепенно уточняя
28. -- это множество, пока оно не уменьшится до одного решения, которое будет
29. -- верным.
30.  
31. -- Поэтому объект может описывать сразу множество реальных объектов,
32. -- у которых установлены некоторые атрибуты, а остальные (не установленные)
33. -- могут быть любыми. Поэтому пустой объект это шаблон всех возможных
34. -- объектов:
35. anyObject = [] :: Object
36. -- А набор пустых объектов — множество всех решений разади заданой
37. -- размерности:
38. anySolution = [ anyObject | n ← [1..size] ]
39.  
40. -- Каждое решение описывает совместимое множество решений, например решение
41. -- [ ["nationality" =: "Englishman"], anyObject, anyObject ]
42. -- описывает все тройки объектов, первый из которых обладает атрибутом
43. -- "национальность - англичанин"
44. -- Но при уточнении решений нам понадобиться иметь множества несовместимых
45. -- решений (например "англичанин или первый или второй но не одновременно"):
46. type Solutions = [Solution]
47.  
48. empty = [] :: Solutions
49.  
50. -- Для решения задачи нам нужно наложить на решение ограничения
51. -- Каждое ограничение будет трансформировать множество решений
52. -- В результате может получится несколько не связанных множеств или
53. -- пустое множество решений
54. type Restriction = Solution → Solutions
55.  
56. -- применение ограничения к множеству решений
57. -- при трансформировании множества решений будем проверять на
58. -- уникальность значений атрибутов:
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)
68.  
69. -- пересечение двух шаблонов, описывающих объекты
70. -- может быть шаблоном, содержащим атрибуты из обоих исходных шаблонов,
71. -- а может быть несовместимым, если исходные шаблоны содержат разные
72. -- значения одинаковых атрибутов
73. both :: Object → Object → Maybe Object
74. both obj obj' = foldl join (Just []) attributes -- объединяем по-атрибутно
75.   where
76.      -- если имеем уже пустое множество то результат тоже пустой
77.      join Nothing _ = Nothing
78.      -- иначе сравниваем значения органичений по атрибутам
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
88.  
89. -- базовое ограничение — объект в некоторой позиции должен совпадать с
90. -- заданым шаблоном
91. objectAt :: Int → Object → Restriction
92. objectAt n obj solution =
93.     case both obj (solution !! (n - 1)) of
94.         Nothing → empty -- если шаблон не совместим с уже стоящим там
95.         Just res → [ replace n res solution ]
96.     where
97.         replace n x xs = take (n - 1) xs ++ [x] ++ drop n xs
98.  
99. -- Операции над ограничениями ---------------------------------------------
100.  
101. -- пересечение — верны оба ограничения
102. (<&>) rs rs' solution = apply rs (rs' solution)
103. r_all = foldl1 (<&>) -- все ограничения из набора
104.  
105. -- объединение — верно одно или другое
106. (<|>) rs rs' solution = rs solution ++ rs' solution
107. r_any = foldl1 (<|>) -- одно из ограничений
108.  
109. -- Производные ограничения ------------------------------------------------
110.  
111. -- существует некоторый объект (или в первой позиции, или во второй и т.д.)
112. exists obj = r_any [ objectAt n obj | n ← [1..5] ]
113.  
114. -- один объект всегда следует за другим
115. before obj obj' = r_any [
116.     objectAt n obj <&> objectAt (n + 1) obj' | n ← [1..size - 1] ]
117.  
118. -- рядом (или один перед вторым, или второй перед первым)
119. near obj obj' = (obj `before` obj') <|> (obj' `before` obj)
120.  
121. ------------------------------------------------
122. -- Описание огрпничений к конкретной проблеме --
123. ------------------------------------------------
124.  
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.     -- рыбка нигде не фигурирует, надо задать, что она есть
143.  
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
148.  
149. -----------------------------
150. -- Строковые представления --
151. -----------------------------
152.  
153. -- строковое представление человека:
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)
160.  
161. -- строковое представление решения:
162. descrSolution sol = concat [ descrMan man ++ "\n" | man ← sol ]
163.