这篇博文对如何使用 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
我的第一个丑陋的方法是:
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
]
{-# 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)
我会看看是否可以解决这个问题。
编辑:有时,可能会在这个问题中找到这个问题的解决方案。
让我们尝试写一个简单的版本:
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))
将会失踪。
你能找出原因吗?可以改进一下吗?
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)
丑陋,但都很实用。