如何在Haskell中枚举递归数据类型？

Question

这篇博客文章提供了一个有趣的解释，说明如何使用Omega单子枚举任意文法。他提供了一个如何实现它的示例，生成了一个无限序列的字符串。我想做同样的事情，但是，与其生成一系列字符串，我想生成一个实际数据类型的列表。例如，

 data T = A | B T | C T T

会生成

A, B A, C A A, C (B A) A... 

或类似的东西。不幸的是，我的Haskell技能仍在成长中，在玩了几个小时后我无法做到我想要的。该怎么做呢？

按要求，这是我的一次尝试（我尝试了太多的东西...）：

import Control.Monad.Omega

data T = A | B T | C T T deriving (Show)

a = [A] 
        ++ (do { x <- each a; return (B x) })
        ++ (do { x <- each a; y <- each a; return (C x y) })

main = print $ take 10 $ a

- MaiaVictor

---

会在什么条件下生成？你的问题不清楚 - 请不要期望我们阅读你发布的文章并尝试在问题中表达你的问题。 - ScarletAmaranth

@ScarletAmaranth 问题只是如何枚举递归数据类型的可能值。没有太多需要补充的，我只想要一个数据类型可能值的列表... - MaiaVictor

也许为Generics编写一个Universe实例会起作用。 - phipsgabler

Answer 1

我的第一个简陋的方法是：

allTerms :: Omega T
allTerms = do
  which <- each [ 1,2,3 ]
  if which == 1 then
    return A
  else if which == 2 then do
    x <- allTerms
    return $ B x
  else do
    x <- allTerms
    y <- allTerms
    return $ C x y

但是，经过一些整理后，我写出了这个一行代码。

import Control.Applicative
import Control.Monad.Omega
import Control.Monad

allTerms :: Omega T
allTerms = join $ each [return A, B <$> allTerms, C <$> allTerms <*> allTerms]

请注意顺序很重要：return A必须是上面列表中的第一个选择，否则allTerms将不会终止。基本上，Omega单子确保在选择之间进行“公平调度”，使您免受例如infiniteList ++ something的困扰，但不能防止无限递归。

---

Crazy FIZRUK提出了一种更加优雅的解决方案，利用了Omega的Alternative实例。

import Control.Applicative
import Data.Foldable (asum)
import Control.Monad.Omega

allTerms :: Omega T
allTerms = asum [ pure A
                , B <$> allTerms
                , C <$> allTerms <*> allTerms
                ]

- chi

---

太棒了！我差不多就做到了，没想到你这样交替处理。感谢你提供的丑陋版本，否则我可能无法理解它。谢谢！ - MaiaVictor

我认为加上Alternative后这段代码会更好看: enum = pure A <|> B <$> enum <|> C <$> enum <*> enum。其中enum代表一个枚举类型，通过<|>和<$>组合实现了不同情况下的值的构造。 - fizruk

@CrazyFIZRUK 确实！我正在寻找 <|>，但 Omega 没有 Alternative 实例。我相信 x <|> y = join $ each [x,y] 应该可以工作（即使在我看来它不是可结合的）。 - chi

@chi 最新版本中，Omega至少有Alternative（以及MonadPlus）实例：https://hackage.haskell.org/package/control-monad-omega-0.3.1/docs/Control-Monad-Omega.html - fizruk

哦，那个Applicative版本很漂亮。而Alternative版本更加漂亮。请你也能编辑一下吗？ - AndrewC

@AndrewC 我同意。我只是把它包含进来了。 - chi

Answer 2

我终于找到时间写一个通用版本。它使用Universe类型类，表示可递归枚举类型。这是代码：

