Как перечислить рекурсивный тип данных в 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

Ответ 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 обеспечивает "справедливое планирование" среди вариантов, экономя вас от, например, 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
                ]

Ответ 2

Наконец-то я нашел время написать generic. Он использует Universe typeclass, который представляет собой рекурсивно перечислимые типы. Вот он:

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

Я посмотрю, смогу ли я это исправить. EDIT:. В какой-то момент решение этой проблемы можно найти в этом вопросе.

Ответ 3

Вы действительно должны показать нам, что вы пробовали до сих пор. Но предоставлено, это не простая проблема для bgeiner.

Попробуйте написать наивную версию вниз:

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

будет отсутствовать.

Можете ли вы узнать, почему? Можете ли вы его улучшить?

Ответ 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)

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