atamur Jun 18 2011 at 01:40

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

7 min

7.7K

Прелюдия

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

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

Алгоритм

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

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

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

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

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

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

Решение

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

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

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

import Data.List (lookup,nub) import Data.Maybe (fromMaybe,catMaybes) ----------------------------------------------- -- Загадка Эйнштейна -- -- by Atamur -- ----------------------------------------------- --------------------------- -- Общее описание задачи -- --------------------------- -- Решением задачи является последовательность объектов type Solution = [Object] -- Каждый объект описывается набором пар аттрибутов и их значений type Object = [ (String, String) ] -- указание пары "атрибут-значение" знаком =: attr =: value = (attr, value) attributes = ["nationality", "house", "pet", "drink", "smoke"] size = 5 -- Будем решать задачу поиска решения удовлетворяющего некоторым -- ограничениям -- Делать это будем начиная от множества всех решений и постепенно уточняя -- это множество, пока оно не уменьшится до одного решения, которое будет -- верным. -- Поэтому объект может описывать сразу множество реальных объектов, -- у которых установлены некоторые атрибуты, а остальные (не установленные) -- могут быть любыми. Поэтому пустой объект это шаблон всех возможных -- объектов: anyObject = [] :: Object -- А набор пустых объектов — множество всех решений разади заданой -- размерности: anySolution = [ anyObject | n ← [1..size] ] -- Каждое решение описывает совместимое множество решений, например решение -- [ ["nationality" =: "Englishman"], anyObject, anyObject ] -- описывает все тройки объектов, первый из которых обладает атрибутом -- "национальность - англичанин" -- Но при уточнении решений нам понадобиться иметь множества несовместимых -- решений (например "англичанин или первый или второй но не одновременно"): type Solutions = [Solution] empty = [] :: Solutions -- Для решения задачи нам нужно наложить на решение ограничения -- Каждое ограничение будет трансформировать множество решений -- В результате может получится несколько не связанных множеств или -- пустое множество решений type Restriction = Solution → Solutions -- применение ограничения к множеству решений -- при трансформировании множества решений будем проверять на -- уникальность значений атрибутов: apply :: Restriction → Solutions → Solutions apply restrict sols = concat [ filter (not.duplicates) (restrict solution) | solution ← sols ] where duplicates sols = any duplicateValues (map (values sols) attributes) values sols attr = map (lookup attr) sols duplicateValues vals' = let vals = catMaybes vals' in (vals ≠ nub vals) -- пересечение двух шаблонов, описывающих объекты -- может быть шаблоном, содержащим атрибуты из обоих исходных шаблонов, -- а может быть несовместимым, если исходные шаблоны содержат разные -- значения одинаковых атрибутов both :: Object → Object → Maybe Object both obj obj' = foldl join (Just []) attributes -- объединяем по-атрибутно where -- если имеем уже пустое множество то результат тоже пустой join Nothing _ = Nothing -- иначе сравниваем значения органичений по атрибутам join (Just rest) attr = case (lookup attr obj, lookup attr obj') of ( Nothing, Nothing) → Just rest (Just value, Nothing) → Just ((attr =: value):rest) ( Nothing, Just value ) → Just ((attr =: value):rest) (Just value, Just value') → if value == value' then Just ((attr =: value):rest) else Nothing -- базовое ограничение — объект в некоторой позиции должен совпадать с -- заданым шаблоном objectAt :: Int → Object → Restriction objectAt n obj solution = case both obj (solution !! (n - 1)) of Nothing → empty -- если шаблон не совместим с уже стоящим там Just res → [ replace n res solution ] where replace n x xs = take (n - 1) xs ++ [x] ++ drop n xs -- Операции над ограничениями --------------------------------------------- -- пересечение — верны оба ограничения (<&>) rs rs' solution = apply rs (rs' solution) r_all = foldl1 (<&>) -- все ограничения из набора -- объединение — верно одно или другое (<|>) rs rs' solution = rs solution ++ rs' solution r_any = foldl1 (<|>) -- одно из ограничений -- Производные ограничения ------------------------------------------------ -- существует некоторый объект (или в первой позиции, или во второй и т.д.) exists obj = r_any [ objectAt n obj | n ← [1..5] ] -- один объект всегда следует за другим before obj obj' = r_any [ objectAt n obj <&> objectAt (n + 1) obj' | n ← [1..size - 1] ] -- рядом (или один перед вторым, или второй перед первым) near obj obj' = (obj `before` obj') <|> (obj' `before` obj) ------------------------------------------------ -- Описание огрпничений к конкретной проблеме -- ------------------------------------------------ restrictions = objectAt 1 ["nationality" =: "Norwegian"] <&> exists ["nationality" =: "Englishman", "house" =: "Red"] <&> (["house" =: "Green"] `before` ["house" =: "White"]) <&> exists ["nationality" =: "Dane", "drink" =: "Tea"] <&> (["smoke" =: "Malboro"] `near` ["pet" =: "Cat"]) <&> exists ["smoke" =: "Dunhill", "house" =: "Yellow"] <&> exists ["nationality" =: "German", "smoke" =: "Rothmans"] <&> objectAt 3 ["drink" =: "Milk"] <&> (["smoke" =: "Malboro"] `near` ["drink" =: "Water"]) <&> exists ["smoke" =: "Pallmall", "pet" =: "Bird"] <&> exists ["nationality" =: "Swede", "pet" =: "Dog"] <&> (["nationality" =: "Norwegian"] `near` ["house" =: "Blue"]) <&> exists ["pet" =: "Horse", "house" =: "Blue"] <&> exists ["smoke" =: "Winfield", "drink" =: "Beer"] <&> exists ["house" =: "Green", "drink" =: "Coffee"] <&> exists ["pet" =: "Fish"] -- рыбка нигде не фигурирует, надо задать, что она есть main = let solutions = apply restrictions [anySolution] in if length solutions > 1 then putStrLn ("Total solution sets: " ++ show (length solutions)) else putStrLn $ descrSolution $ head solutions ----------------------------- -- Строковые представления -- ----------------------------- -- строковое представление человека: descrMan man = descr "nationality" ++ " lives in " ++ descr "house" ++ " house, owns " ++ descr "pet" ++ ", drinks " ++ descr "drink" ++ " and smokes " ++ descr "smoke" where descr attr = fromMaybe "?" (lookup attr man) -- строковое представление решения: descrSolution sol = concat [ descrMan man ++ "\n" | man ← sol ]

Tags:

Hubs:

Haskell