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

Question

这篇博客文章有趣地解释了如何使用Omega monad对角枚举任意语法。 他提供了一个示例，说明了如何执行此操作，从而产生了无限的字符串序列。 我想做同样的事情，除了它不是生成字符串列表，而是生成实际数据类型的列表。 例如，

 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提出了一种更为优雅的解决方案，该方法利用了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
                ]

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

我不确定在mplus的分支顺序中会发生什么，但是我坚信Omega如果正确实施，应该都能解决。

---

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

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

虽然这有效：

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

我看看是否可以解决。 编辑：有时，可能会在此问题中找到此问题的解决方案。

Answer 3

您确实应该向我们展示您到目前为止所做的尝试。 但是理所当然的是，这对于bgeinner而言并非易事。

让我们尝试写下一个朴素的版本：

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 ：我们总能压缩的层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)

丑陋，但一起发挥作用。