Haskell. Задача о мудрецах и колпаках

Tazman 22 февраля в 09:21 14,5k
Три мудреца поспорили, кто из них самый мудрый. Чтобы выяснить правду, каждый надел на голову колпак случайного цвета. Каждый мудрец видит цвета колпаков своих оппонентов, но не видит свой собственный. Побеждает тот, кто сможет определить цвет своего колпака.

Так получилось, что все трое вытянули колпаки белого цвета. Мимо проходящий прохожий сообщает им: «на одном из вас надет белый колпак». Через некоторое время самый умный из мудрецов воскликнул: «на мне белый колпак!!!».

Как он об этом догадался?
Существует определенная последовательность рассуждений, которая привела нашего мудреца к верному ответу. Мы попытаемся смоделировать эти рассуждения.

Как же он об этом догадался?

Эту задачу можно сформулировать для любого количества мудрецов. Давайте рассмотрим самый простой вариант.

Сидят два мудреца, на каждом надет белый колпак. Оба знают, что существует, как минимум, один колпак белого цвета. Тогда один из мудрецов рассуждает: «если бы на мне был колпак любого не белого цвета, то мой оппонент уже бы догадался, что белый колпак на нем. Но он молчит. Значит белый колпак на мне!»

Когда мудрецов трое, то один из них рассуждает так: «Если на мне колпак не белого цвета, то второй мудрец будет думать так. … (далее идут рассуждения из задачи про двух мудрецов) ... один из них бы догадался, что белый колпак на нем. Но они оба молчат. Значит мое первое предположение не верно, и на мне белый колпак!»

По индукции мы можем распространить данные рассуждения на любое количество мудрецов. Далее в статье, мы будем моделировать ситуацию с тремя мудрецами.

Формулировка задачи

В нашей изначальной формулировке задача не до конца корректна. Не понятно, сколько должно пройти времени, чтобы сделать вывод, что другой мудрец так и не догадался о цвете своего колпака. Давайте, я переформулирую задачу более корректно.
Имеется трое мудрецов. На каждом надет колпак либо черного, либо белого цвета. Каждый знает цвета своих оппонентов, но не знает свой собственный.

В первый день им сообщают, что существует, как минимум, один белый колпак. Они весь день думают и в конце дня независимо друг от друга голосуют. Они выдают один из двух возможных результатов: «я знаю свой цвет», «я не знаю свой цвет».

На второй день они знакомятся с «результатами голосования» каждого из оппонентов. Затем они снова весь день думают и в конце дня снова голосуют.

и так далее.

Вопрос. Как проголосует каждый из мудрецов в каждый из дней при различных начальных условиях?

Код

Для начала опишем наши основные типы, с которыми мы будем работать.

data Color = Black | White deriving (Show, Eq)

type State = [Color]

fullState :: [State]
fullState = do 
    c1 <- [Black, White]
    c2 <- [Black, White]
    c3 <- [Black, White]
    return [c1, c2, c3]

type StateInfo a = State -> a

stateInfoColor :: Int -> StateInfo Color
stateInfoColor i state = state !! i 

stateInfoAnyWhite :: StateInfo Bool 
stateInfoAnyWhite state = or $ map (\c -> c == White) state  

Состояние нашего мира (какой колпак на ком надет) описывается с помощью типа State. В переменной fullState мы храним список всех возможных состояний.

Тип StateInfo описывает некоторые сведения, которые мы можем вычислить из состояния мира. Например, с помощью stateInfoColor мы можем вычленить цвет колпака для конкретного мудреца. А с помощью stateInfoAnyWhite мы вычисляем, верно ли для данного состояния утверждение, что все колпаки белые.

Далее идут более сложные конструкции.

type Knowledge = State -> (State -> Bool)

knowledgeAbout :: (Eq a) => StateInfo a -> Knowledge 
knowledgeAbout stateInfo state = let info = stateInfo state in \s -> stateInfo s == info 

