Уровень-порядок repminPrint - PullRequest
Новая
       132

Уровень-порядок repminPrint

4 голосов
/ 14 июля 2020
Проблема

repmin довольно известна. Нам дан тип данных для деревьев: 

data Tree a = Leaf a | Fork (Tree a) a (Tree a) deriving Show

Нам нужно записать функцию (repmin), которая будет брать дерево чисел и заменять все числа в нем на их минимум в за один проход . Также можно распечатать дерево попутно (скажем, это делает функция repminPrint). И repmin, и до, после и по порядку repminPrint можно легко записать с помощью рекурсии значений. Вот пример для упорядоченного repminPrint: 

import Control.Arrow

replaceWithM :: (Tree Int, Int) -> IO (Tree Int, Int)
replaceWithM (Leaf a, m)      = print a >> return (Leaf m, a)
replaceWithM (Fork l mb r, m) = do 
                                  (l', ml) <- replaceWithM (l, m)
                                  print mb
                                  (r', mr) <- replaceWithM (r, m)
                                  return (Fork l' m r', ml `min` mr `min` mb)

repminPrint = loop (Kleisli replaceWithM)

Но что, если мы хотим записать порядок уровней repminPrint вниз?

Я предполагаю, что мы не можем использовать очередь, поскольку нам нужны ml и mr для обновления привязки для m. Я не понимаю, как это могло быть связано с очередью. Я записал пример для level-order Foldable Tree, чтобы показать, что я имею в виду: 

instance Foldable Tree where
 foldr f ini t = helper f ini [t] where
  helper f ini []                 = ini
  helper f ini ((Leaf v) : q      = v `f` helper f ini q
  helper f ini ((Fork l v r) : q) = v `f` (helper f ini (q ++ [l, r]))

Как видите, мы ничего не запускаем на l и r во время текущего рекурсивного вызова .

Итак, как это можно было сделать? Буду признателен за подсказки вместо полных решений.

1 Ответ

1 голос
/ 17 июля 2020

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

data Tree a
  = a :& [Tree a]
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

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

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

unloop :: WriterT a ((->) a) b -> b
unloop m = 
  let (x,w) = runWriterT m w
  in x
      
repmin :: Ord a => Tree a -> Tree a
repmin = unloop . traverse (WriterT .  f)
  where
    f x ~(Just (Min y)) = (y, Just (Min x))

Хотя мы используем версию WriterT с преобразователем монад, конечно, мы не делаем ' Это необходимо, поскольку аппликативы всегда составляют.

Следующий шаг - превратить это в функцию repminPrint: для этого нам понадобится расширение RecursiveDo, которое позволяет нам t ie узел в функции unloop, даже когда мы находимся внутри монады ввода-вывода. 

unloopPrint :: WriterT a (ReaderT a IO) b -> IO b
unloopPrint m = mdo
  (x,w) <- runReaderT (runWriterT m) w
  pure x

repminPrint :: (Ord a, Show a) => Tree a -> IO (Tree a)
repminPrint = unloopPrint . traverse (WriterT . ReaderT . f)
  where
    f x ~(Just (Min y)) = (y, Just (Min x)) <$ print x

Правильно: на этом этапе нам удалось написать версию repminPrint, которая использует любые общие c обход для выполнения функции repmin. Конечно, он все еще в порядке, а не в ширину: 

>>> repminPrint (1 :& [2 :& [4 :& []], 3 :& [5 :& []]])
1
2
4
3
5

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

bft :: Applicative f => (a -> f b) -> Tree a -> f (Tree b)
bft f (x :& xs) = liftA2 (:&) (f x) (bftF f xs)

bftF :: Applicative f => (a -> f b) -> [Tree a] -> f [Tree b]
bftF t = fmap head . foldr (<*>) (pure []) . foldr f [pure ([]:)]
  where
    f (x :& xs) (q : qs) = liftA2 c (t x) q : foldr f (p qs) xs
    
    p []     = [pure ([]:)]
    p (x:xs) = fmap (([]:).) x : xs

    c x k (xs : ks) = ((x :& xs) : y) : ys
      where (y : ys) = k ks

В целом, что делает следующее однопроходным, repminPrint в ширину * с использованием аппликативного обхода : 

unloopPrint :: WriterT a (ReaderT a IO) b -> IO b
unloopPrint m = mdo
  (x,w) <- runReaderT (runWriterT m) w
  pure x

repminPrint :: (Ord a, Show a) => Tree a -> IO (Tree a)
repminPrint = unloopPrint . bft (WriterT . ReaderT . f)
  where
    f x ~(Just (Min y)) = (y, Just (Min x)) <$ print x

>>> repminPrint (1 :& [2 :& [4 :& []], 3 :& [5 :& []]])
1
2
3
4
5
...