我之前声称下面第三个解决方案与深度优先unfoldForest具有相同的严格性，这是不正确的。
你的直觉是树可以懒惰地按广度展开，即使我们不需要MonadFix实例也至少部分正确。对于特殊情况，当分支因子已知为有限时以及当分支因子已知为“大”时，存在解决方案。我们将从一种解决方案开始，该解决方案在包括每个节点只有一个子节点的退化树在内的具有有限分支因子的树中以O(n)时间运行。对于具有无限分支因子的树，有限分支因子的解决方案将无法终止，我们将通过一种解决方案来纠正这一点，该解决方案适用于具有“大于一”的分支因子的树，包括具有无限分支因子的树。具有“大”分支因子的解决方案将在每个节点每个子节点没有或只有一个子节点的退化树上以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 :: [[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 . (:[])
大分支因子
对于大分支因子的解决方案与有限分支因子的解决方案基本相同，唯一的区别在于它保留整个树的结构而不是将每个层级的分支连接成一个列表并跟踪该列表。除了上一节中使用的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结构是可以提供zipWithIrrefutable的Functors。对于每个a、xs和ys的Traceable定律是，如果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
The astute reader may notice that
Traceable 中的
zipWithIrrefutable 与
Applicative 的定义有一半非常相似。
混合解决方案
混合解决方案结合了有限解决方案和“大型”解决方案的方法。像有限解决方案一样，我们将在每个步骤中压缩和解压树形表示。像“大型”分支因素的解决方案一样，我们将使用允许跨完整分支进行步进的数据结构。有限分支因素解决方案使用了一个平铺的数据类型
[b]。 “大型”分支因素解决方案使用了一个未平铺的数据类型：越来越嵌套的列表，从
[b] 开始，然后是
[[b]]，然后是
[[[b]]] 等等。在这些结构之间将是嵌套的列表，它们要么停止嵌套并仅保存
b，要么继续嵌套并保存
[b]。这种递归模式通常由
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 [] 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
一个更加优雅的算法版本可能可以通过认识到对于
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)
为了获取这些无限树的有限部分，甚至是无限分支的树，我们将定义一种方法，只要标签与谓词匹配，就可以从树中获取内容。这可以更简洁地写成能够对每个子树应用函数的能力。请注意保留HTML标签。
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) 时间上界。在本节中，我们将仅将压缩延迟一代。
为了控制压缩的方式，我们将内部的 [] 填充分离到自由[] 结构中，以免压缩掉具有0个或1个后代的退化分支。
因为这个技巧的一部分没有大量的压缩惰性支持就不能工作，所以我们将在任何地方采用过度懒惰的惰性水平。除了元组构造函数 (,) 之外，如果可以确定结果的任何部分而不需要强制执行其输入的模式匹配，则我们将避免强制执行它直到必要时为止。对于元组，任何模式匹配都将进行惰性匹配。因此，下面的某些代码看起来会像核心代码或更糟。
bindFreeInvertible 将 Pure [b,...] 替换为 Free [Pure b,...]
bindFreeInvertible :: Free [] ([] b) -> (Free [] b, Free [] a -> Free [] ([] a))
bindFreeInvertible = wrapFree . go
where
wrapFree ~(xs, dxs) = (Free xs, dxs)
go (Pure xs) = ( (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) = ( 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代，如果最后一个分支的最后一个节点比其他所有分支都深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)))
Node被检查之前，按顺序放置每个级别中m的所有效果。您是否正在寻找一个函数unfoldForestM，使得unfoldForest' f = runIdentity . unfoldForestM (Identity . f)具有与unfoldForest相同的严格语义？ - CirdecControl.Monad.Trans.State.Strict、Control.Monad.ST或IO）无法获得任何东西。但是，是的，你对我对惰性准则一般感觉的描述是正确的。然而，unfoldForestM这个名称已经被一个深度优先展开占用了，它实际上确实具有所需的惰性。 - dfeuerunfoldForst和unfoldForestM_BF在Identity专用情况下的区别？ - PetrunfoldTreeBF f = runIdentity . unfoldTreeM_BF (Identity . f)和一个一元树展开器mkUnary x = (x, [x+1])，则在标签匹配谓词的情况下，树的部分在使用unfoldTree构建树时完全被定义 -takeWhileTree (<= 3) (unfoldTree mkUnary 0)，但在使用unfoldTreeBF构建树时未被定义 -takeWhileTree (<= 3) (unfoldTreeBF mkUnary 0)。请参见我的示例部分以获取takeWhileTree的定义。 - CirdecunfoldTree（\ _ - >（“a”，[1 ..]））1。尝试下降树，取每个节点的第二个孩子。 - dfeuer