Разве можно развестись ленивым, широким первым монадическим розовым деревом?

Ответ 1

Ранее я утверждал, что третье решение, представленное ниже, имеет ту же строгость, что и первая глубина unfoldForest, что неверно.

Ваша интуиция в том, что деревья можно лениво развернуть по ширине, по крайней мере частично исправлена, даже если нам не нужен экземпляр MonadFix. Решения существуют для особых случаев, когда известно, что коэффициент ветвления является конечным, и когда коэффициент ветвления известен как "большой". Начнем с решения, которое выполняется в O(n) времени для деревьев с конечными ветвящимися факторами, включая вырожденные деревья с одним ребенком на node. Решение для конечных факторов ветвления не будет завершено на деревьях с бесконечными факторами ветвления, которые мы исправим решением, которое выполняется в O(n) времени для деревьев с "большими" факторами ветвления, большими, чем единицы, включая деревья с бесконечным коэффициентом ветвления. Решение для "больших" коэффициентов ветвления будет выполняться в O(n^2) времени на вырожденных деревьях с одним ребенком или без детей на node. Когда мы комбинируем методы с обоих этапов в попытке сделать гибридное решение, которое выполняется в O(n) времени для любого коэффициента ветвления, мы получим решение, которое будет более лёгким, чем первое решение для конечных факторов ветвления, но не может вместить деревья, которые создают быстрый переход от бесконечного фактора ветвления к отсутствию ветвей.

Конечный ветвящийся фактор

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

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

import Data.Tree hiding (unfoldTreeM_BF, unfoldForestM_BF)