knowledgeIsTrue :: StateInfo Bool -> Knowledge 
knowledgeIsTrue si _ state = si state 

knowledgeAboutColor1 :: Knowledge  
knowledgeAboutColor1 = knowledgeAbout $ stateInfoColor 0

knowledgeAboutColor2 :: Knowledge  
knowledgeAboutColor2 = knowledgeAbout $ stateInfoColor 1

knowledgeAboutColor3 :: Knowledge  
knowledgeAboutColor3 = knowledgeAbout $ stateInfoColor 2

Тип Knowledge описывает некоторое «знание» о мире. Как мы увидим дальше, тип Knowledge будет по-разному комбинироваться с типом StateInfo. Это очень важный тип. Остановлюсь на нем поподробнее.

Как видно из определения Knowledge, это функция, которая из состояния мира вычисляет некоторую фильтрующую функцию. Т.е. мы передаем «настоящее» состояние мира, а она выдает некоторое подмножество возможных состояний, которые не противоречат нашим знаниям.

Например, функция knowledgeAboutColor1 представляет собой знание о цвете первого мудреца. Если я передам состояние [White, Black, Black], в котором цвет первого мудреца белый, то она вернет функцию, которая отфильтрует все состояния, в котором первый мудрец имеет другой цвет.

У нас не будет специальных структур, обозначающих мудреца. Мы будем рассуждать в терминах «знаний». Вот пример таких рассуждений.

знания первого мудреца в первый день = знание о втором цвете + знание о третьем цвете + знание о том, что один из колпаков белый

знания мудреца на следующий день = знания мудреца в предыдущий день + новые знания


Вот еще несколько вспомогательных функций в терминах Knowledge и StateInfo.

knowledgeAnd :: [Knowledge] -> Knowledge
knowledgeAnd list stateTrue = \s -> and $ map (\f -> f stateTrue s) list    

stateInfoList :: [StateInfo a] -> StateInfo [a]
stateInfoList sil state = map (\si-> si state) sil 

knowledgeImply :: Knowledge -> Knowledge -> StateInfo Bool
knowledgeImply knowledge1 knowledge2 state = and $ map (\(b1, b2) -> not $ and [b1, not b2]) $ map (\s -> (knowledge1 state s, knowledge2 state s)) fullState   

Функция knowledgeAnd просто комбинирует знания в одно.

Действие функции stateInfoList очевидно из её типа.

Третья функция knowledgeImply поинтересней. Это некоторое утверждение о том, что из первого знания вытекает второе знание.

Далее пойдет код, относящийся непосредственно к задаче.

type KnowledgeList = [(Knowledge, Knowledge)]

insightList :: KnowledgeList -> StateInfo [Bool]
insightList knowledgeList = stateInfoList $ map knowledgeInsight knowledgeList 

knowledgeInsight :: (Knowledge, Knowledge) -> StateInfo Bool
knowledgeInsight (currentKnowledge, targetKnowledge) = knowledgeImply currentKnowledge targetKnowledge

manStart_1 = knowledgeAnd [knowledgeAboutColor2, knowledgeAboutColor3, knowledgeAbout stateInfoAnyWhite]
manStart_2 = knowledgeAnd [knowledgeAboutColor1, knowledgeAboutColor3, knowledgeAbout stateInfoAnyWhite]
manStart_3 = knowledgeAnd [knowledgeAboutColor1, knowledgeAboutColor2, knowledgeAbout stateInfoAnyWhite]

knowledgeList_1 :: KnowledgeList
knowledgeList_1 = [(manStart_1, knowledgeAboutColor1), (manStart_2, knowledgeAboutColor2), (manStart_3, knowledgeAboutColor3)]

insightList_1 :: StateInfo [Bool]
insightList_1 = insightList knowledgeList_1 

Тип KnowledgeList — это что-то вроде списка мудрецов. Для каждого мудреца у нас определена пара знаний. Первый элемент — это его текущие знания. Второй элемент — это то, что он пытается выяснить, а именно, цвет своей шляпы.

