В сентябре на традиционном конкурсе по функциональному программированию, проводимому под эгидой ФП(ФП), была выставлена задача, продолжающая тему адекватности душевного состояния различных субъектов. Но если в августе конкурсанты решали более или менее простую логическую задачу, то на этот раз в условиях было вставлено немного случайности — среди здоровых и психически больных людей затерялся субъект, который «играл» с исследователями, а потому истинность его суждений могла принимать значение как 1, так и 0. В общем, условия задачи были таковы:
Давненько санитарам первой городской больницы уездного города N не приваливало столько работы. Подумать только — город-здравница; город, в который приезжали лечиться со всех концов необъятной страны; город, известный чистотой воздуха, прозрачностью воды; и вдруг — массовое пищевое отравление, причём настолько массовое, что пришлось разворачивать целый палаточный городок, чтобы разместить всех пациентов — 435 человек.
Главный врач был первым, кто заметил неладное — уже к вечеру второго дня. Странные взгляды, которые бросали некоторые пациенты, непонятные смешки, волнами перекатывающиеся по больничному комплексу. На третье утро врачи обнаружили, что ночью часть пациентов оказалась обрита на лысо с выбритым на затылке символом. К обеду пришли известия о том, что среди пострадавших от отравления отдыхающих оказалось и более двух сотен человек, проходивших лечение в различных психиатрических стационарах страны и собранных в городе N в ходе полузасекреченного эксперимента «В здоровом теле — здоровый дух».
Поскольку в ходе госпитализации были допущены некоторые нарушения, то отличить психически здоровых людей от психически нездоровых по документам оказалось невозможно. Единственно доступной информацией является информация, полученная путём опроса пациентов — каждый из них составил список из нескольких человек, в психическом состоянии которых он уверен. Ситуация осложняется тем, что среди пациентов находится и таинственный Доктор X — идеолог и основоположник проекта «В здоровом теле — здоровый дух». Доктор Х, являясь мастером человеческой психики, может гениально изображать любое поведение так, что и нормальные и психически нездоровые пациенты не способны дать ему адекватную оценку, они будут видеть только то, что Доктор Х хочет чтобы они видели. В данном случае Доктор X развлекается и для общения с любым человеком бросает монетку. Точно такой же способ Доктор Х использовал и для заполнения своего листа опросника.
В ходе заполнения этих опросников был обнаружен и дневник Доктора Х, из которого стало ясно что художественно обрил часть пациентов именно он, но о причинах можно только догадываться. Текст, который удалось разобрать гласит — «Сначала здоровые в алфавитном порядке, а потом мои драгоценные пациенты в обратном, построить в 31 колонну по 14 рядов».
Необходимо отметить, что данную задачу и задачу на проверку общности алгоритма разработал, а сам конкурс организовал наш добрый коллега Михаил Байков, который подвизался на поприще коммерческой разработки информационных систем на языке программирования Haskell. Далее представлены его решения для генерации задания и для поиска ответа.
Далее в этой заметке мы рассмотрим модули для генерации задания, для поиска решения, а также два вспомогательных модуля.
Генерация задания
Для генерации условия задачи автор использовал свой модуль, в котором описана монада для генерации случайных последовательностей. Описание данной монады выходит за рамки этой статьи, поэтому заинтересованных читателей можно лишь отправить к исходному коду модуля MonadGen, интерфейс которого выглядит следующим образом:
module MonadGen
(
Gen,
runGen,
evalGen,
withSeedGen,
takeRandom,
shiftGen,
gen,
genFromList
)
where
Начнём разработку модуля. Как обычно — сверху вниз. Функция main в данном случае выглядит очень просто:
main :: IO ()
main = saveTask "fly.txt"
Поскольку предполагалось, что из этого модуля будет компилироваться исполняемый файл, то функция main, которая является точкой входа в программу, сделана в виде обёртки над функцией saveTask. Ну а последняя определена так:
saveTask :: FilePath -> IO ()
saveTask fn = do m <- readFile fn
let (h, task) = withSeedGen 1 (createTask m)
ideas = collectPatientIdeas task
patients = M.elems h
print $ getDoctor h
writeFile (takeWhile (/= '.') fn ++ ".task") $
unlines $
formatPatients ideas patients
Как видно, данная функция открывает файл с картинкой в виде ASCII-арт (она должна быть строго прямоугольной), на основании этой картинки генерирует набор пациентов и сохраняет его в другой файл. Посмотрим, как генерируется список пациентов. Функция createTask определена следующим образом:
createTask :: String -> Gen (Hospital, [(Patient, Int)])
createTask s = do h <- genHospital s
let doctor = getDoctor h
doctorLoops <- getPersonLoops 2 (M.delete (pId doctor) h) doctor
patientLoops <- mapM (p -> getPersonLoops 2 (M.delete (pId p) h) p) (M.elems h)
patientSpikes <- mapM (p -> getPersonSpike (M.delete (pId p) h) p) (M.elems h)
return (h, concat $ doctorLoops ++ concat patientLoops ++ patientSpikes)
Именно эта функция и является основной по генерации условия задачи. Она получает на вход картинку в виде одной большой строки, а возвращает пару вида (госпиталь, список пациентов). Тип Hospital — это всего лишь синоним для всего набора пациентов. Для удобства этот перечень сделан в виде словаря, ключами в котором являются целые числа:
type Hospital = M.IntMap Patient
Ну а тип Patient представляет собой алгебраический тип данных в виде записи с именованными полями:
data PatientType = Sane
| Insane
| Doctor
deriving (Eq, Show)
type Mark = Char
data Patient = Patient
{
pType :: PatientType,
pId :: Int,
pMark :: Mark
}
deriving (Eq, Show)
Возвращаемся к функции createTask. Далее в ней есть вызов функции getDoctor, которая является вспомогательной и используется лишь для того, чтобы найти доктора в словаре. Её определение более или менее тривиально:
getDoctor :: Hospital -> Patient
getDoctor = head . M.elems . M.filter ((== Doctor) . pType)
Все функции к квалификатором M здесь и далее импортированы из модуля Data.IntMap.
Далее — важные функции getPersonSpike и getPersonLoops. Они предназначены для генерации среди всего множества пациентов петель взаимных мнений. Так вторая функция генерирует N петель с заданным пациентом так, чтобы среди них не было пересечений. А первая функция необходима для того, чтобы структура задачи была чуточку интересней, нежели банальные циклы (хоть и с кучей пересечений) — для заданного пациента создаётся мнение о другом произвольном пациенте. Их определения выглядят следующим образом:
getPersonSpike :: Hospital -> Patient -> Gen [(Patient, Int)]
getPersonSpike h p = do (p2, _) <- randPerson h
return [(p, getLinkScore p p2)]
getPersonLoops :: Int -> Hospital -> Patient -> Gen [[(Patient, Int)]]
getPersonLoops 0 _ _ = return []
getPersonLoops l h p = do thisLoop <- getLoopWith p h
let h' = foldl (flip M.delete) h (map (pId . fst) $ tail thisLoop)
restLoops <- getPersonLoops (l - 1) h' p
return $ thisLoop : restLoops
Функция getPersonSpike для заданного пациента p выбирает из всего списка пациентов (госпиталя) случайного и формирует при помощи функции getLinkScore мнение пациента p об этом выбранном пациенте. Её определение таково:
getLinkScore :: Patient -> Patient -> Int
getLinkScore p1 p2 = let t1 = pType p1
t2 = pType p2
in case () of
_ | t1 == Doctor && t2 == Sane -> negate $ pId p2
| t1 == Doctor && t2 == Insane -> pId p2
| t2 == Doctor && t1 == Sane -> pId p2
| t2 == Doctor && t1 == Insane -> negate $ pId p2
| t1 == t2 -> pId p2
| otherwise -> negate (pId p2)
Как видно, здесь используется следующая логика генерации мнения. Доктор X о самом себе говорит, что он здоров. О других пациентах Доктор X говорит так же, как говорят душевнобольные — переворачивает их душевное состояние наоборот. Здесь есть хитрость — никакого «подбрасывания монетки», как об этом сказано в условии, здесь нет. Из-за нарушения симметрии матрицы мнений:
D S I
D + - +
S + + -
I - - +
наличие Доктора X в графе взаимосвязей нарушает согласованность мнений. Именно наличие такой несогласованности позволяет найти Доктора X. Но говорить об этом было нельзя, поскольку в таком случае задача сделалась бы на порядок легче :). Ну а выборка случайного пациента из целого госпиталя делается так:
randPerson :: Hospital -> Gen (Patient, Hospital)
randPerson h = do idx <- ((`rem` M.size h) . abs) `liftM` takeRandom
let personId = M.keys h !! idx
person = h M.! personId
h' = M.delete personId h
return (person, h')
Тут всё просто. Берём случайное число, находящееся в множестве индексов пациентов госпиталя. Из госпиталя выбирается пациент с этим номером, а сам госпиталь обновляется — из него этот пациент как бы удаляется. Пара вида (пациент, новое состояние госпиталя) возвращается в качестве результата. Функция getLoopWith используется для того, чтобы задача решалась в принципе. Надо, чтобы в задаче были циклы с нарушением логики. Чтобы решалось ещё веселей — надо, чтобы в задаче также были циклы без нарушения логики. Эта функция берёт случайного пациента и возвращает цикл из ссылающихся друг на друга пациентов длинной от двух до восьми человек, так чтобы цикл был без повторений. При этом функция добавляет мнение о каждом следующем пациенте. Её определение следующее:
getLoopWith :: Patient -> Hospital -> Gen [(Patient, Int)]
getLoopWith p h
= do len <- genFromList [(1, 0.2), (2, 1.0), (3, 2.5), (4, 2.2), (5, 2.0), (6, 1.0), (7, 0.5)]
otherPatients <- randPersons len (M.delete (pId p) h)
let patients = [p] ++ otherPatients ++ [p]
return $ zipWith (p1 p2 -> (p1, getLinkScore p1 p2)) patients (tail patients)
Тут вот и используется генератор случайных чисел при помощи заданного распределения (функция genFromList из модуля MonadGen). Также в определении этой функции используется функция randPersons, которая выбирает из всего госпиталя N случайных пациентов, так чтобы было без повторений. Её определение таково:
randPersons :: Int -> Hospital -> Gen [Patient]
randPersons 0 _ = return []
randPersons i h = do (p, h') <- randPerson h
rest <- randPersons (i - 1) h'
return $ p : rest
В общем-то, тривиально. Осталось написать определение самой главной функции — функции genHospital, которая, собственно, и генерирует набор пациентов на основании заданной картинки ASCII-арт. В полном соответствии с условиями задачи её определение выглядит так:
genHospital :: String -> Gen Hospital
genHospital f = do let points' = concat . lines $ f
num = length points' + 1
doctorIdx <- (`mod` num) `liftM` takeRandom
let (before, after) = splitAt doctorIdx points'
points = before ++ "W" ++ after
saneStatus <- replicateM num takeRandom
let (saneIds, insaneIds) = partition fst $ zip saneStatus [1..]
ids = saneIds ++ reverse insaneIds
doctorId = snd $ ids !! doctorIdx
markedPats = zipWith applyMark ids points
return $ M.adjust (p -> p { pType = Doctor }) doctorId $ M.fromList $ map (pId &&& id) markedPats
where
applyMark :: (Bool, Int) -> Mark -> Patient
applyMark (isSane, idx) = Patient (if isSane then Sane else Insane) idx
Рассмотрим её подробнее. Для начала строки из файла собираются в одну строку, высчитывается потребное количество пациентов (единица добавляется на Доктора X). Случайным образом выбирается номер Доктора X среди пациентов, после чего входная строка с символами разделяется на две — до и после Доктора, а Доктору на затылке выбривается символ «W» (прихоть или даже причуда автора задачи). Создаётся количество случайных вариантов душевных состояний для всех пациентов. Далее все пациенты разделяются на нормальных и безумных. Список безумных обращается. Ну и, наконец, всем пациентам ставится на затылок соответствующий символ.
Посмотрим, как это работает. Если на вход функции saveTask подать файл со следующим рисунком:
((((c, ,7))))
((((((( ))))))))
((((((( ))))))))
((((((@@@@@@@@@@@))))))))
@@@@@@@@@@@@@@@@)))))))
@@@@@@@@@@@@@@@@@@))))))@@@@
@@/,:::,/,:::,@@@@@@@@@@@@@@
@@|:::::||:::::|@@@@@@@@@@@@@@@
@@':::'/':::'/@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@
/ (
( )
/
то в результате получится файл, содержащий примерно такие строки:
1: ' ', -108, -425, 208, 278, -215, -135, -172, -60, 20, 378
2: ' ', -267, -323, 422, 216, 391, 173, -385, -195, 21, -126, -82, -188, -193, 35, -251
...
435: '@', 71, 264, -131, 158, -178, -390, 399, -426, 225, -227, -246, -353, 350, 266
Всё.
Синтаксический анализатор файла с заданием
Синтаксический анализ входного файла с описанием задания сделаем при помощи библиотеки комбинаторов синтаксического анализа attoparsec. Выбор именно этой библиотеки для такой задачи не обусловлен ничем, кроме привычки автора. С таким же успехом можно было бы воспользоваться библиотеками parsec, или polyparse, или ещё какой-нибудь из многочисленных из имеющихся в архиве Hackage. Библиотека attoparsec хороша тем, что умеет работать с сетевыми протоколами.
Поскольку формат входного файла очень прост, то и синтаксический анализатор для него состоит, по сути, из двух функций. Описывать тут, собственно, нечего:
prsPatients :: Parser [Patient]
prsPatients = many1 prsPatient
Это комбинатор для анализа всего файла. Пропускает одну или более строку, которая анализируется комбинатором prsPatient:
prsPatient :: Parser Patient
prsPatient = do pId <- decimal
_ <- string ": '"
pMark <- anyChar
_ <- string "', "
let status = Unknown
opinions <- fmap (map makeOpinion . nub . sort)
(signed decimal `sepBy` string ", ")
_ <- char 'n'
return Patient {..}
Ну а тут чисто по формату строки с описанием суждения одного пациента. Сначала считываем номер пациента, потом символ, выбритый у него на затылке (при этом пропускаем всякие несущественные разделительные символы, не имеющие отношения к данным), а потом заполняем список суждений. Всё.
Программные сущности для описания пациента
Теперь же перейдём к рассмотрению ещё одного вспомогательного модуля, в котором описаны программные сущности для представления пациента и базовой работы с этим представлением. Это модуль Patient. Модуль этот содержит, в основном, практически те же самые определения для пациентов, что находятся и в рассмотренном ранее модуле Generator. Например, вот определения всех АТД:
data Status = Unknown
| Sane
| Insane
| Doctor
deriving (Eq, Show, Ord, Enum)
data Opinion = Opinion {
opinionId :: !Int,
opinion :: !Status
}
deriving (Eq, Show)
data Patient = Patient {
pId :: !Int,
pMark :: !Char,
status :: !Status,
opinions :: [Opinion]
}
deriving (Eq, Show)
Как видно, здесь добавлено только новое значение для душевного состояния (Unknown — Неизвестное состояние), поскольку нам придётся решать задачу, и такое состояние нам пригодится. Ну и некоторые поля сделаны строгими в целях оптимизации. Об этом, впрочем, задумываться особо смысла нет — можно было бы и не делать поля строгими.
Далее потребуются две функции для смены душевного состояния на противоположеное. Они просты:
flipOpinion :: Opinion -> Opinion
flipOpinion o@Opinion{..} | opinion == Sane = o { opinion = Insane }
| opinion == Insane = o { opinion = Sane }
| otherwise = o
flipSanity :: Patient -> Patient
flipSanity p@Patient{..} | status == Sane = p { status = Insane }
| status == Insane = p { status = Sane }
| otherwise = p
Тут меняется на противоположное только нормальное и психически нездоровое душевное состояния. Неизвестно состояние и Доктор X остаются без изменений. Пригодятся. Ещё пригодятся три функции для установки конкретного значения душевного состояния, кроме неизвестного. Их определения вообще тривиальны:
setSane :: Patient -> Patient
setSane p = p { status = Sane }
setInsane :: Patient -> Patient
setInsane p = p { status = Insane }
setDr :: Patient -> Patient
setDr p = p { status = Doctor }
Наконец, потребуется функция для установки мнения о душевном состоянии некоторого пациента по знаку его номера. Эта функция необходима будет для преобразования входного файла во внутреннее представление. Вот её определение:
makeOpinion :: Int -> Opinion
makeOpinion x | x == 0 = error "invalid makeOpinion"
| x > 0 = Opinion x Sane
| otherwise = Opinion (abs x) Insane
Вот такой небольшой и утилитарный модуль.
Решение задачи
Наконец перейдём к модулю, в котором описано решение поставленной задачи. Надо отметить, что этот модуль писал другой человек, а не уже упомянутый нами Михаил Байков. Автор модуля — Джон Лато. Поэтому внимательный читатель заметит, что стиль написания решения совершенно иной (и хотелось бы сразу предупредить, что ниже много бойлерплейта, но слов из песни не выкинешь :). Тем не менее, рассмотрим этот модуль.
Для начала небольшое вспомогательное определение (ну и тут уже видно дублирование):
type PatientMap = IntMap Patient
Ну и теперь начинаем рассмотреть опять сверху вниз. Самой первой функцией является функция main:
main :: IO ()
main = do let file = "doctor.task"
(width, height) = case file of
"fly.task" -> (31, 14)
"doctor.task" -> (120, 120)
_ -> (80, maxBound)
body <- B.readFile file
case parseOnly prsPatients body of
Left e -> error e
Right ps -> do let pmap = M.fromList $ Prelude.map (p -> (pId p, p)) ps :: PatientMap
case stage pmap of
Nothing -> putStrLn "No solutions found"
Just (pmap, drId) -> do let pmap' = M.delete drId pmap
showPicture width height pmap'
Тут, конечно, небольшой мрак и ужас. Но это опять же издержки того, что модуль будет компилироваться в исполняемый файл для решения, поскольку в режиме интерпретации задача решается уж очень долго. Так что пусть пока остаётся, но универсализировать эту функцию так, чтобы она могла получать имя файла и размеры ASCII-изображения. Ну а остальной код понятен: производится синтаксический анализ и по структуре производится поиск решения. Если решение найдено, на экран выводится изображение.
Как выглядит функция, производящая поиск решения? Вот она:
stage :: PatientMap -> Maybe (PatientMap, Int)
stage pmap = do let solutionList = Prelude.filter (isJust . snd) .
reverse .
withStrategy (parList (evalTuple2 rseq rseq)) .
Prelude.map (key -> (key, solveMap $ M.delete key pmap)) $
keys pmap
case solutionList of
((dr, Just pmap):_) -> Just (update (Just . setDr) dr pmap, dr)
_ -> trace (show solutionList) Nothing
Тоже ничего сложного. Правда, здесь используется немного параллелизации для ускорения решения, но это несложно. Берутся ключи (то есть номера пациентов) из списка всего госпиталя, после чего для каждого производится попытка разрешить его душевное состояние. Все эти попытки делаются в параллельном режиме. В итоге из результата выбираются только те решения, которые существуют. Основная функция здесь — solveMap. Рассмотрим подробнее её определение:
solveMap :: PatientMap -> Maybe PatientMap
solveMap patients = do ((key, keyPatient), _rest) <- minViewWithKey patients
let keyPatient' = setSane keyPatient
map' = M.insert key keyPatient' patients
solve map' [keyPatient']
where
solve pmap [] = return pmap
solve pmap xs = do let allOpinions = concatMap getOpinions xs
pIdsToUpdate = patientsToUpdate pmap allOpinions
pmap' <- setByOpinion allOpinions pmap
solve pmap' (mapMaybe (`M.lookup` pmap') pIdsToUpdate)
getOpinions patient = case status patient of
Insane -> Prelude.map flipOpinion $ opinions patient
Doctor -> error "Нарушение вызова функции getOpinions - Доктор X."
Sane -> opinions patient
Unknown -> error "Нарушение вызова функции getOpinions - Неизвестное состояние."
patientsToUpdate pmap pOpinions =
let pIds = Prelude.map opinionId pOpinions
in mapMaybe (key -> M.lookup key pmap >>=
pCheck -> if status pCheck == Unknown
then return key
else Nothing) pIds
Алгоритм такой. Для заданного списка пациентов ищется тот, у которого минимальный индекс (то есть он стоит выше всех остальных в списке). Этому пациенту устанавливается душевное состояние «Нормальный», после чего делается попытка решить задачу для такого варианта. Решение производится в рекурсивной манере. Собираются все суждения текущего пациента о других пациентах, им устанавливаются варианты душевного состояния в соответствии с душевным состоянием текущего пациента, и для всех них также запускается функция решения.
В ряду функций для решения осталось рассмотреть функцию setByOpinion. Вот её определение:
setByOpinion :: [Opinion] -> PatientMap -> Maybe PatientMap
setByOpinion opinions' pmap = do
let f accMap Opinion{..} =
case M.lookup opinionId accMap of
Just pToChange -> case (opinion, status pToChange) of
(_, Unknown) -> return $ M.insert opinionId
(pToChange { status = opinion })
accMap
(Sane, Insane) -> Nothing
(Insane, Sane) -> Nothing
_ -> return accMap
Nothing -> return accMap
foldM f pmap opinions'
Эта функция находит несоответствия в цепочках суждений пациентов. Если несоответствие найдено, то она возвращает значение Nothing, которое потом является маркером того, что было сделано неправильное предположение. Ну и в списке решений, в соответствии с правилами для монады Maybe всё также останется значение Nothing, которое отфильтруется при составлении окончательного решения.
Наконец, функция вывода ASCII-изображения на экран:
showPicture :: Int -> Int -> PatientMap -> IO ()
showPicture width height pmap = printLines str
where
printLines [] = return ()
printLines str = putStrLn (Prelude.take width str) >> printLines (drop width str)
(sane, insane) = M.partition ((== Sane) . status) pmap
str = map pMark $ M.elems sane ++ reverse (M.elems insane)
Опять же, в соответствии с условиями задачи — разделяем нормальных и безумцев, список безумцев обращаем, выводим строки на экран, производя разделение на строки в соответствии с заданной шириной изображения. Всё.
Заключение
Вот как-то примерно так. Как обычно, все перечисленные в этой заметке модули можно получить по следующим ссылкам:
- Модуль Generator.hs — генерация условий задачи.
- Модуль MonadGen.hs — вспомогательный модуль с описанием генератора случайных последовательностей.
- Модуль Parser.hs — синтаксический анализатор файла с описанием задачи.
- Модуль Patient.hs — программные сущности для описания пациента.
- Модуль Solver.hs — решатель задачи.
В качестве замечаний, которые можно вынести на обсуждение:
- Удалить дублирование кода из модулей
GeneratorиPatient/Solver— вынести дублирование в отдельный модуль (скорее всего, именноPatient). - Удалить весь бойлерплейт из модуля
Solver. - Универсализировать функцию
mainв модулеSolver.
Ну и как обычно хотелось бы поблагодарить всех тех, кто дочитал эту заметку до конца. Все конструктивные комментарии не останутся без ответа :).
Мои предыдущие статьи о конкурсах по ФП на Хаброхабре:
- Решение задачи о перегорающих лампочках на языке Haskell
- Фреймворк для решения задач о переправах на языке Haskell
- Конструирование и вычисление арифметических выражений на языке Haskell
- Расшифровка кода на языке Haskell (конкурс по ФП в январе 2012)
- Шахматные задачи на мат в один ход: решение на языке Haskell
- Измерение объёмов при помощи двух заданных сосудов: решение на языке Haskell
- Трансмутации слов друг в друга: решение на языке Haskell
- Решение арифметических задач — вероятностный подход против регулярных выражений
- Поиск кратчайшего расстояния между точками в трёхмерном пространстве
- Управление лифтами: решение на языке Haskell
- Решение логических задач на языке Haskell: в своём ли уме Валет?
Автор: Darkus
