Из пушек по воробьям. Генерация и решение лабиринта не самым обычным способом21.01.2024 04:15

На уходящей неделе мне попалась симпатичная, хоть и не новая мини‑серия статей на Дзен‑канале @zdgzdgzdg про процедурную генерацию лабиринта методом «коллапса волновой функции». Пока я читал эти статьи и знакомился с кодом, меня осенило: ведь это же вычисления в комонаде, погружённые в монаду! Я не издеваюсь, действительно, речь идёт о композиции двух паттернов функционального программирования: комонаде Zipper, превращающей локальные правила в глобальное состояние, и монаде Random, позволяющей генерировать случайные объекты.

И вот, в качестве баловства на выходных, я решил реализовать этот «квантовый» алгоритм генерации лабиринтов на Haskell, используя и комонады и монады, и вообще, ни в чëм себе не отказывая. И хотя язык программирования Haskell нужен не только для извращений, но именно для них он подходит идеально!

Цель этого мини‑проекта не code‑golf (то есть, максимальное сокращение кода) и не поиск оптимального решения, а proof of concept: демонстрация того, что этот алгоритм действительно вполне естественным образом выражается композицией монады и комонады.

Для тех, кому лень читать, или страшно смотреть код на Haskell, объясню в двух словах суть подхода. Мы детально описываем локальный алгоритм, то есть всë, что касается одного элемента лабиринта, а затем используем «волшебство» комонад и монад и специально подобранные структуры данных для того, чтобы во‑первых, превратить локальный алгоритм в глобальный, то есть, автоматически распространить его на весь, потенциально бесконечный лабиринт, а во‑вторых, гладко протащить через это расширение генерацию случайных чисел. После этого мы используем анаморфизмы и катаморфизмы для того, чтобы отыскать выход из полученного лабиринта.

Генерируем лабиринт

Канонический алгоритм генерации лабиринта недетерминированно заполняет двумерный массив ячеек, изменяя их состояние с учётом состояния соседей и используя элемент случайности. Он хорошо и с картинками описан в указанной выше серии статей и его легко отыскать в YouTube. Случайность, изменяемое состояние, массив с произвольным доступом… такое сочетание для чистого функционального языка программирования это чистое издевательство и повод поменять либо язык,  либо задачу. Но не тут‑то было! Вызов принят!

Поскольку упомянутые мной заумные концепции соответствуют парадигме программирования, управляемого данными (DDD), то начать стоит с данных и их типов.

Элементы будущего лабиринта мы представим четвëркой целых чисел, которые однозначно задают паттерн ячейки. Строковое представление ячеек показывает что я имею в виду:

ц ф-- | Представление квадратной ячейки
type Cell = ( Int, Int
            , Int, Int ) 

showCell :: Cell -> String
showCell = \case
  (1,0,0,0) -> "▀ "
  (0,1,0,0) -> " ▀"
  (0,0,1,0) -> "▄ "
  (0,0,0,1) -> " ▄"
  (1,1,0,0) -> "▀▀"
  (0,1,0,1) -> " █"
  (1,0,1,0) -> "█ "
  (0,0,1,1) -> "▄▄"
  _         -> "  "

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

-- | Представление состояния ячейки
type State = [Cell]     

-- | Список всех валидных состояний клеток лабиринта.
states :: State
states = [ (0,0,0,1), (0,0,1,0)
         , (0,1,0,0), (1,0,0,0)
         , (0,0,1,1), (0,1,0,1)
         , (1,0,1,0), (1,1,0,0) ]

showState :: State -> String
showState = \case
  []  -> "░░"
  [x] -> showCell x
  xs  -> show (length xs) <> " "

Опишем теперь какие состояния сочетаются друг с другом. В упомянутой выше статье для этого использовался словарь, мы же определим простую функцию-предикат:

-- | Представление направления
data Dir = R | L | U | D 
  deriving (Eq, Show)

-- | Предикат смежности для клеток лабиринта по указанным направлениям
adjacent :: Dir -> Cell -> Cell -> Bool
adjacent R (_,a,_,b) (c,_,d,_) = a*c + b*d /= 0
adjacent D (_,_,a,b) (c,d,_,_) = a*c + b*d /= 0
adjacent L a b = adjacent R b a
adjacent U a b = adjacent D b a