Функция knowledgeInsight вычисляет, смог ли конкретный мудрец определить свой цвет. Другими словами, вытекают ли знания, к которым он стремится, из тех знаний, которыми он обладает. Используется наша волшебная функция knowledgeImply.

Переменные manStart_1, manStart_2, manStart_3 — это начальные знания соответствующих мудрецов.

Переменная knowledgeList_1 — это список всех мудрецов на первый день (их знания).

Переменная insightList_1 — это результаты голосования в первый день.

Имея результаты голосования, мы можем составить новый список знаний мудрецов.

addNewKnowledge :: Knowledge -> KnowledgeList -> KnowledgeList 
addNewKnowledge newKnowledge knowledgeList = flip map knowledgeList $ \(oldKnowledge, targetKnowledge) -> (knowledgeAnd [oldKnowledge, newKnowledge], targetKnowledge)   

knowledgeList_2 :: KnowledgeList
knowledgeList_2 = addNewKnowledge (knowledgeAbout insightList_1) knowledgeList_1      

insightList_2 :: StateInfo [Bool]
insightList_2 = insightList knowledgeList_2

knowledgeList_3 :: KnowledgeList
knowledgeList_3 = addNewKnowledge (knowledgeAbout insightList_2) knowledgeList_2      

insightList_3 :: StateInfo [Bool]
insightList_3 = insightList knowledgeList_3

С помощью функции addNewKnowledge мы пробегаемся по всем мудрецам и добавляем им новые знания (результаты голосования за предыдущий день).

Повторяя процедуру несколько раз, получаем переменные insightList_1, insightList_2 и insightList_3 — результаты голосований за три дня.

Последний штрих — это вывести результат для конкретного начального состояния.

startState = [White, White, White] 

main = do  
	putStr $ "day 1 result: " ++ (show $ insightList_1 startState) ++ "\n" 
	putStr $ "day 2 result: " ++ (show $ insightList_2 startState) ++ "\n"
	putStr $ "day 3 result: " ++ (show $ insightList_3 startState) ++ "\n"

Результат

Для начала рассмотрим самый сложный и интересный вариант, когда все колпаки белые.

startState = [White, White, White] 
{- result:
day 1 result: [False,False,False]
day 2 result: [False,False,False]
day 3 result: [True,True,True]
-}


В первые два дня мудрецы думали. А на третий день они втроем заявили, что знают свой цвет.

К сожалению, выявить «самого умного» не удалось. Мы предполагаем, что все мудрецы максимально умные и используют всю имеющуюся информацию по полной. В своих рассуждениях они все используют тот факт, что другие мудрецы тоже максимально умные.

Что будет, если один из колпаков будет черным?

startState = [Black, White, White] 
{- result:
day 1 result: [False,False,False]
day 2 result: [False,True,True]
day 3 result: [True,True,True]
-}


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

А вот пример с двумя черными колпаками.

startState = [Black, Black, White] 
{- result:
day 1 result: [False,False,True]
day 2 result: [True,True,True]
day 3 result: [True,True,True]
-}


Как видим, мудрец в белом колпаке на первый же день смог определить свой цвет. И это четкий сигнал для остальных мудрецов, что у них черные колпаки.

Код статьи целиком
data Color = Black | White deriving (Show, Eq)

type State = [Color]

fullState :: [State]
fullState = do 
    c1 <- [Black, White]
    c2 <- [Black, White]
    c3 <- [Black, White]
    return [c1, c2, c3]

type StateInfo a = State -> a

stateInfoColor :: Int -> StateInfo Color
stateInfoColor i state = state !! i 

stateInfoAnyWhite :: StateInfo Bool 
stateInfoAnyWhite state = or $ map (\c -> c == White) state  



-- ===================


type Knowledge = State -> (State -> Bool)


