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

Question

This blog post 对如何使用 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

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 monad 确保选择之间的“公平调度”，使您免于例如infiniteList ++ something，但不阻止无限递归。

---

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

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

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

Answer 2

终于有时间写一个generic的版本了。它使用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))]

我不确定mplus 的分支顺序会发生什么，但我认为如果Omega 正确实施，一切都会解决，我坚信这一点。

---

但是等等！上面的实现还不是没有错误的；它在“左递归”类型上有所不同，如下所示：

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

虽然这有效：

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

我看看能不能解决这个问题。 编辑：在某个时候，这个问题的解决方案可能会在 in this question 找到。

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))

将丢失。

你能找出原因吗？你能改进它吗？

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 的两个特征。首先是Traversable，所以我们可以使用sequenceA来“翻转”Tf和Omega的顺序

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

其中?f :: Omega (Omega T) -> Omega T 就是join。最后一个棘手的问题是找出?g :: Omega (Tf T) -> Omega T。显然，我们并不关心Omega 层，所以我们应该只关心fmap 一个Tf T -> T 类型的函数。

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

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)

丑陋，但功能齐全。