Первым аргументом предиката указано направление, вдоль которого происходит стыковка ячеек. Для представления этих направлений определëн простой тип‑перечисление Dir.

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

-- | Детерминистическая часть алгоритма для одной ячейки и её соседей
adjust :: State -> [(Dir, State)] -> State
adjust = \cases
{-1-} []    []  -> []
{-2-} [x]   _   -> [x]
{-3-} []    nbs -> adjust states nbs
{-4-} state nbs -> let
        res = nub [ s | s <- state
                  , (d, nb) <- nbs
                  , any (adjacent d s) nb ]
        in if length res == 8 then [] else res

Эта функция принимает два аргумента: состояние ячейки и список её соседей, с указанием направления к каждому из них. При этом указываются только те соседи, состояние которых хоть как‑то определено. В теле функции описываются четыре варианта поведения в зависимости от состояния клетки и её соседей.

1. Если не определены ни ячейка, ни её окружение, то она остаётся неопределённой.

2. Если ячейка находится в единственном состоянии, то возвращаем это состояние, игнорируя соседей.

3. Если состояние ячейки не определено, но какие‑то из соседей уже частично или полностью коллапсировали, то рассматриваем её состояние как суперпозицию всех возможных состояний.

4. Общий случай, который фильтрует те состояния, которые согласуются с соседями, используя генератор списков, как в Python. При этом если в результат входят все возможные варианты, то мы считаем такое состояние неопределённым.

После того, как число состояний клетки уменьшилось, нам предстоит случайно выбрать один из возможных вариантов. Этим займётся функция collapse:

-- | Стохастическая часть алгоритма для одной ячейки
collapse :: Rational -> State -> Random State
collapse p = \case
{-1-} [x]   -> return [x]
{-2-} []    -> do x <- uniform states
                  fromList [([x], p), ([], 1)]
{-3-} state -> do x <- uniform state
                  return [x]

Она принимает два аргумента: вероятность p и состояние ячейки. При этом возможны три варианта:

1. Если ячейка находится в единственном состоянии, то возвращаем его.

2. Неопределённое состояние может с небольшой вероятностью схлопнуться в одно из возможных состояний. О том, зачем это нужно, я скажу позже.

3. Для суперпозиций состояний мы возвращаем одно из них.

Тип этой функции говорит о том, что её результатом будет не просто состояние ячейки, а случайное. Функция uniform выбирает из списка элемент, считая, что все они распределены равномерно. А функция fromList выбирает случайные элементы с указанными вероятностями.

Поскольку деревья стенок в лабиринте имеют свойство заканчивать свой рост, окружая себя клетками, не имеющими продолжений. Я добавил появление случайных элементов лабиринта, схлопывая неопределённые состояния с некоторой небольшой вероятностью, обратно пропорциональной площади лабиринта. Для этого и используется функция fromList.

Пока всë достаточно просто, если не считать особенностей синтаксиса языка Haskell. Функциональное программирование тут пока ещё не начиналось. Пора, наконец погрузиться в его причудливый мир!

Самое главное свойство функций adjust и collapse состоит в том, что они локальны. Это значит, что они оперируют только состоянием какой‑то одной ячейки и состояниями её непосредственных соседей. Этот паттерн характерен многих задач:

• клеточных автоматов,

• фильтрации сигналов и изображений,

• свëртки и корреляции временных рядов,

• численных методов матфизики (типа метода конечных разностей),

• вычисления таблиц с взаимными ссылками (spreadsheets, как в Lotus или Excell) и так далее.

Однако для решения нашей задачи надо корректно распространить действие функции adjust на всë поле. От структуры данных, которая будет представлять весь массив ячеек лабиринта на этапе генерации, нам, в первую очередь, нужен простой и эффективный доступ к соседям.

Для этого мы воспользуемся не списком списков, а структурой, которая называется зиппером или лентой (Tape). Она представляет собой массив, разделённый на части, относительно курсора — выделенного элемента ленты. В одномерном варианте эта структура определяется двумя бесконечными списками или потоками, представляющими данные, расположенные впереди курсора и позади него.

-- | Бесконечная лента с курсором.
data Tape a = Tape [a] a [a]

