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

问题描述 投票：0回答：4

这篇博文对如何使用 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
haskell functional-programming grammar monads
4个回答
8
投票

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

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 ]
6
投票
我终于找到时间来写一个

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)



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



    

    
    
    

    

        

            

                

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



将会失踪。



你能找出原因吗？可以改进一下吗？

    



    

    
    
    

    

        

            

                

                    
3
投票

                    
                

            

        

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






我们可能会考虑添加“一层”的想法



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)



丑陋，但都很实用。

    

	

    

    


  

  

    
最新问题


  





  

    © www.soinside.com 2019 - 2024. All rights reserved.