{-# LANGUAGE DeriveGeneric, TypeOperators, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances, OverlappingInstances #-}

import Data.Universe
import Control.Monad.Omega
import GHC.Generics
import Control.Monad (mplus, liftM2)

class GUniverse f where
    guniverse :: [f a]

instance GUniverse U1 where
    guniverse = [U1]

instance (Universe c) => GUniverse (K1 i c) where
    guniverse = fmap K1 (universe :: [c])

instance (GUniverse f) => GUniverse (M1 i c f) where
    guniverse = fmap M1 (guniverse :: [f p])

instance (GUniverse f, GUniverse g) => GUniverse (f :*: g) where
    guniverse = runOmega $ liftM2 (:*:) ls rs
        where ls = each (guniverse :: [f p])
              rs = each (guniverse :: [g p])

instance (GUniverse f, GUniverse g) => GUniverse (f :+: g) where
    guniverse = runOmega $ (fmap L1 $ ls) `mplus` (fmap R1 $ rs)
        where ls = each (guniverse :: [f p])
              rs = each (guniverse :: [g p])

instance (Generic a, GUniverse (Rep a)) => Universe a where
    universe = fmap to $ (guniverse :: [Rep a x])


data T = A | B T | C T T deriving (Show, Generic)
data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Show, Generic)

我找不到删除UndecidableInstances的方法，但这应该不是什么大问题。只需要使用OverlappingInstances来覆盖预定义的Universe实例，例如Either的实例。现在让我们看一些好的输出：

*Main> take 10 $ (universe :: [T])
[A,B A,B (B A),C A A,B (B (B A)),C A (B A),B (C A A),C (B A) A,B (B (B (B A))),C A (B (B A))]
*Main> take 20 $ (universe :: [Either Int Char])
[Left (-9223372036854775808),Right '\NUL',Left (-9223372036854775807),Right '\SOH',Left (-9223372036854775806),Right '\STX',Left (-9223372036854775805),Right '\ETX',Left (-9223372036854775804),Right '\EOT',Left (-9223372036854775803),Right '\ENQ',Left (-9223372036854775802),Right '\ACK',Left (-9223372036854775801),Right '\a',Left (-9223372036854775800),Right '\b',Left (-9223372036854775799),Right '\t']
*Main> take 10 $ (universe :: [Tree Bool])
[Leaf False,Leaf True,Branch (Leaf False) (Leaf False),Branch (Leaf False) (Leaf True),Branch (Leaf True) (Leaf False),Branch (Leaf False) (Branch (Leaf False) (Leaf False)),Branch (Leaf True) (Leaf True),Branch (Branch (Leaf False) (Leaf False)) (Leaf False),Branch (Leaf False) (Branch (Leaf False) (Leaf True)),Branch (Leaf True) (Branch (Leaf False) (Leaf False))]

我不确定在分支顺序中会发生什么，但如果正确实现了Omega，我认为一切都应该可以解决。

---

但是等等！上面的实现还不完全没有bug；它在“左递归”类型上会发散，比如这个例子：

data T3 = T3 T3 | T3' deriving (Show, Generic)

虽然这个可以工作：

data T6 = T6' | T6 T6 deriving (Show, Generic)

我会尝试修复这个问题。编辑：在某个时候，这个问题的解决方案可能会在这个问题中找到。

- phipsgabler

---

哇，什么！？太棒了。谢谢你。我不明白你对mplus的担忧是什么？ - MaiaVictor

这太棒了。 GHC 只是免费派生所有样板代码！ - Piotr Miś

@Viclib 我的意思是 Branch (Leaf False) (Branch (Leaf False) (Leaf False)) 这个树会比 Branch (Leaf True) (Leaf True) 先出现。Omega 并不是按照字典顺序生成所有的树，而是以一种类似于正方形遍历它们的空间的方式进行遍历。 - phipsgabler

干得好。我认为 mplus 应该可以正常工作：它被定义为 mplus (Omega xs) (Omega ys) = Omega (diagonal [xs,ys])，因此它会粗略地交错这两个列表。 - chi

是的，正是那个“大概”让我感到不爽，我并不怀疑Omega的正确性。 - phipsgabler

Answer 3

你真的应该向我们展示一下你到目前为止尝试过的东西。但是可以理解，这对于一个初学者来说并不是一个容易的问题。

让我们试着写一个朴素版本：

enum = A : (map B enum ++ [ C x y | x <- enum, y <- enum ])

好的，这实际上给了我们：

[A, B A, B (B A), B (B (B A)), .... ]

“并且永远不会达到 C 值。”

