如何枚舉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)

丑陋，但一起發揮作用。