Data.Tree包含unfoldTreeM_BF和unfoldForestM_BF函数使用单子动作的结果构建树的广度优先。使用森林展开器可以轻松编写树展开器，因此我将重点关注后者：
unfoldForestM_BF :: Monad m =>
(b -> m (a, [b])) -> [b] -> m [Tree a]
从种子列表开始，它对每个种子应用一个函数，生成将产生树根和种子的动作，以用于下一层展开。使用的算法有些严格，因此使用unfoldForestM_BFmonadIdentity与使用 pure 并不完全相同unfoldForest。我一直在试图弄清楚是否有办法让它变得懒惰而不牺牲它的O(n)时间限制。如果（正如 Edward Kmett 向我建议的那样）这是不可能的，我想知道是否可以用更受限制的类型来做到这一点，特别是要求MonadFix而不是Monad. 这里的概念是（以某种方式）设置指向未来计算结果的指针，同时将这些计算添加到待办事项列表中，因此如果它们在早期计算的影响中变得懒惰，它们将立即可用。
我之前声称下面介绍的第三种解决方案与 depth-first 具有相同的严格性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上一节中使用的 s 之外，我们将使用 s来组合树的多个层次的函子，Compose以及跨多层次结构的函子。Traversablesequence
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和ysif fmap (const a) xs == fmap (const a) ysthenzipWithIrrefutable (\x _ -> x) xs ys == xs和zipWithIrrefutable (\_ y -> y) xs ys == ys. 它的严格性是为 eachf和xsby给出的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
精明的读者可能会注意到zipWithIrrefutablefromTraceable非常类似于liftA2which is half of 的定义Applicative。
混合解决方案结合了有限解决方案和“大”解决方案的方法。与有限解一样，我们将在每一步压缩和解压缩树表示。像“大”分支因子的解决方案一样，我们将使用允许跨过完整分支的数据结构。有限分支因子解决方案使用了一种随处展平的数据类型，[b]. “大”分支因子解决方案使用了一种在任何地方都无法展平的数据类型：越来越多的嵌套列表从[b]then [[b]]then开始[[[b]]]，依此类推。在这些结构之间将是嵌套列表，它们要么停止嵌套并仅保存 a，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拿 aFree []拿着森林的种子，把[b]它压扁[b]成Freea 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都是通过将它们的参数打包成 aFree [] 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 aMonad是嫁接在树上和两者上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对于具有无限分支因子的树，只有“大”分支因子的解具有与 相同的严格性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's相同的严格语义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
直到退化的 s 被压缩掉之后，整体压缩才会将 s 绑定Pure []到s中，从而将一代中引入的退化 s 的压缩延迟到下一代的压缩中。FreeFreeFree
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)))