“显然，我们需要逐步构建该列表。假设我们已经有了一份完整的项目列表，涵盖了某个嵌套级别，我们可以在一步中计算出比当前嵌套级别多一个级别的项目。”

step xs = map B xs ++ [ C x y | x <- xs, y <- xs ]

例如，我们得到：

> step [A]
[B A,C A A]
> step (step [A])
[B (B A),B (C A A),C (B A) (B A),C (B A) (C A A),C (C A A) (B A),C (C A A) (C A ...

我们想要的是这样的：

[A] ++ step [A] ++ step (step [A]) ++ .....

这是“结果连接”的意思。

iterate step [A]

这当然是。

someT = concat (iterate step [A])

警告：您会注意到这仍然没有给出所有的值。例如：

C A (B (B A))

将其翻译成中文：会缺失。 你能找出原因吗？能否改进它？

- Ingo

---

哦，我一眼就能理解你的解决方案，因为它根本不涉及单子，谢谢！这只留下了两个问题：1. 这是博主所说的对角枚举的同一种吗？2. 如果是，那么为什么那篇博客文章中需要Omega Monad呢？ - MaiaVictor

@Viclib 我还没有阅读这篇文章。请注意我在帖子末尾添加的最后警告。 - Ingo

你确定 C A (B (B A)) 丢失了吗？第一步之后会有 (B A)。第二步之后会有 (B (B A))。所以，第三步之后会有 C A (B (B A))。不是吗？ - MaiaVictor

alternating append 应该有所帮助，enum = A : (map B enum ++/ map (uncurry C) (pairup enum enum)) ; (x:xs) ++/ ys = x:(ys ++/ xs) ; pairup (x:xs) ys = map (x,) ys ++/ pairup xs ys。我期望 C A (B (B A)) 可以实现。（未经测试） - Will Ness

似乎 enum = A, B A, C A A, B (B A), ... 所以 C A (B (B A)) 应该在 enum !! (2+4*3)。 - Will Ness

Answer 4

以下是一个可怕的解决方案，但也许是一个有趣的解决方案。

---

我们可以考虑添加“多一层”的想法。

grow :: T -> Omega T
grow t = each [A, B t, C t t]

代码基本正确但有一个缺陷——特别是在C分支中，我们最终会让两个参数取相同的值而不能独立变化。我们可以通过计算T的“基础函数”来解决这个问题，它看起来像这样：

data T    = A  | B  T | C  T T
data Tf x = Af | Bf x | Cf x x deriving Functor

具体来说，Tf只是T的一个副本，其中递归调用被函数器“洞”取代了直接递归调用。现在我们可以编写：

grow :: Omega T -> Omega (Tf (Omega T))
grow ot = each [ Af, Bf ot, Cf ot ot ]

每个空洞中都有一个全新的T计算。如果我们能够将Omega (Tf (Omega T))“扁平化”为Omega T，那么我们就可以正确地向我们的Omega计算中添加“一个新层”。

flatten :: Omega (Tf (Omega T)) -> Omega T
flatten = ...

我们可以使用fix来获取这种分层的固定点。

fix :: (a -> a) -> a

every :: Omega T
every = fix (flatten . grow)

所以唯一的技巧就是搞清楚 `flatten`。为此，我们需要注意 `Tf` 的两个特点。首先，它是可遍历的，因此我们可以使用 `sequenceA` 来“翻转” `Tf` 和 `Omega` 的顺序。

flatten = ?f . fmap (?g . sequenceA)

其中，?f :: Omega (Omega T) -> Omega T 就是 join。最棘手的部分在于搞清楚 ?g :: Omega (Tf T) -> Omega T。显然，我们不关心 Omega 层，因此我们应该只对类型为 Tf T -> T 的函数进行 fmap。

而这个函数非常接近于 Tf 和 T 之间的关系定义概念：我们总是可以将一层 Tf 压缩到 T 的顶部。

compress :: Tf T -> T
compress Af         = A
compress (Bf t)     = B t
compress (Cf t1 t2) = C t1 t2

总体来说，我们拥有

flatten :: Omega (Tf (Omega T)) -> Omega T
flatten = join . fmap (fmap compress . sequenceA)

外观丑陋，但功能齐全。

- J. Abrahamson