-- |  Курсор и его соседи
cursor (Tape _ x _) = x
viscinity (Tape (b:_) _ (f:_)) = (b, f)

-- | Перемещения по ленте
back (Tape (a:as) x bs    ) = Tape as     a (x:bs)
forw (Tape as     x (b:bs)) = Tape (x:as) b bs

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

-- | Инициализатор ленты значением по умолчанию и списком заданных значений
tape :: a -> [a] -> Tape a
tape d xs =
  forw $ Tape (repeat d) d (xs ++ repeat d)

-- | Представление конечного участка ленты в виде списка
takeT :: Int -> Tape a -> [a]
takeT n (Tape _ x xs) = take n (x:xs)

На базе ленты строится двумерная структура, которую мы будем называть полем или решёткой (Grid). Это лента, элементами которой являются другие ленты:

-- | Бесконечное поле с курсором в указанной позиции.
data Grid a = Grid { pos     :: (Int, Int)
                   , getGrid :: Tape (Tape a) }

-- | Инициализатор для поля значением по умолчанию  и списком  заданных значений.
grid :: a -> [[a]] -> Grid a
grid d = Grid (0,0) . tape (tape d []) . fmap (tape d)

-- | Представление конечного участка поля.
takeG :: Int -> Grid a -> [[a]]
takeG n (Grid _ g) = takeT n $ takeT n <$> g

Структура Grid позволяет легко и быстро определить функцию, возвращающую список соседей курсора в формате, необходимом для функции adjust:

-- | Список соседей курсора, ассоциированный с соответствующими направлениями
neigbours :: Grid a -> [(Dir, a)]
neigbours (Grid _ m) =
   [(L, l),(R, r), (D, cursor d), (U, cursor u)]
  where
    (u,d) = viscinity m
    (l,r) = viscinity $ cursor m

Обе описанные нами структуры Tape  и Grid  являются комонадами. С точки зрения программиста, это некий интерфейс, относящийся к типу данных, который позволяет локальную функцию превратить в глобальную, то есть в преобразователь всей структуры по единому локальному правилу.

Реализуя этот интерфейс для произвольной структуры, достаточно определить две функции: extract и duplicate c такими типами:

class Functor w => Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)

class Functor f where
  fmap :: (a -> b) -> f a -> f b

Здесь Functor можно тоже воспринимать, как интерфейс, позволяющий применять ко всем элементам структуры некоторый преобразователь. Вот как типы Tape и Grid реализуют класс Comonad:

deriving instance Functor Tape
deriving instance Functor Grid

instance Comonad Tape where
  extract = cursor
  duplicate = iterateT back forw

instance Comonad Grid where
  extract (Grid _ g) = cursor $ cursor g
  duplicate (Grid p g) =
    fmap (Grid p) $ Grid p $ shift $ shift g
    where
      shift = iterateT (fmap back) (fmap forw)

-- | Итеративный конструктор ленты
iterateT :: (a -> a) -> (a -> a) -> a -> Tape a
iterateT l r x =
  Tape (iterate l (l x)) x (iterate r (r x))

Задача функции duplicate создать множество копий пространства (ленты или решётки) со всеми сдвигами. После этого к эти копиям можно применять локальные функции, которые по каждой из копий саособны вычислить отдельны элементы. В результате этой работы, в нашем распоряжении появляется несколько полезных функций, которые определены для всех комонад. Одна из этих функций имеет вид оператора с таким типом:

(<<=) :: (w a -> a) -> w a -> w a

Это именно то, что там нужно: преобразователь локальной функции в глобальную. В литературе еë обычно называют extend. Вот как с её помощью мы сможем расширить локальную функцию adjust до глобального преобразователя всего поля.

-- | Комонадический вариант функции adjust
adjustG :: Grid State -> State
adjustG x = adjust (extract x) (neigbours x)

Если мы создадим пустое поле m с единственной определённой клеткой лабиринта и вычислим выражение m =>> adjustG то увидим, что клетки окружающие фиксированную ячейку стали менее неопределёнными.

Цифры показывают количество состояний в ячейках. Повторное применение преобразователя увеличивает распространение информации о фиксированной ячейке по полю.

Однако лабиринт так не построишь, рано или поздно, надо будет определяться и фиксировать какие‑то значения из суперпозиции состояний. Для этого мы уже написали локальную функцию collapse. Может быть, её можно превратить в глобальную, просто применив ко всем элементам поля с помощью fmap?

