Question

This blog post有一个有趣的解释，说明如何使用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确保了公平的调度＆＃34;在选择中，拯救你infiniteList ++ something，但不会阻止无限递归。

Crazy FIZRUK建议使用更优雅的解决方案 Alternative的{{1}}个实例。

Omega

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＆＃39}。现在一些不错的输出：

*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正确实施，那么一切都会成功，我坚信这一点。

但是等等！上面的实现还没有错误;它离开了递归＆＃34;离开递归＆＃34;类型，像这样：

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

虽然这有效：

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

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

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

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

我们可能会考虑添加另外一层＆＃34;

的想法

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

接近正确但有一个缺陷 - 特别是在C分支中，我们最终使两个参数采用完全相同的值而不是能够独立变化。我们可以通过计算＆＃34; base functor＆＃34;来解决这个问题。 T看起来像这样

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

特别是，Tf只是T的副本，其中递归调用是functor＆＃34; hole＆＃34;而不是直接递归调用。现在我们可以写：

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

每个洞中都有一组T的新计算。如果我们可以某种方式＆＃34;压扁＆＃34;将Omega (Tf (Omega T))转换为Omega T然后我们会计算出一个新的＆＃34;一个新图层＆＃34;我们的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来＆＃34;翻转＆＃34; 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)

丑陋，但一切都在起作用。

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

4 个答案: