问题 懒散的，广度优先的一元玫瑰树是否可能展开？

我之前声称，下面介绍的第三个解决方案与深度优先具有相同的严格性 unfoldForest，这是不正确的。

即使我们不需要，你对树木可以懒散地展开广度的直觉至少也是部分正确的 MonadFix 实例。当已知分支因子是有限的并且已知分支因子是“大”时，存在特殊情况的解决方案。我们将从一个运行的解决方案开始 O(n) 具有有限分支因子的树木的时间，包括退化树，每个节点只有一个子节点。有限分支因子的解决方案将无法在具有无限分支因子的树上终止，我们将使用在其中运行的解决方案来纠正 O(n) “大”分枝因子大于1的树木的时间，包括具有无限分枝因子的树木。 “大”分支因子的解决方案将在 O(n^2) 在每个节点只有一个孩子或没有孩子的退化树上的时间。当我们结合两个步骤中的方法以尝试制作运行的混合解决方案时 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 平展有关祖先级别的所有信息可防止此实现在节点上使用无限子节点的树上工作。

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]秒。这种递归模式一般由 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 ))

每个压缩步骤还返回一个函数，当应用于a时将撤消它 Free [] 具有相同结构的树。所有这些功能都是部分定义的;他们做了什么 Free [] 具有不同结构的树是不确定的。为简单起见，我们还定义了逆的部分函数 Pure 和 Free。

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

都 unfoldForestM_BF 和 unfoldTreeM_BF 通过将他们的论点打包成a来定义 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

可以通过识别该算法来制作更优雅的算法 >>= 为一个 Monad 嫁接树木和两者 Free 和 FreeT 提供monad实例。都 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 对于具有有限分支因子的树。对于具有无限分支因子的树木，只有“大”支化因子的解决方案具有相同的严格性 unfoldTree。为了展示懒惰，我们将定义三个无限树 - 一个带有一个分支的一元树，一个带有两个分支的二叉树，以及一个每个节点都有无数个分支的无限树。

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 []。在具有恒定深度的树的最大深度处，没有任何分支具有任何剩余的后代，因此我们永远不能跳过压缩的步骤。这导致探索整个树以便能够访问最后一个节点。当由于无限分支因子而导致该深度的整个树是非有限的时，探索树的一部分当它由生成时终止时将无法终止。 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直到退化之后 Frees被压缩掉了，延迟了退化的压缩 Frees在一代中引入了下一代的压缩。

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 生成，如果最后一个分支的最后一个节点是，我们可以重新创建完全相同的问题 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)))