Увы, так просто это сделать не получится, потому что случайность сама по себе нарушает базовые принципы Haskell — функциональность и прозрачность по ссылкам. Первый означает, что результат функции зависит исключительно от входных данных. А следствием второго является то, что в любом месте программы можно заменить вызов функции от фактических аргументов еë результатом, если он уже известен. Генератор псевдослучайных чисел, следующий этому принципу, сможет вернуть лишь одну, возможно, случайную, константу.

Впрочем, это не значит, что все программы на чистом ФП обречены на детерминизм. Генераторы псевдослучайных чисел работают, используя внутреннее состояние и изменяя его. Мы можем один раз передать генератор g при вызове всей программы, а внутри неë использовать его, получая пару (g', x). В этой паре x это псевдослучайное число, а g'— генератор в новом состоянии, вычисленном на основе исходного. Ели нам потребуется не одно, а несколько случайных чисел, обновляемые генераторы можно передавать по цепочке вычислений.

Это хорошо теоретически, но на практике требует прямой передачи генераторов по эстафете от функции к функции, что не только замусоривает код, но и нарушает его модульность — независимость одних частей программы от других.

На помощь приходит концепция монады, которая позволяет с минимальными потерями аккуратно и, главное, явно разделить два мира вычислений: тот, в котором генераторы передаются по эстафете и тот, в котором это не нужно. Кроме того, и саму эстафету монады надёжно прячут так, что мы сохраняя семантику кода, синтаксически еë не наблюдаем.

Взглянем ещё раз на функцию collapse:

-- | Стохастическая часть алгоритма для одной ячейки
collapse :: Rational -> State -> Random State
collapse p = \case
{-1-} [x]   -> return [x]
{-2-} []    -> do x <- uniform states
                  fromList [([x], p), ([], 1)]
{-3-} state -> do x <- uniform state
                  return [x]

Здесь используется конструкция do и левая стрелка <- которыми в Haskell синтаксически оформляются монадические вычисления. Функция uniform для списка значений возвращает одно, но «завёрнутое» в контекст случайности. Далее с этим случайным значением можно производить любые операции, как с нормальной величиной, но при этом мы должны понимать, что результаты уже не смогут просто так избавиться от контекста непредсказуемости.

Таким образом, монада позволяет погружать значения в некоторый контекст (например в котором есть случайные величины), а потом организовывать корректную последовательность вычислений в этом контексте. Побочным результатом таких вычислений является тот или иной эффект или действие. Это тоже очень распространённый паттерн функционального программирования. Примерами контекстов или эффектов могут быть

• Частичные или опциональные значения;

• вычисления с ошибками или исключениями;

• недерминированные вычисления в которых величины могут принимать несколько значений (генераторы списков);

• вычисления с внешней базой данных или с записью в лог или журнал;

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

Подобно комонаде, монады определяются неким интерфейсом: классом Monad. Этот интерфейс может быть реализован определением двух операций  return  и join с такими типами:

-- монада
return :: a -> m a
join :: m (m a) -> m a

Сравните эти три операции с типами операций, определяющих комонаду:

-- комонада
extract :: w a -> a
duplicate :: w a -> w (w a)

Вы можете увидеть определённую симметрию в этих определениях, а именно — они двойственны друг другу. Эта двойственность и объясняет странноватые термины с приставкой «ко‑».

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

(=<<) :: (a -> m a) -> m a -> m a
mapM  :: (a -> m b) -> [a] -> m [a]

Первая, двойственная оператору (<<=), превращает действие над элементом монадической структуры в действие над всей структурой, а вторая (её тип я сильно упростил) позволяет применить монадическое действие к элементам списка, получив список результатов, но уже в монаде.

Нам осталось только превратить локальную монадическую функцию collapse в глобальную, и собрать монадические и комонадические вычисления в один генератор лабиринтов:

-- | Монадический вариант функции collapse
collapseM :: Rational -> Maze -> Random Maze
collapseM p = mapM $ mapM (collapse p)

-- | Генератор случайного лабиринта
buildMaze :: Int  -- ^ Размеры лабиринта 
          -> Int  -- ^ Количество итераций 
          -> Int  -- ^ Глубина рекурсии
          -> IO Maze
buildMaze size n k =
  evalRandIO $ do c <- uniform states
                  build [[[c]]]
  where
    build x = iterate (stepM =<<) (return x) !! n
    recur x = iterate (stepW <<=) (toGrid x) !! k
    stepM x = collapseM p $ toMaze $ recur x
    stepW x = adjust (extract x) (nonempty $ neigbours x)
    nonempty = filter (not . null . snd)
    p = 1/fromIntegral (size^2)
    toGrid = grid []
    toMaze = takeG size

Функция  buildMaze  принимает три параметра: размер лабиринта, количество шагов генерации и глубину рекурсии при схлопывании состояний, за это отвечает число итераций в комонаде.

На каждом шаге генерации мы погружаем поле состояний лабиринта в комонаду Grid, производим вычисления в ней, после чего передаëм поле обновлённых состояний в монаду Random. Результатом этого шага будет новый случайный лабиринт. Для многократного повторения вычислений мы пользуемся операторами (<<=) и (=<<). Функция evalRandomIO запускает вычисления с системной затравкой для ГПСЧ и погружает результат в монаду IO, в которой происходит ввод/вывод и прочее взаимодействие чистой функциональной программы с внешним миром.

В зависимости от параметров генерации мы будем получать лабиринты разной морфологии и древообразности.

Шалость удалась! Генерация лабиринта размером 100×100 занимает на моём ноутбуке от 600 мсек до 2.5 сек в зависимости от глубины раекурсии, что, в общем, вполне неплохо, учитывая, что лабиринт обычно генерируется один раз, а потом либо достраивается, либо используется как есть.

Наряду с монадами, концепция комонад нашла своё применение в разработке приложений со сложной навигацией по древообразным структурам, таким как меню, файловые системы или гипертексты типа XML. На них базируется одна из реализаци так называемых линз — таких функций доступа к элементам сложных структур, которые обладают идеальной функциональной композицией.

Решаем лабиринт

Лабиринт мы запутали монадами и комонадами, а чем бы таким помудрëнее его распутать? Предлагаю для этого воспользоваться двумя двушими взаимно двойственными инструментами: анаморфизмом и катаморфизмом (как вы поняли, я люблю двойственность и морфизмы). А заодно можно продемонстрировать, как организуются вычисления с изменяемым состоянием в языке программирования, в котором это запрещено в принципе.

В прошлой части мы только создавали лабиринты, не заботясь об их дальнейшем использовании. Для перемещений по лабиринту и размещения в нём приманок нам потребуется дополнительный инструментарий. В дополнение к написанному я добавил ряд полезных функций. В-первых, лабиринт надо сделать «плоским», а не собранным из квадратных ячеек:

-- | Разбивает лабиринт на набор отдельных клеток
flatten :: Maze -> Grid Int
flatten = grid 1 . foldMap mkRow
  where
    mkRow =
      map concat . transpose .
      map \case [(a,b,c,d)] -> [[a,b],[c,d]]
                _           -> [[1,1],[1,1]]

Кроме того, нам нужна навигация:

-- | Смещает курсор в указанном направлении
move :: Int -> Dir -> Grid a -> Grid a
move n dir (Grid (a,b) g) =
  Grid p' $ iterate go g !! n
  where
    (p', go) = case dir of
      D -> ((a, b+n), forw)
      U -> ((a, b-n), back)
      R -> ((a+n, b), fmap forw)
      L -> ((a-n, b), fmap back)

-- | Смещает курсор в указанную позицию
moveTo (a, b) = move (abs a) x . move (abs b) y
  where
    x = if a > 0 then R else L
    y = if b > 0 then D else U

-- | Устанавливает значение курсора
set :: a -> Grid a -> Grid a
set x g = Grid p (Tape u (Tape l x r) d)
  where Grid p (Tape u (Tape l _ r) d) = g

-- | Устанавливает значение курсора в указанных координатах
setAt :: (Int, Int) -> a -> Grid a -> Grid a
setAt p x = rewind . set x . moveTo p

-- | Возвращает курсор в начальное положение
rewind :: Grid a -> Grid a
rewind m = moveTo (-a,-b) m
  where (a,b) = pos m

Теперь мы можем раскладывать по лабиринту всякие ценности и опасности, помечая их различными числами и бродить обозревая окрестности. Теперь можно и о морфизмах порассуждать.

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

Дерево мы возьмём стандартное, из библиотеки Data.Tree. Оно имеет структуру «розового куста» в котором из узла выходит целый список веток, произвольной длины, может быть пустой, а может быть и бесконечный.

Обычно, древовидные структуры и строят и обходят с помощью рекурсии. Но сегодня это не наш метод, рекурсию возьмёт на себя и спрячет анаморфизм: абстракция отображение из малого (простого, примитивного, единичного) в большое (сложное, комплексное, обладающее структурой). Содержательная математическая структура не должна быть просто множеством элементов. Она задаëтся конечным набором правил и базовых примитивов, из которых строятся элементы. Полезных примеров структур, к которым применимо использование анаморфизмов, много:

• Индуктивные множества и структуры данных: натуральные числа, списки (ряды, последовательности), деревья и т. п.

• Формальные языки, описываемые порождающими грамматиками;

• Марковские цепи и генеративные сети

• Наконец, комонады, упомянутые выше.

Как видите, в этот широкий класс структур входит много чего полезного. Мы будем строить дерево. Для библиотечных деревьев есть функция unfoldTree с таким типом:

unfoldTree :: (b -> (a, [b])) -> b -> Tree a

Первый аргумент это порождающая функция, которая из некоторого объекта-генератора b порождает узел дерева типа a, и список новых генераторов. Задача анаморфизма unfoldTree превратить генератор в целое дерево. При этом порождающая функция может быть не рекурсивной, всю машинерию и стратегию построения дерева (в ширину или в глубину) берëт на себя анаморфическая функция.

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

-- | Анаморфизм лабиринта в дерево путей
mkTree' :: Grid Int -> Tree ([Dir], Int)
mkTree' m = unfoldTree step (m, [], empty)

step (m, ds, visited) =
  let res = [ (m', d':ds, insert (pos m) visited)
            | (d', n) <- neigbours m
            , n /= 1
            , let m' = move 1 d' m
            , notMember (pos m') visited ]
  in ((ds, extract m), res)

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

Это верное, но плохое решение. Дело в том, что учёт посещённых ячеек лабиринта каждая ветка ведёт сама по себе. Даже на умеренно больших лабиринтах это может привести к комбинаторному взрыву и практическому зависанию программы. Значит, надо как-то сделать множество посещённых клеток общим.

Для этого мы воспользуемся монадой State, позволяющей использовать в вычислениях изменяемое состояние без нарушения функциональности. Это совсем несложно. Достаточно вместо анаморфизма unfoldTree использовать монадический вариант unfoldTreeM и переписать порождающую функцию таким образом:

-- | Монадический анаморфизм лабиринта в дерево путей
mkTree :: Grid Int -> Tree ([Dir], Int)
mkTree m = unfoldTreeM_BF stepM (m, []) `evalState` empty

stepM (m, ds) = do
  visited <- get  -- ^ получаем множество посещённых позиций из контекста
  let res = [ (m', d':ds)
            | (d', n) <- neigbours m
            , n /= 1
            , let m' = move 1 d' m
            , notMember (pos m') visited ]
  modify $ insert (pos m)  -- ^ добавляем текущую позицию в контекст
  return ((ds, extract m), res)

Теперь мы не передаем явно множество уже посещённых ячеек в параметрах функции stepM, а используем это множество, как контекст, запрашивая с помощью функции get и меняя с помощью modify. На самом внешнем контуре вычислений мы передаём пустое множество анаморфизму с помощью функции runState, которая аккуратно производит вычисления в нужном нам контексте и выводит результат из монады.

Теперь можно строить деревья обхода для достаточно больших либиринтов. Но что нам делать с этими деревьями? Если анаморфизм отображал малое в большое, то двойственный ему катаморфизм большую структуру сворачивает в примитив. Классический пример: суммирование элементов списка чисел превращает сложную структуру (список) в простое число. Также ведут себя вычисление максимума, подсчёт количества элементов, поиск конкретного элемента и так далее. Катаморфизм иначе называют свëрткой.

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

toDigits :: Int -> Int -> [Int]
toDigits base = unfoldr step
  where
    step n = case divMod n base of
      (0, 0) -> Nothing
      (r, q) -> Just (q, r)

fromDigits :: Int -> [Int] -> Int
fromDigits base = foldr (\d n -> d + base*n) 0

Но вернёмся к нашим деревьям. Как и для чего нам надо будет их сворачивать? Здесь я мельком упомяну ещё одну математическую концепцию, которая очень помогает в функциональном программировании — полугруппу с единицей или моноид.

Это множество (тип данных), на котором определена некоторая ассоциативная операция (<>) и нейтральный элемент (единица, или mempty). Ассоциативность даëт нам возможность не задумываться о порядке вычислений (но не о порядке операндов), а сосредоточиться на формулировке задачи, решаемой вычислениями. Более того, мы можем определить некий универсальный катаморфизм из сложной структуры в простой моноид и с его помощью решать разные задачи, адресуя их типам ожидаемого результата. Вот что имеется в виду.

Рассмотрим список чисел. Используя универсальный катаморфизм foldMap, и различные типы-моноиды мы можем найти ряд его характеристик:

λ> a = [2,3,1,5,13,2,6,8,4] :: [Int]
λ> foldMap Sum a
Sum {getSum = 44}
λ> foldMap Product a
Product {getProduct = 149760}
λ> foldMap Min a
Min {getMin = 1}
λ> foldMap (Any . odd) a
Any {getAny = True}
λ> foldMap (First . (\x -> if odd x then Just x else Nothing)) a
First {getFirst = Just 3}
λ> foldMap (Last . (\x -> if odd x then Just x else Nothing)) a
Last {getLast = Just 13}

Сами типы Sum, Product, Min, Any, First и Last ничего не вычисляют. Они только помечают числа, обозначая в каком моноиде мы производим свёртку. Конкретная операция определена в реализациях классов Semigroup и Monoid для этих типов. Точно такой же принцип мы можем использовать и для нашего дерева. Вот как можно добывать из нашего дерева пути до цели:

-- | Выделение поддерева путей к указанной цели
pathTo :: Int -> Grid Int -> Tree (Maybe [Dir])
pathTo s =
  fmap (\(p, x) -> if x == s then Just p else Nothing) . mkTree

-- | Катаморфизм дерева в список путей (моноид [])
allPaths :: Int -> Grid Int -> [[Dir]]
allPaths s = foldMap maybeToList . pathTo s

-- | Катаморфизм дерева в первый найденный путь (моноид First)
firstPath :: Int -> Grid Int -> Maybe [Dir]
firstPath s = getFirst . foldMap First . pathTo s

Определив вспомогательный тип Path для путей в лабиринте, и отношение порядка для путей, мы можем выделить кратчайший путь:

newtype Path = Path {getPath :: [Dir]}
  deriving (Eq, Show)

instance Ord Path where
  compare (Path a) (Path b) = comparing length a b

-- | Катаморфизм дерева в кратчайший путь (моноид Min)
shortestPath :: Int -> Grid Int -> Maybe [Dir]
shortestPath s = 
  fmap (getPath . getMin) . foldMap (Min . Path <$>) . pathTo s

Впрочем, использование построение дерева стретегией поиска в ширину приводит к тому, что скорее всего, firstPath вернёт один из минимальных путей по длине.

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

markPath :: Int -> Grid Int -> [Dir] -> Grid Int
markPath x m =
  rewind . foldr (\d -> move 1 d . set x) m

Ну что, осталось только создать тестовый лабиринт и посмотреть, как он решается:

main = do
  maze <- flatten <$> buildMaze n 400 1
  let m = set 0 $ moveTo (-1,0) $ setAt (2*n-1,2*n-1) 2 maze
      path = fromMaybe [] $ firstPath 2 m
      m' = moveTo (-1,-1) $ markPath 3 m path
  mapM_ (putStrLn . concat) $ takeG (2*n+2) $ toChar m'
  where
    n = 12
    toChar = fmap \case
      1 -> "░░"
      2 -> "\ESC[93m██\ESC[0m"
      3 -> "\ESC[31m**\ESC[0m"
      _ -> "  "

Весь проект можно посмотреть и скачать в репозитории https://hub.darcs.net/samsergey/maze

© Habrahabr.ru