Haskell — глубина для каждого узла в бинарном дереве с использованием монады Reader

Я хочу показать вам, что ваша идея является примером более общей концепции - ziping. Вот версия вашей программы, которая использует более простой и функциональный стиль.

Аппликативные функторы

Вот определение Applicative:

class Functor f => Applicative f where
    pure :: a -> f a
    (<*>) :: f (a -> b) -> f a -> f b

Можно сказать, что тип f x представляет собой структуру f, содержащую некоторые значения x. Функция <*> берет структуру функций (f (a -> b)) и применяет ее к структуре аргументов (f a) для получения структуры результатов (f b).

Быстрые приложения

Один из способов сделать Tree аппликативным функтором — заставить <*> последовательно проходить два дерева, связывая их вместе, как zip работает со списками. Каждый раз, когда вы встречаете Node в дереве функций и Node в дереве аргументов, вы можете извлечь функцию и применить ее к аргументу. Вы должны прекратить движение, когда достигнете основания любого из деревьев.

instance Applicative Tree where
    pure x = let t = Node x t t in t
    Empty <*> _ = Empty
    _ <*> Empty = Empty
    (Node f lf rf) <*> (Node x lx rx) = Node (f x) (lf <*> lx) (rf <*> rx)

instance Functor Tree where
    fmap f x = pure f <*> x  -- as usual

pure x генерирует бесконечное дерево из xs. Это прекрасно работает, потому что Haskell — ленивый язык.

     +-----x-----+
     |           |
  +--x--+     +--x--+
  |     |     |     |
+-x-+ +-x-+ +-x-+ +-x-+
|   | |   | |   | |   |
          etc

Таким образом, форма дерева t <*> pure x такая же, как форма t: вы перестаете двигаться только тогда, когда встречаете Empty, а в pure x их нет. (То же самое относится и к pure x <*> t.)

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

newtype ZipList a = ZipList { getZipList :: [a] }
instance Applicative ZipList where
    pure x = ZipList (repeat x)
    ZipList fs <*> ZipList xs = ZipList (zipWith ($) fs xs)

И снова pure генерирует бесконечное ZipList, а <*> потребляет свои аргументы в режиме блокировки.

Прототипом zippy Applicative, если хотите, является Applicative "читатель" (->) r, который объединяет функции, применяя их все к фиксированному аргументу и собирая результаты. Итак, все функторы Representable допустить (по крайней мере) быстрый экземпляр Applicative.

Использование некоторых Applicative механизмов , мы можем обобщить zip Prelude для любого аппликативного функтора (хотя он будет вести себя точно так же, как zip, только когда Applicative является быстрым по своей природе - например, с обычным экземпляром Applicative для [] zipA даст вам декартово произведение своих аргументов) .

zipA :: Applicative f => f a -> f b -> f (a, b)
zipA = liftA2 (,)

Пометка как застежка-молния

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

depths :: Tree Integer
depths = go 0
    where go n = let t = go (n+1) in Node n t t

Вот как выглядит depths:

     +-----0-----+
     |           |
  +--1--+     +--1--+
  |     |     |     |
+-2-+ +-2-+ +-2-+ +-2-+
|   | |   | |   | |   |
          etc

Теперь, когда мы настроили необходимые структуры, пометить дерево несложно.

labelDepths :: Tree a -> Tree (Integer, a)
labelDepths = zipA depths

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

relabelDepths :: Tree a -> Tree Integer
relabelDepths t = t *> depths

Быстрый тест:

ghci> let myT = Node 'x' (Node 'y' (Node 'z' Empty Empty) (Node 'a' Empty Empty)) (Node 'b' Empty Empty)
ghci> labelDepths myT
Node (0,'x') (Node (1,'y') (Node (2,'z') Empty Empty) (Node (2,'a') Empty Empty)) (Node (1,'b') Empty Empty)

    +--'x'-+                      +--(0,'x')-+
    |      |    labelDepths       |          |
 +-'y'-+  'b'       ~~>      +-(1,'y')-+  (1,'b')
 |     |                     |         |
'z'   'a'                 (2,'z')   (2,'a')

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

data Step = L | R
type Path = [Step]
paths :: Tree Path
paths = go []
    where go path = Node path (go (path ++ [L])) (go (path ++ [R]))

         +--------[ ]--------+
         |                   |
    +---[L]---+         +---[R]---+
    |         |         |         |
+-[L,L]-+ +-[L,R]-+ +-[R,L]-+ +-[R,R]-+
|       | |       | |       | |       |
                  etc

(Неэффективное вложение вызовов ++ выше можно уменьшить с помощью списков различий.)

labelPath :: Tree a -> Tree (Path, a)
labelPath = zipA paths

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

Нет необходимости входить и выходить из Reader так, как вы делаете это здесь, используя runReader; вместо этого вы можете переписать его как

renumberR :: Tree a -> Reader Int (Tree Int)
renumberR (Node _ l r) = do
    x <- ask
    l' <- local (+1) (renumberR l)
    r' <- local (+1) (renumberR r)
    return (Node x l' r')
renumberR Empty = return Empty

Тем не менее, вы можете написать его еще лучше, просто используя аппликативный интерфейс Reader:

renumberR (Node _ l r) =
    Node <$> ask <*> local (+1) (renumberR l) <*> local (+1) (renumberR r)
renumberR Empty = pure Empty

Обратите внимание, что я переименовал вашу функцию в renumberR, чтобы подчеркнуть тот факт, что она работает в Reader, но не обязательно использует монадический интерфейс.