knowledgeAbout :: (Eq a) => StateInfo a -> Knowledge 
knowledgeAbout stateInfo state = let info = stateInfo state in \s -> stateInfo s == info 


knowledgeIsTrue :: StateInfo Bool -> Knowledge 
knowledgeIsTrue si _ state = si state 


knowledgeAboutColor1 :: Knowledge  
knowledgeAboutColor1 = knowledgeAbout $ stateInfoColor 0

knowledgeAboutColor2 :: Knowledge  
knowledgeAboutColor2 = knowledgeAbout $ stateInfoColor 1

knowledgeAboutColor3 :: Knowledge  
knowledgeAboutColor3 = knowledgeAbout $ stateInfoColor 2

-- ===================


knowledgeAnd :: [Knowledge] -> Knowledge
knowledgeAnd list stateTrue = \s -> and $ map (\f -> f stateTrue s) list    

stateInfoList :: [StateInfo a] -> StateInfo [a]
stateInfoList sil state = map (\si-> si state) sil 

knowledgeImply :: Knowledge -> Knowledge -> StateInfo Bool
knowledgeImply knowledge1 knowledge2 state = and $ map (\(b1, b2) -> not $ and [b1, not b2]) $ map (\s -> (knowledge1 state s, knowledge2 state s)) fullState   

-- ==================

   
type KnowledgeList = [(Knowledge, Knowledge)]


insightList :: KnowledgeList -> StateInfo [Bool]
insightList knowledgeList = stateInfoList $ map knowledgeInsight knowledgeList 


knowledgeInsight :: (Knowledge, Knowledge) -> StateInfo Bool
knowledgeInsight (currentKnowledge, targetKnowledge) = knowledgeImply currentKnowledge targetKnowledge


manStart_1 = knowledgeAnd [knowledgeAboutColor2, knowledgeAboutColor3, knowledgeAbout stateInfoAnyWhite]
manStart_2 = knowledgeAnd [knowledgeAboutColor1, knowledgeAboutColor3, knowledgeAbout stateInfoAnyWhite]
manStart_3 = knowledgeAnd [knowledgeAboutColor1, knowledgeAboutColor2, knowledgeAbout stateInfoAnyWhite]


knowledgeList_1 :: KnowledgeList
knowledgeList_1 = [(manStart_1, knowledgeAboutColor1), (manStart_2, knowledgeAboutColor2), (manStart_3, knowledgeAboutColor3)]


insightList_1 :: StateInfo [Bool]
insightList_1 = insightList knowledgeList_1 


-- ===============

addNewKnowledge :: Knowledge -> KnowledgeList -> KnowledgeList 
addNewKnowledge newKnowledge knowledgeList = flip map knowledgeList $ \(oldKnowledge, targetKnowledge) -> (knowledgeAnd [oldKnowledge, newKnowledge], targetKnowledge)   


knowledgeList_2 :: KnowledgeList
knowledgeList_2 = addNewKnowledge (knowledgeAbout insightList_1) knowledgeList_1      



insightList_2 :: StateInfo [Bool]
insightList_2 = insightList knowledgeList_2

knowledgeList_3 :: KnowledgeList
knowledgeList_3 = addNewKnowledge (knowledgeAbout insightList_2) knowledgeList_2      

insightList_3 :: StateInfo [Bool]
insightList_3 = insightList knowledgeList_3

-- =============

startState = [White, White, White] 

main = do  
	putStr $ "day 1 result: " ++ (show $ insightList_1 startState) ++ "\n" 
	putStr $ "day 2 result: " ++ (show $ insightList_2 startState) ++ "\n"
	putStr $ "day 3 result: " ++ (show $ insightList_3 startState) ++ "\n"


Заключение

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

В моем коде количество мудрецов и дней захардкожено. Я специально не стал его обобщать на N мудрецов и N дней, чтобы было понятнее. Возможно, в следующей статье я перепишу его через комонады.
Проголосовать:
+29
Сохранить: