Возможно ли разворачивать ленивое монадическое розовое дерево первой ширины?
Data.Tree включает в себя unfoldTreeM_BF а также unfoldForestM_BF функции для построения деревьев в ширину, используя результаты монадических действий. Развертывание дерева можно легко записать с помощью развертывания леса, поэтому я сосредоточусь на последнем:
unfoldForestM_BF :: Monad m =>
(b -> m (a, [b])) -> [b] -> m [Tree a]
Начиная со списка семян, он применяет функцию к каждому, генерируя действия, которые будут производить корни деревьев и семена для следующего уровня развертывания. Используемый алгоритм несколько строг, поэтому использование unfoldForestM_BF с Identity монада не совсем то же самое, что использование чистого unfoldForest, Я пытался выяснить, есть ли способ сделать это ленивым, не жертвуя его O(n) ограниченный по времени. Если (как предложил мне Эдвард Кметт) это невозможно, мне интересно, можно ли было бы сделать это более ограниченным типом, конкретно требующим MonadFix скорее, чем Monad, Идея заключается в том, чтобы (каким-то образом) установить указатели на результаты будущих вычислений при добавлении этих вычислений в список дел, поэтому, если они ленивы в результате более ранних вычислений, они будут доступны немедленно.
1 ответ
Ранее я утверждал, что третье решение, представленное ниже, имеет ту же строгость, что и глубина unfoldForest , что не правильно.
Ваша интуиция о том, что деревья вначале могут быть лениво развернуты, по крайней мере, частично верна, даже если нам не требуется MonadFix пример. Решения существуют для особых случаев, когда фактор ветвления известен как конечный и когда фактор ветвления известен как "большой". Мы начнем с решения, которое работает в O(n) время для деревьев с конечными факторами ветвления, включая вырожденные деревья только с одним потомком на узел. Решение для конечных факторов ветвления не будет заканчиваться на деревьях с бесконечными факторами ветвления, которые мы исправим решением, которое работает в O(n) время для деревьев с "большими" факторами ветвления больше единицы, включая деревья с бесконечным фактором ветвления. Решение для "больших" факторов ветвления будет работать в O(n^2) время на вырожденных деревьях только с одним ребенком или без детей на узел. Когда мы объединяем методы из обоих шагов в попытке сделать гибридное решение, которое работает в O(n) Время для любого фактора ветвления, мы получим решение, которое является более ленивым, чем первое решение для конечных факторов ветвления, но не может вместить деревья, которые делают быстрый переход от бесконечного фактора ветвления к отсутствию ветвей.
Конечный фактор ветвления
Общая идея заключается в том, что сначала мы создадим все метки для всего уровня и семена для лесов для следующего уровня. Затем мы спустимся на следующий уровень, построив все это. Мы соберем вместе результаты с более глубокого уровня, чтобы построить леса для внешнего уровня. Мы будем ставить метки вместе с лесами, чтобы построить деревья.
unfoldForestM_BF это довольно просто. Если для уровня нет семян, он возвращается. После создания всех меток, он берет семена для каждого леса и собирает их вместе в один список всех семян, чтобы построить следующий уровень и разворачивает весь более глубокий уровень. Наконец, он строит лес для каждого дерева из структуры семян.
import Data.Tree hiding (unfoldTreeM_BF, unfoldForestM_BF)
unfoldForestM_BF :: Monad m => (b->m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF f [] = return []
unfoldForestM_BF f seeds = do
level <- sequence . fmap f $ seeds
let (labels, bs) = unzip level
deeper <- unfoldForestM_BF f (concat bs)
let forests = trace bs deeper
return $ zipWith Node labels forests
trace реконструирует структуру вложенных списков из плоского списка. Предполагается, что в [b] для каждого из предметов в любом месте [[a]], Использование concat... trace Сглаживание всей информации об уровнях предков не позволяет этой реализации работать на деревьях с бесконечными дочерними элементами для узла.
trace :: [[a]] -> [b] -> [[b]]
trace [] ys = []
trace (xs:xxs) ys =
let (ys', rem) = takeRemainder xs ys
in ys':trace xxs rem
where
takeRemainder [] ys = ([], ys)
takeRemainder (x:xs) (y:ys) =
let ( ys', rem) = takeRemainder xs ys
in (y:ys', rem)
Развертывание дерева - это тривиально, если говорить о развертывании леса.
unfoldTreeM_BF :: MonadFix m => (b->m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = (>>= return . head) . unfoldForestMFix_BF f . (:[])
Большой фактор ветвления
Решение для большого фактора ветвления происходит во многом так же, как решение для конечного фактора ветвления, за исключением того, что вместо структуры сохраняется вся структура дерева. concat введение ветвей на уровне в один список и trace в этом списке. В добавок к import S используется в предыдущем разделе, мы будем использовать Compose составить функторы для нескольких уровней дерева вместе и Traversable в sequence через многоуровневые структуры.
import Data.Tree hiding (unfoldForestM_BF, unfoldTreeM_BF)
import Data.Foldable
import Data.Traversable
import Data.Functor.Compose
import Prelude hiding (sequence, foldr)
Вместо того, чтобы сгладить все структуры предка вместе с concat мы завернем с Compose предки и семена для следующего уровня и рекурсии по всей структуре.
unfoldForestM_BF :: (Traversable t, Traceable t, Monad m) =>
(b->m (a, [b])) -> t b -> m (t (Tree a))
unfoldForestM_BF f seeds
| isEmpty seeds = return (fmap (const undefined) seeds)
| otherwise = do
level <- sequence . fmap f $ seeds
deeper <- unfoldForestM_BF f (Compose (fmap snd level))
return $ zipWithIrrefutable Node (fmap fst level) (getCompose deeper)
zipWithIrrefutable более ленивая версия zipWith это основывается на предположении, что во втором списке есть элемент для каждого элемента в первом списке. Traceable структуры являются Functors что может обеспечить zipWithIrrefutable, Законы для Traceable для каждого a, xs, а также ys если fmap (const a) xs == fmap (const a) ys затем zipWithIrrefutable (\x _ -> x) xs ys == xs а также zipWithIrrefutable (\_ y -> y) xs ys == ys, Его строгость дана для каждого f а также xs от zipWithIrrefutable f xs ⊥ == fmap (\x -> f x ⊥) xs,
class Functor f => Traceable f where
zipWithIrrefutable :: (a -> b -> c) -> f a -> f b -> f c
Мы можем лениво объединить два списка, если уже знаем, что они имеют одинаковую структуру.
instance Traceable [] where
zipWithIrrefutable f [] ys = []
zipWithIrrefutable f (x:xs) ~(y:ys) = f x y : zipWithIrrefutable f xs ys
Мы можем объединить композицию из двух функторов, если знаем, что можем объединить каждый функтор.
instance (Traceable f, Traceable g) => Traceable (Compose f g) where
zipWithIrrefutable f (Compose xs) (Compose ys) =
Compose (zipWithIrrefutable (zipWithIrrefutable f) xs ys)
isEmpty проверяет, чтобы пустая структура узлов расширялась, как в случае совпадения шаблона [] сделал в решении для конечных факторов ветвления.
isEmpty :: Foldable f => f a -> Bool
isEmpty = foldr (\_ _ -> False) True
Проницательный читатель может заметить, что zipWithIrrefutable от Traceable очень похоже на liftA2 что составляет половину определения Applicative,
Гибридное решение
Гибридное решение сочетает в себе подходы конечного решения и "большого" решения. Как и конечное решение, мы будем сжимать и распаковывать представление дерева на каждом шаге. Как и решение для "больших" факторов ветвления, мы будем использовать структуру данных, которая позволяет переходить через целые ветви. Решение с конечным коэффициентом ветвления использует тип данных, который сглаживается повсюду, [b], В "большом" решении с коэффициентом ветвления использовался тип данных, который нигде не был сведен: все больше и больше вложенных списков начинаются с [b] затем [[b]] затем [[[b]]] и так далее. Между этими структурами будут вложенные списки, которые либо прекратят вкладывать, либо просто сохранят b или продолжайте гнездиться и держать [b] s. Эта схема рекурсии описывается в целом Free монада.
data Free f a = Pure a | Free (f (Free f a))
Мы будем работать конкретно с Free [] который выглядит как
data Free [] a = Pure a | Free [Free [] a]
Для гибридного решения мы повторим все его импорт и компоненты, так что приведенный ниже код должен быть полным рабочим кодом.
import Data.Tree hiding (unfoldTreeM_BF, unfoldForestM_BF)
import Data.Traversable
import Prelude hiding (sequence, foldr)
Так как мы будем работать с Free [] мы предоставим zipWithIrrefutable,
class Functor f => Traceable f where
zipWithIrrefutable :: (a -> b -> c) -> f a -> f b -> f c
instance Traceable [] where
zipWithIrrefutable f [] ys = []
zipWithIrrefutable f (x:xs) ~(y:ys) = f x y : zipWithIrrefutable f xs ys
instance (Traceable f) => Traceable (Free f) where
zipWithIrrefutable f (Pure x) ~(Pure y ) = Pure (f x y)
zipWithIrrefutable f (Free xs) ~(Free ys) =
Free (zipWithIrrefutable (zipWithIrrefutable f) xs ys)
Первый обход в ширину будет очень похож на оригинальную версию для конечного ветвящегося дерева. Мы строим текущие метки и начальные значения для текущего уровня, сжимаем структуру оставшейся части дерева, выполняем всю работу для оставшихся глубин и распаковываем структуру результатов, чтобы леса соответствовали меткам.
unfoldFreeM_BF :: (Monad m) => (b->m (a, [b])) -> Free [] b -> m (Free [] (Tree a))
unfoldFreeM_BF f (Free []) = return (Free [])
unfoldFreeM_BF f seeds = do
level <- sequence . fmap f $ seeds
let (compressed, decompress) = compress (fmap snd level)
deeper <- unfoldFreeM_BF f compressed
let forests = decompress deeper
return $ zipWithIrrefutable Node (fmap fst level) forests
compress занимает Free [] держа семена для леса [b] и выравнивает [b] в Free чтобы получить Free [] b, Это также возвращает decompress функция, которая может быть использована для отмены выравнивания, чтобы вернуть исходную структуру. Мы сжимаем ветви без оставшихся семян и ветвей, которые разветвляются только в одну сторону.
compress :: Free [] [b] -> (Free [] b, Free [] a -> Free [] [a])
compress (Pure [x]) = (Pure x, \(Pure x) -> Pure [x])
compress (Pure xs ) = (Free (map Pure xs), \(Free ps) -> Pure (map getPure ps))
compress (Free xs) = wrapList . compressList . map compress $ xs
where
compressList [] = ([], const [])
compressList ((Free [],dx):xs) = let (xs', dxs) = compressList xs
in (xs', \xs -> dx (Free []):dxs xs)
compressList ( (x,dx):xs) = let (xs', dxs) = compressList xs
in (x:xs', \(x:xs) -> dx x:dxs xs)
wrapList ([x], dxs) = (x, \x -> Free (dxs [x]))
wrapList (xs , dxs) = (Free xs, \(Free xs) -> Free (dxs xs ))
Каждый шаг сжатия также возвращает функцию, которая отменяет ее при применении к Free [] дерево с той же структурой. Все эти функции частично определены; что они делают для Free [] деревья с другой структурой не определены. Для простоты мы также определим частичные функции для обратных Pure а также Free,
getPure (Pure x) = x
getFree (Free xs) = xs
И то и другое unfoldForestM_BF а также unfoldTreeM_BF определяются путем упаковки их аргумента в Free [] b и распаковывать результаты, предполагая, что они находятся в одной структуре.
unfoldTreeM_BF :: MonadFix m => (b->m (a, [b])) -> b -> m (Tree a)
unfoldTreeM_BF f = (>>= return . getPure) . unfoldFreeM_BF f . Pure
unfoldForestM_BF :: MonadFix m => (b->m (a, [b])) -> [b] -> m [Tree a]
unfoldForestM_BF f = (>>= return . map getPure . getFree) . unfoldFreeM_BF f . Free . map Pure
Более элегантную версию этого алгоритма, вероятно, можно сделать, признав, что >>= для Monad прививает на деревьях и оба Free а также FreeT предоставить монадные экземпляры. И то и другое compress а также compressList вероятно, есть более элегантные презентации.
Алгоритм, представленный выше, не достаточно ленив, чтобы разрешать запросы к деревьям, которые разветвляются бесконечным числом путей, а затем завершаются. Простым примером счетчика является следующая генерирующая функция, развернутая из 0,
counterExample :: Int -> (Int, [Int])
counterExample 0 = (0, [1, 2])
counterExample 1 = (1, repeat 3)
counterExample 2 = (2, [3])
counterExample 3 = (3, [])
Это дерево будет выглядеть
0
|
+- 1
| |
| +- 3
| |
| `- 3
| |
| ...
|
`- 2
|
+- 3
Попытка спуститься на второй ветке 2) и осмотреть оставшееся конечное поддерево не удастся завершить.
Примеры
Следующие примеры демонстрируют, что все реализации unfoldForestM_BF выполнить действия в ширину первого порядка и что runIdentity . unfoldTreeM_BF (Identity . f) имеет ту же строгость, что и unfoldTree для деревьев с конечным коэффициентом ветвления. Для деревьев с бесконечным фактором разветвления, только решение для "больших" факторов разветвления имеет ту же строгость, что и unfoldTree, Чтобы продемонстрировать лень, мы определим три бесконечных дерева - унарное дерево с одной ветвью, бинарное дерево с двумя ветвями и бесконечное дерево с бесконечным числом ветвей для каждого узла.
mkUnary :: Int -> (Int, [Int])
mkUnary x = (x, [x+1])
mkBinary :: Int -> (Int, [Int])
mkBinary x = (x, [x+1,x+2])
mkInfinitary :: Int -> (Int, [Int])
mkInfinitary x = (x, [x+1..])
Вместе с unfoldTree мы определим unfoldTreeDF с точки зрения unfoldTreeM чтобы проверить это unfoldTreeM на самом деле ленив, как вы утверждали, и unfoldTreeBF с точки зрения unfoldTreeMFix_BF проверить, что новая реализация так же ленива.
import Data.Functor.Identity
unfoldTreeDF f = runIdentity . unfoldTreeM (Identity . f)
unfoldTreeBF f = runIdentity . unfoldTreeM_BF (Identity . f)
Чтобы получить конечные куски этих бесконечных деревьев, даже бесконечно ветвящихся, мы определим способ извлечения из дерева, если его метки соответствуют предикату. Это может быть написано более кратко с точки зрения способности применять функцию к каждому subForest,
takeWhileTree :: (a -> Bool) -> Tree a -> Tree a
takeWhileTree p (Node label branches) = Node label (takeWhileForest p branches)
takeWhileForest :: (a -> Bool) -> [Tree a] -> [Tree a]
takeWhileForest p = map (takeWhileTree p) . takeWhile (p . rootLabel)
Это позволяет нам определить девять примеров деревьев.
unary = takeWhileTree (<= 3) (unfoldTree mkUnary 0)
unaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkUnary 0)
unaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkUnary 0)
binary = takeWhileTree (<= 3) (unfoldTree mkBinary 0)
binaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkBinary 0)
binaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkBinary 0)
infinitary = takeWhileTree (<= 3) (unfoldTree mkInfinitary 0)
infinitaryDF = takeWhileTree (<= 3) (unfoldTreeDF mkInfinitary 0)
infinitaryBF = takeWhileTree (<= 3) (unfoldTreeBF mkInfinitary 0)
Все пять методов имеют одинаковый вывод для унарного и двоичного деревьев. Выход приходит от putStrLn . drawTree . fmap show
0
|
`- 1
|
`- 2
|
`- 3
0
|
+- 1
| |
| +- 2
| | |
| | `- 3
| |
| `- 3
|
`- 2
|
`- 3
Однако первый обход ширины из решения с конечным коэффициентом ветвления недостаточно ленив для дерева с бесконечным коэффициентом ветвления. Другие четыре метода выводят все дерево
0
|
+- 1
| |
| +- 2
| | |
| | `- 3
| |
| `- 3
|
+- 2
| |
| `- 3
|
`- 3
Дерево, созданное с unfoldTreeBF для конечного фактора ветвления решение никогда не может быть полностью проведено за его первыми ветвями.
0
|
+- 1
| |
| +- 2
| | |
| | `- 3
| |
| `- 3
Конструкция определенно широка первой.
mkDepths :: Int -> IO (Int, [Int])
mkDepths d = do
print d
return (d, [d+1, d+1])
mkFiltered :: (Monad m) => (b -> Bool) -> (b -> m (a, [b])) -> (b -> m (a, [b]))
mkFiltered p f x = do
(a, bs) <- f x
return (a, filter p bs)
binaryDepths = unfoldTreeM_BF (mkFiltered (<= 2) mkDepths) 0
Бег binaryDepths выводит внешние уровни перед внутренними
0
1
1
2
2
2
2
От ленивых к откровенным ленивцам
Гибридное решение из предыдущего раздела недостаточно лениво, чтобы иметь ту же семантику строгости, что и Data.Tree "s unfoldTree, Это первый из серии алгоритмов, каждый из которых немного ленивее своего предшественника, но ни один из них не достаточно ленив, чтобы иметь ту же семантику строгости, что и unfoldTree,
Гибридное решение не дает гарантии, что исследование части дерева не требует исследования других частей того же дерева. Также не будет код, представленный ниже. В одном конкретном, но все же частом случае, выявленном dfeuer, исследующим только log(N) размерный кусок конечного дерева заставляет дерево целиком. Это происходит при исследовании последнего потомка каждой ветви дерева с постоянной глубиной. При сжатии дерева мы выбрасываем каждую тривиальную ветвь без потомков, чего необходимо избегать O(n^2) Продолжительность. Мы можем только лениво пропустить эту часть сжатия, если мы можем быстро показать, что у ветви есть хотя бы один потомок, и поэтому мы можем отклонить шаблон Free [], На самой большой глубине дерева с постоянной глубиной ни одна из ветвей не имеет оставшихся потомков, поэтому мы никогда не можем пропустить шаг сжатия. Это приводит к исследованию всего дерева, чтобы иметь возможность посетить самый последний узел. Когда все дерево на эту глубину не является конечным из-за бесконечного коэффициента ветвления, исследование части дерева не завершается, когда оно завершается, когда генерируется unfoldTree,
Этап сжатия в секции гибридного решения сжимает ветви без потомков в первом поколении, в котором они могут быть обнаружены, что является оптимальным для сжатия, но не оптимальным для лени. Мы можем сделать алгоритм более медленным, задерживая, когда происходит это сжатие. Если мы задержим это на одно поколение (или даже на любое постоянное число поколений), мы будем поддерживать O(n) верхняя граница по времени. Если мы задержим его на несколько поколений, это как-то зависит от N мы обязательно пожертвуем O(N) ограниченный по времени. В этом разделе мы задержим сжатие на одно поколение.
Чтобы контролировать, как происходит сжатие, мы отделим начинку самым внутренним [] в Free [] структура от сжатия вырожденных ветвей с 0 или 1 потомками.
Поскольку часть этого трюка не работает без особой лени в сжатии, мы повсеместно примем параноидальный уровень чрезмерно ленивой лени. Если что-нибудь о результате, отличном от конструктора кортежа (,) можно определить, не форсируя часть его входных данных с помощью сопоставления с образцом, мы не будем форсировать его, пока это не будет необходимо. Для кортежей все, что соответствует шаблону, будет лениво. Следовательно, часть кода ниже будет выглядеть как ядро или хуже.
bindFreeInvertible заменяет Pure [b,...] с Free [Pure b,...]
bindFreeInvertible :: Free [] ([] b) -> (Free [] b, Free [] a -> Free [] ([] a))
bindFreeInvertible = wrapFree . go
where
-- wrapFree adds the {- Free -} that would have been added in both branches
wrapFree ~(xs, dxs) = (Free xs, dxs)
go (Pure xs) = ({- Free -} (map Pure xs), Pure . map getPure . getFree)
go (Free xs) = wrapList . rebuildList . map bindFreeInvertible $ xs
rebuildList = foldr k ([], const [])
k ~(x,dx) ~(xs, dxs) = (x:xs, \(~(x:xs)) -> dx x:dxs xs)
wrapList ~(xs, dxs) = ({- Free -} xs, \(~(Free xs)) -> Free (dxs xs)))
compressFreeList удаляет вхождения Free [] и заменяет Free [xs] с xs,
compressFreeList :: Free [] b -> (Free [] b, Free [] a -> Free [] a)
compressFreeList (Pure x) = (Pure x, id)
compressFreeList (Free xs) = wrapList . compressList . map compressFreeList $ xs
where
compressList = foldr k ([], const [])
k ~(x,dx) ~(xs', dxs) = (x', dxs')
where
x' = case x of
Free [] -> xs'
otherwise -> x:xs'
dxs' cxs = dx x'':dxs xs''
where
x'' = case x of
Free [] -> Free []
otherwise -> head cxs
xs'' = case x of
Free [] -> cxs
otherwise -> tail cxs
wrapList ~(xs, dxs) = (xs', dxs')
where
xs' = case xs of
[x] -> x
otherwise -> Free xs
dxs' cxs = Free (dxs xs'')
where
xs'' = case xs of
[x] -> [cxs]
otherwise -> getFree cxs
Общее сжатие не будет связывать Pure [] с в Free с до вырождения Free s были сжаты, задерживая сжатие вырожденных Free s введены в одном поколении в сжатие следующего поколения.
compress :: Free [] [b] -> (Free [] b, Free [] a -> Free [] [a])
compress xs = let ~(xs' , dxs' ) = compressFreeList xs
~(xs'', dxs'') = bindFreeInvertible xs'
in (xs'', dxs' . dxs'')
Из продолженной паранойи, помощники getFree а также getPure также сделаны неопровержимо ленивыми.
getFree ~(Free xs) = xs
getPure ~(Pure x) = x
Это очень быстро решает проблемный пример обнаруженного dfeuer
print . until (null . subForest) (last . subForest) $
flip unfoldTreeBF 0 (\x -> (x, if x > 5 then [] else replicate 10 (x+1)))
Но так как мы только задержали сжатие 1 поколение, мы можем воссоздать точно такую же проблему, если самый последний узел самой последней ветви 1 уровень глубже, чем все остальные ветви.
print . until (null . subForest) (last . subForest) $
flip unfoldTreeBF (0,0) (\(x,y) -> ((x,y),
if x==y
then if x>5 then [] else replicate 9 (x+1, y) ++ [(x+1, y+1)]
else if x>4 then [] else replicate 10 (x+1, y)))