Как перечислить рекурсивный тип данных в Haskell?

В этом посте есть интересное объяснение того, как использовать монаду Омега для перечисления произвольной грамматики по диагонали. Он предлагает пример того, как это сделать, что приводит к бесконечной последовательности строк. Я хотел бы сделать то же самое, за исключением того, что вместо генерации списка строк он генерирует список фактических типов данных. Например,

 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

4 ответа

Решение

Мой первый уродливый подход был:

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 Монада обеспечивает "честное планирование" среди вариантов, избавляя вас от, например, infiniteList ++ something, но не мешает бесконечной рекурсии.


Еще более изящное решение было предложено 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
                ]

Я наконец нашел время, чтобы написать общую версию. Он использует 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 "S. Теперь несколько хороших результатов:

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

Некрасиво, но все вместе функционально.

Другие вопросы по тегам