unfoldForestM_BF :: Monad m => (b->m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF f []    = return []
unfoldForestM_BF f seeds = do
    level <- sequence . fmap f $ seeds
    let (labels, bs) = unzip level
    deeper <- unfoldForestM_BF f (concat bs)
    let forests = trace bs deeper
    return $ zipWith Node labels forests

trace восстанавливает структуру вложенных списков из сплющенного списка. Предполагается, что в [b] есть элемент в каждом элементе в [[a]]. Использование concat... trace, чтобы сгладить всю информацию о уровнях предков, не позволяет этой реализации работать с деревьями с бесконечными дочерними элементами для node.

trace :: [[a]] -> [b] -> [[b]]
trace []       ys = []
trace (xs:xxs) ys =
    let (ys', rem) = takeRemainder xs ys
    in   ys':trace xxs rem
    where
        takeRemainder []        ys  = ([], ys)
        takeRemainder (x:xs) (y:ys) = 
            let (  ys', rem) = takeRemainder xs ys
            in  (y:ys', rem)

Развертывание дерева тривиально писать в терминах разворачивания леса.

unfoldTreeM_BF :: MonadFix m => (b->m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = (>>= return . head) . unfoldForestMFix_BF f . (:[])

Большой коэффициент ветвления

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

import Data.Tree hiding (unfoldForestM_BF, unfoldTreeM_BF)

import Data.Foldable
import Data.Traversable
import Data.Functor.Compose
import Prelude hiding (sequence, foldr)

Вместо того, чтобы сплющить все структуры предков вместе с concat, мы обернем с Compose предками и семенами для следующего уровня и рекурсируем по всей структуре.

unfoldForestM_BF :: (Traversable t, Traceable t, Monad m) =>
                    (b->m (a, [b])) -> t b -> m (t (Tree a))
unfoldForestM_BF f seeds
    | isEmpty seeds = return (fmap (const undefined) seeds)
    | otherwise     = do
        level <- sequence . fmap f $ seeds
        deeper <- unfoldForestM_BF f (Compose (fmap snd level))
        return $ zipWithIrrefutable Node (fmap fst level) (getCompose deeper)

zipWithIrrefutable является более ленивой версией zipWith, которая полагается на предположение, что во втором списке есть элемент во втором элементе в первом списке. Структуры Traceable представляют собой Functors, которые могут обеспечить zipWithIrrefutable. Законы для Traceable для каждого a, xs и ys, если fmap (const a) xs == fmap (const a) ys, затем zipWithIrrefutable (\x _ -> x) xs ys == xs и zipWithIrrefutable (\_ y -> y) xs ys == ys. Его строгость дается для всех f и xs на zipWithIrrefutable f xs ⊥ == fmap (\x -> f x ⊥) xs.

class Functor f => Traceable f where
    zipWithIrrefutable :: (a -> b -> c) -> f a -> f b -> f c 

Мы можем совместить два списка лениво, если мы уже знаем, что они имеют одинаковую структуру.

instance Traceable [] where
    zipWithIrrefutable f []       ys    = []
    zipWithIrrefutable f (x:xs) ~(y:ys) = f x y : zipWithIrrefutable f xs ys 

Мы можем комбинировать состав двух функторов, если мы знаем, что мы можем объединить каждый функтор.

instance (Traceable f, Traceable g) => Traceable (Compose f g) where
    zipWithIrrefutable f (Compose xs) (Compose ys) =
        Compose (zipWithIrrefutable (zipWithIrrefutable f) xs ys)

isEmpty проверяет, что пустая структура узлов расширяется, как совпадение шаблона на [], в решении для конечных факторов ветвления.

isEmpty :: Foldable f => f a -> Bool
isEmpty = foldr (\_ _ -> False) True

Проницательный читатель может заметить, что zipWithIrrefutable из Traceable очень похож на liftA2, который является половиной определения Applicative.

Гибридное решение

Гибридное решение объединяет подходы конечного решения и "большого" решения. Как и конечное решение, мы будем сжимать и декомпрессировать представление дерева на каждом шаге. Подобно решению для "больших" факторов ветвления, мы будем использовать структуру данных, которая позволяет переходить через полные ветки. Для решения конечного разветвляющего фактора использовался тип данных, который сглаживался везде, [b]. В "большом" разветвляющем коэффициенте используется тип данных, который нигде не был сплющен: все больше вложенных списков, начиная с [b], затем [[b]], затем [[[b]]] и т.д. Между этими структурами будут вложенные списки, которые либо остановят вложенность, либо просто удерживают b или удерживают вложенность и удерживают [b] s. Эта схема рекурсии описывается в основном монадой Free.

data Free f a = Pure a | Free (f (Free f a))

Мы будем работать специально с Free [], который выглядит.

data Free [] a = Pure a | Free [Free [] a]

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

import Data.Tree hiding (unfoldTreeM_BF, unfoldForestM_BF)

import Data.Traversable
import Prelude hiding (sequence, foldr)

Поскольку мы будем работать с Free [], мы предоставим ему zipWithIrrefutable.

class Functor f => Traceable f where
    zipWithIrrefutable :: (a -> b -> c) -> f a -> f b -> f c  

instance Traceable [] where
    zipWithIrrefutable f []       ys    = []
    zipWithIrrefutable f (x:xs) ~(y:ys) = f x y : zipWithIrrefutable f xs ys 

instance (Traceable f) => Traceable (Free f) where
    zipWithIrrefutable f (Pure x)  ~(Pure y ) = Pure (f x y)
    zipWithIrrefutable f (Free xs) ~(Free ys) =
        Free (zipWithIrrefutable (zipWithIrrefutable f) xs ys)

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

unfoldFreeM_BF :: (Monad m) => (b->m (a, [b])) -> Free [] b -> m (Free [] (Tree a))
unfoldFreeM_BF f (Free []) = return (Free [])
unfoldFreeM_BF f seeds = do
    level <- sequence . fmap f $ seeds
    let (compressed, decompress) = compress (fmap snd level)
    deeper <- unfoldFreeM_BF f compressed
    let forests = decompress deeper
    return $ zipWithIrrefutable Node (fmap fst level) forests

compress берет Free [], удерживая семена для лесов [b] и выравнивает [b] в Free, чтобы получить Free [] b. Он также возвращает функцию decompress, которая может использоваться для отмены выравнивания, чтобы вернуть исходную структуру. Мы сжимаем ветки без оставшихся семян и ветвей, которые только ветвятся в одну сторону.

compress :: Free [] [b] -> (Free [] b, Free [] a -> Free [] [a])
compress (Pure [x]) = (Pure x, \(Pure x) -> Pure [x])
compress (Pure xs ) = (Free (map Pure xs), \(Free ps) -> Pure (map getPure ps))
compress (Free xs)  = wrapList . compressList . map compress $ xs
    where    
        compressList []                 = ([], const [])
        compressList ((Free [],dx):xs) = let (xs', dxs) = compressList xs
                                         in  (xs', \xs -> dx (Free []):dxs xs)
        compressList (      (x,dx):xs) = let (xs', dxs) = compressList xs
                                         in  (x:xs', \(x:xs) -> dx x:dxs xs)
        wrapList ([x], dxs) = (x,             \x   -> Free (dxs [x]))
        wrapList (xs , dxs) = (Free xs, \(Free xs) -> Free (dxs xs ))

Каждый шаг сжатия также возвращает функцию, которая отменяет ее при применении к дереву Free [] с той же структурой. Все эти функции частично определены; то, что они делают с деревьями Free [] с другой структурой, undefined. Для простоты мы также определяем частичные функции для инверсий Pure и Free.

getPure (Pure x)  = x
getFree (Free xs) = xs

Оба unfoldForestM_BF и unfoldTreeM_BF определяются путем упаковки их аргумента до Free [] b и распаковки результатов, предполагая, что они находятся в одной структуре.

unfoldTreeM_BF :: MonadFix m => (b->m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = (>>= return . getPure) . unfoldFreeM_BF f . Pure


unfoldForestM_BF :: MonadFix m => (b->m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF f = (>>= return . map getPure . getFree) . unfoldFreeM_BF f . Free . map Pure

Более элегантная версия этого алгоритма, вероятно, может быть достигнута путем распознавания того, что >>= для a Monad выполняет трансплантацию на деревьях, а оба Free и FreeT предоставляют экземпляры монады. И compress, и compressList, вероятно, имеют более элегантные презентации.

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

counterExample :: Int -> (Int, [Int])
counterExample 0 = (0, [1, 2])
counterExample 1 = (1, repeat 3)
counterExample 2 = (2, [3])
counterExample 3 = (3, [])

Это дерево будет выглядеть как

0
|
+- 1
|  |
|  +- 3
|  |
|  `- 3
|  |
|  ...
|
`- 2
   |
   +- 3

Попытка спуститься во вторую ветвь (до 2) и проверить оставшееся конечное поддерево не завершится.

Примеры

Следующие примеры демонстрируют, что все реализации unfoldForestM_BF запускают действия в первом порядке по ширине и что runIdentity . unfoldTreeM_BF (Identity . f) имеет ту же строгость, что и unfoldTree для деревьев с конечным коэффициентом ветвления. Для деревьев с фактором inifinite разветвления только решение для "больших" ветвящихся факторов имеет ту же строгость, что и unfoldTree. Чтобы продемонстрировать лень, мы определим три бесконечных дерева - унарное дерево с одной ветвью, двоичное дерево с двумя ветвями и бесконечное дерево с бесконечным количеством ветвей для каждого node.

mkUnary :: Int -> (Int, [Int])
mkUnary x = (x, [x+1])

mkBinary :: Int -> (Int, [Int])
mkBinary x = (x, [x+1,x+2])

mkInfinitary :: Int -> (Int, [Int])
mkInfinitary x = (x, [x+1..])

Вместе с unfoldTree мы определим unfoldTreeDF в терминах unfoldTreeM, чтобы проверить, что unfoldTreeM действительно ленив, как вы утверждали, и unfoldTreeBF в терминах unfoldTreeMFix_BF, чтобы проверить, что новая реализация так же ленивы.

import Data.Functor.Identity

unfoldTreeDF f = runIdentity . unfoldTreeM    (Identity . f)
unfoldTreeBF f = runIdentity . unfoldTreeM_BF (Identity . f)

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

takeWhileTree :: (a -> Bool) -> Tree a -> Tree a
takeWhileTree p (Node label branches) = Node label (takeWhileForest p branches)

takeWhileForest :: (a -> Bool) -> [Tree a] -> [Tree a]
takeWhileForest p = map (takeWhileTree p) . takeWhile (p . rootLabel)

Это позволяет нам определить девять деревьев примеров.

unary   = takeWhileTree (<= 3) (unfoldTree   mkUnary 0)
unaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkUnary 0)
unaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkUnary 0)

binary   = takeWhileTree (<= 3) (unfoldTree   mkBinary 0)
binaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkBinary 0)
binaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkBinary 0)

infinitary   = takeWhileTree (<= 3) (unfoldTree   mkInfinitary 0)
infinitaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkInfinitary 0)
infinitaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkInfinitary 0)

Все пять методов имеют одинаковый вывод для унарных и двоичных деревьев. Выходной сигнал поступает от putStrLn . drawTree . fmap show

0
|
`- 1
   |
   `- 2
      |
      `- 3

0
|
+- 1
|  |
|  +- 2
|  |  |
|  |  `- 3
|  |
|  `- 3
|
`- 2
   |
   `- 3

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

0
|
+- 1
|  |
|  +- 2
|  |  |
|  |  `- 3
|  |
|  `- 3
|
+- 2
|  |
|  `- 3
|
`- 3

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

0
|
+- 1
|  |
|  +- 2
|  |  |
|  |  `- 3
|  |
|  `- 3

Конструкция определенно широта.

mkDepths :: Int -> IO (Int, [Int])
mkDepths d = do
    print d
    return (d, [d+1, d+1])

mkFiltered :: (Monad m) => (b -> Bool) -> (b -> m (a, [b])) -> (b -> m (a, [b]))
mkFiltered p f x = do
    (a, bs) <- f x
    return (a, filter p bs)

binaryDepths = unfoldTreeM_BF (mkFiltered (<= 2) mkDepths) 0

Запуск binaryDepths выводит внешние уровни перед внутренними

0
1
1
2
2
2
2

От ленивого к прямому ленивому

Гибридное решение из предыдущего раздела не достаточно ленив, чтобы иметь такую ​​же строгость семантики, как Data.Tree unfoldTree. Это первый в серии алгоритмов, каждый немного ленивый, чем их предшественник, но не достаточно ленив, чтобы иметь такую ​​же строгость семантики, как unfoldTree.

Гибридное решение не дает гарантии, что изучение части дерева не требует изучения других частей одного и того же дерева. Не будет представлен ниже код. В одном конкретном, но часто встречающемся случае идентифицированном dfeuer, изучение только размера log(N) размера конечного дерева заставляет полностью дерево. Это происходит при изучении последнего потомка каждой ветки дерева с постоянной глубиной. При сжатии дерева мы выбрасываем каждую тривиальную ветвь без потомков, что необходимо, чтобы избежать O(n^2) времени выполнения. Мы можем только лениво пропустить эту часть сжатия, если мы можем быстро показать, что ветвь имеет хотя бы одного потомка, и поэтому мы можем отказаться от шаблона Free []. На самой большой глубине дерева с постоянной глубиной ни одна из ветвей не имеет оставшихся потомков, поэтому мы никогда не сможем пропустить шаг сжатия. Это приводит к изучению всего дерева, чтобы иметь возможность посещать последний node. Когда все дерево на эту глубину не является конечным из-за бесконечного фактора ветвления, исследование части дерева не может завершиться, когда оно завершится при создании unfoldTree.

Шаг сжатия в секции гибридного решения сжимает ветки без потомков в первом поколении, которые они могут быть обнаружены, что является оптимальным для сжатия, но не оптимальным для лени. Мы можем сделать алгоритм более лёгким, задерживаясь при этом сжатии. Если мы отложим его на одно поколение (или даже любое постоянное число поколений), мы будем поддерживать верхнюю границу O(n) во времени. Если мы отложим его на несколько поколений, которые каким-то образом зависят от N, мы обязательно пожертвуем временной привязкой O(n). В этом разделе мы задерживаем сжатие одним поколением.

Чтобы контролировать, как происходит сжатие, мы отделим заполнение самой внутренней [] в структуре Free [] от сдавливания вырожденных ветвей с 0 или 1 потомками.

Поскольку часть этого трюка не работает без большого количества лени в сжатии, мы будем принимать параноидальный уровень чрезмерно ленивой лени во всем мире. Если бы что-либо о результате, отличном от конструктора кортежа (,), можно было бы определить, не форсируя часть его ввода с совпадением шаблонов, мы избежим его форсирования, пока это не понадобится. Для кортежей, что-либо сопоставление шаблонов на них будет делать это лениво. Следовательно, некоторые из приведенных ниже кодов будут выглядеть как ядро ​​или хуже.

bindFreeInvertible заменяет Pure [b,...] на Free [Pure b,...]

bindFreeInvertible :: Free [] ([] b) -> (Free [] b, Free [] a -> Free [] ([] a))
bindFreeInvertible = wrapFree . go
    where
        -- wrapFree adds the {- Free -} that would have been added in both branches
        wrapFree ~(xs, dxs) = (Free xs, dxs)
        go (Pure xs) = ({- Free -} (map Pure xs), Pure . map getPure . getFree)
        go (Free xs) = wrapList . rebuildList . map bindFreeInvertible $ xs
        rebuildList = foldr k ([], const [])
        k ~(x,dx) ~(xs, dxs) = (x:xs, \(~(x:xs)) -> dx x:dxs xs)
        wrapList ~(xs, dxs) = ({- Free -} xs, \(~(Free xs)) -> Free (dxs xs)))

compressFreeList удаляет вхождения Free [] и заменяет Free [xs] на xs.

compressFreeList :: Free [] b -> (Free [] b, Free [] a -> Free [] a)
compressFreeList (Pure x) = (Pure x, id)
compressFreeList (Free xs) = wrapList . compressList . map compressFreeList $ xs
    where
        compressList = foldr k ([], const [])
        k ~(x,dx) ~(xs', dxs) = (x', dxs')
            where
                x' = case x of
                        Free []   -> xs'
                        otherwise -> x:xs'
                dxs' cxs = dx x'':dxs xs''
                    where
                        x'' = case x of
                            Free []   -> Free []
                            otherwise -> head cxs
                        xs'' = case x of
                            Free []   -> cxs
                            otherwise -> tail cxs
        wrapList ~(xs, dxs) = (xs', dxs')
            where
                xs' = case xs of
                        [x]       -> x
                        otherwise -> Free xs
                dxs' cxs = Free (dxs xs'')
                    where
                        xs'' = case xs of
                            [x]       -> [cxs]
                            otherwise -> getFree cxs

Общее сжатие не привяжет Pure [] к Free до тех пор, пока вырожденный Free не будет сжат, задерживая сжатие вырожденного Free, введенное в одно поколение для сжатия следующего поколения.

compress :: Free [] [b] -> (Free [] b, Free [] a -> Free [] [a])
compress xs = let ~(xs' , dxs' ) = compressFreeList xs
                  ~(xs'', dxs'') = bindFreeInvertible xs'
                  in (xs'', dxs' . dxs'')

Из продолженной паранойи помощники getFree и getPure также становятся неопровержимо ленивыми.

getFree ~(Free xs) = xs
getPure ~(Pure x)  = x

Это очень быстро решает проблемный пример, обнаруженный dfeuer

print . until (null . subForest) (last . subForest) $
    flip unfoldTreeBF 0 (\x -> (x, if x > 5 then [] else replicate 10 (x+1)))

Но поскольку мы только задерживали сжатие с помощью генерации 1, мы можем воссоздать точно такую ​​же проблему, если самая последняя node самой последней ветки 1 глубже, чем все остальные ветки.

print . until (null . subForest) (last . subForest) $
    flip unfoldTreeBF (0,0) (\(x,y) -> ((x,y), 
        if x==y
        then if x>5 then [] else replicate 9 (x+1, y) ++ [(x+1, y+1)]
        else if x>4 then [] else replicate 10 (x+1, y)))