一棵懒惰的、广度优先的单子玫瑰树展开是否可能？

Question

Data.Tree 包括unfoldTreeM_BF 和unfoldForestM_BF 函数，用于使用单子操作的结果构建树的广度优先。使用森林展开器可以轻松编写树展开器，因此我将重点关注后者：

unfoldForestM_BF :: Monad m =>
             (b -> m (a, [b])) -> [b] -> m [Tree a]

从种子列表开始，它对每个种子应用一个函数，生成将产生树根和种子的操作，以用于下一层展开。使用的算法有些严格，因此使用 unfoldForestM_BF 和 Identity monad 与使用纯 unfoldForest 并不完全相同。我一直试图弄清楚是否有办法让它变得懒惰而不牺牲其O(n) 时间限制。如果（正如 Edward Kmett 向我建议的那样）这是不可能的，我想知道是否可以使用更受限制的类型来做到这一点，特别是需要 MonadFix 而不是 Monad。其概念是（以某种方式）设置指向未来计算结果的指针，同时将这些计算添加到待办事项列表中，因此如果它们在早期计算的影响中懒惰，它们将立即可用。

Answer 1

我之前声称下面提出的第三种解决方案与深度优先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 从扁平列表中重构嵌套列表的结构。假设[[a]] 中的每个项目在[b] 中都有一个项目。使用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 . (:[])

大分支因子

大分支因子的解决方案与有限分支因子的解决方案大致相同，除了它保留树的整个结构而不是concatenating分支在一个级别到单个列表和@ 987654338@ing 该列表。除了上一节中使用的imports，我们将使用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 结构是可以提供zipWithIrrefutable 的Functors。 Traceable 的规则适用于每个 a、xs 和 ys，如果 fmap (const a) xs == fmap (const a) ys 然后是 zipWithIrrefutable (\x _ -> x) xs ys == xs 和 zipWithIrrefutable (\_ y -> y) xs ys == ys。 zipWithIrrefutable f xs ⊥ == fmap (\x -> f x ⊥) xs 对每个f 和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

精明的读者可能会注意到Traceable 中的zipWithIrrefutable 与liftA2 非常相似，这是Applicative 定义的一半。

混合解决方案

混合解决方案结合了有限解决方案和“大型”解决方案的方法。与有限解一样，我们将在每一步压缩和解压缩树表示。像“大”分支因子的解决方案一样，我们将使用允许跨过完整分支的数据结构。有限分支因子解决方案使用了一种随处展平的数据类型，[b]。 “大”分支因子解决方案使用了一种无处展平的数据类型：越来越多的嵌套列表以 [b] 开头，然后是 [[b]] 然后 [[[b]]] 等等。在这些结构之间是嵌套列表，它们要么停止嵌套并仅保存b，要么继续嵌套并保存[b]s。这种递归模式通常由 Free monad 描述。

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 [] 树所做的事情是未定义的。为简单起见，我们还为 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

通过识别>>= for a 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 一起，我们将根据unfoldTreeM 定义unfoldTreeDF，以检查unfoldTreeM 是否真的像您声称的那样懒惰，并根据unfoldTreeMFix_BF 定义unfoldTreeBF，以检查新的实现是一样懒惰。

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 相同的严格语义。

混合解决方案不能保证探索树的一部分不需要探索同一棵树的其他部分。 下面的代码也不会。在一个特殊但常见的情况下，identified by 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 []s 绑定到Frees，直到退化的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)))