Как стать автором
Обновить

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

Haskell *

Прелюдия

Albert_Einstein
Не так давно я прочитал на Хабре статью, которая напомнила мне про интересную головоломку, которую называют «Загадкой Эйнштейна» или «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.  
Теги:
Хабы:
Всего голосов 47: ↑44 и ↓3 +41
Просмотры 6.9K
Комментарии Комментарии 39