Как перечислить рекурсивный тип данных в 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)
Некрасиво, но все вместе функционально.