{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} -- | By providing a 'TreeLike' instance, a functor can be traversed in several -- orders: -- -- ['inorder' / 'InOrder'] -- Viewing a 'TreeLike' functor as a sequence of values and subtrees, an -- /__inorder__/ traversal iterates through this sequence visiting values and -- traversing subtrees in the order they are given. -- -- >>> printTree (label inorder exampleBinaryTree) -- ┌──────6───┐ -- │ │ -- ┌──2┴───┐ ┌7─┴──┐ -- │ │ │ │ -- ┌0┴┐ ┌─┴5┐ ╵ ┌─9┴─┐ -- │ │ │ │ │ │ -- ╵ ┌1┐ ┌3┴┐ ╵ ┌8┐ ┌10┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌4┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- -- ['preorder' / 'PreOrder'] -- Viewing a 'TreeLike' functor as a sequence of values and subtrees, a -- /__preorder__/ traversal visits all the values in the sequence before -- traversing the subtrees. -- -- >>> printTree (label preorder exampleBinaryTree) -- ┌──────0───┐ -- │ │ -- ┌──1┴───┐ ┌7─┴──┐ -- │ │ │ │ -- ┌2┴┐ ┌─┴4┐ ╵ ┌─8┴─┐ -- │ │ │ │ │ │ -- ╵ ┌3┐ ┌5┴┐ ╵ ┌9┐ ┌10┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌6┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- -- ['postorder' / 'PostOrder'] -- Viewing a 'TreeLike' functor as a sequence of values and subtrees, a -- /__postorder__/ traversal traverses all the subtrees in the sequence -- before visiting the values in the sequence before -- traversing the subtrees. -- -- >>> printTree (label postorder exampleBinaryTree) -- ┌──────10───┐ -- │ │ -- ┌──5┴───┐ ┌9─┴─┐ -- │ │ │ │ -- ┌1┴┐ ┌─┴4┐ ╵ ┌─8─┐ -- │ │ │ │ │ │ -- ╵ ┌0┐ ┌3┴┐ ╵ ┌6┐ ┌7┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌2┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- -- ['levelorder' / 'LevelOrder'] -- Similar to a preorder traversal, a /__levelorder__/ traversal first visits -- all the values at the root level before traversing any of the subtrees. -- Instead of traversing the subtrees one by one, though, a levelorder -- traversal interweaves their traversals, next visiting all the values at the -- root of each subtree, then visiting all the values at the roots of each -- subtree's subtrees, and so on. This is also known as a breadth-first -- traversal. -- -- >>> printTree (label levelorder exampleBinaryTree) -- ┌──────0───┐ -- │ │ -- ┌──1─┴───┐ ┌2─┴─┐ -- │ │ │ │ -- ┌3┴┐ ┌──┴4┐ ╵ ┌─5─┐ -- │ │ │ │ │ │ -- ╵ ┌6┐ ┌7┴─┐ ╵ ┌8┐ ┌9┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌10┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- -- ['rlevelorder' / 'RLevelOrder'] -- Similar to a postlevel traversal, a /__reversed levelorder__/ traversal -- only visits all the values at the root level after traversing all of the -- subtrees. Instead of traversing the subtrees one by one, though, a -- reversed levelorder traversal interweaves their traversals, working -- from the deepest level up, though still in left-to-right order. -- -- >>> printTree (label rlevelorder exampleBinaryTree) -- ┌──────10───┐ -- │ │ -- ┌──8┴───┐ ┌9─┴─┐ -- │ │ │ │ -- ┌5┴┐ ┌─┴6┐ ╵ ┌─7─┐ -- │ │ │ │ │ │ -- ╵ ┌1┐ ┌2┴┐ ╵ ┌3┐ ┌4┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌0┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- module Data.Traversable.TreeLike ( TreeLike(..), treeFoldMap -- | = TreeLike wrappers -- These @newtype@s define 'TreeLike' instances for 'Traversable' types. , Forest(..), Flat(..), List(..) -- | = Traversals -- Each 'TreeLike' type admits multiple traversal orders: -- -- > inorder, preorder, postorder, levelorder, rlevelorder -- > :: TreeLike tree => Traversal (tree a) (tree b) a b -- -- Using the definition of 'Control.Lens.Traversal.Traversal' from -- "Control.Lens.Traversal": -- -- > type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t -- , inorder, preorder, postorder, levelorder, rlevelorder -- | = Traversable wrappers -- These @newtype@s define 'Traversable' instances for 'TreeLike' types. , InOrder(..), PreOrder(..), PostOrder(..), LevelOrder(..), RLevelOrder(..) -- | = Convenience functions , showTree, printTree ) where import Data.Functor.Compose (Compose(..)) import Data.Functor.Const (Const(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) import Data.Traversable (foldMapDefault) import Data.Tree hiding (Forest) import Control.Applicative.Phases import Data.BinaryTree import Data.Monoid.TreeDiagram -- | Render the tree as a string, using the 'TreeDiagram' monoid. showTree :: (TreeLike tree, Show a) => tree a -> ShowS showTree = showTreeDiagram . treeFoldMap singleton subtree -- | Print the tree, using the 'TreeDiagram' monoid. printTree :: (TreeLike tree, Show a) => tree a -> IO () printTree = putStrLn . ($[]) . showTree -- | Notionally, functors are 'TreeLike' if any values and 'TreeLike' -- substructure they contain can be traversed distinctly. -- -- For example, given the 'TreeDiagram' monoid, one can use 'treeTraverse' with -- the 'Const' applicative to recursively create a drawing of any tree, -- rendering values inline with 'singleton' and dropping a line to drawings of -- subtrees with 'subtree': -- -- >>> :{ -- printTree :: (Show a, TreeLike tree) => tree a -> IO () -- printTree = printTreeDiagram . drawTree where -- drawTree :: (Show a, TreeLike tree) => tree a -> TreeDiagram -- drawTree = getConst . treeTraverse (Const . singleton) (Const . subtree . drawTree) -- :} -- -- This common pattern of mapping each element to a monoid and then modifying -- each monoidal value generated from a subtree is captured by 'treeFoldMap', which -- gives a slightly less verbose implementation of @printTree@. -- -- >>> printTree = printTreeDiagram . treeFoldMap singleton subtree -- -- Instances of 'TreeLike' are encouraged to avoid recursively defining -- 'treeTraverse' in terms of itself, and to instead traverse subtrees -- using the provided argument. -- -- For example, given this definition for balanced binary trees: -- -- >>> :{ -- data BBT a = Nil | a `Cons` BBT (a,a) -- deriving Functor -- infixr 4 `Cons` -- :} -- -- Its 'TreeLike' instance can be defined as: -- -- >>> :{ -- instance TreeLike BBT where -- treeTraverse = \f g t -> case t of -- Nil -> pure Nil -- a `Cons` at -> branch <$> g (fst <$> at) <*> f a <*> g (snd <$> at) -- where -- branch :: BBT b -> b -> BBT b -> BBT b -- branch Nil b ~Nil = b `Cons` Nil -- branch (x `Cons` xt) b ~(y `Cons` yt) = b `Cons` branch xt (x,y) yt -- :} -- -- This definition exposes the substructure in a way that can be used -- by functions implemented in terms of 'treeTraverse', such as @printTree@: -- -- >>> printTree $ 1 `Cons` (2,3) `Cons` ((4,5),(6,7)) `Cons` Nil -- ┌───1───┐ -- │ │ -- ┌─2─┐ ┌─3─┐ -- │ │ │ │ -- ┌4┐ ┌6┐ ┌5┐ ┌7┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ╵ ╵ ╵ ╵ ╵ class Functor tree => TreeLike tree where treeTraverse :: Applicative f => (a -> f b) -> (forall subtree. TreeLike subtree => subtree a -> f (subtree b)) -> tree a -> f (tree b) -- | Recursively fold a tree into a monoid, using the given functions to -- transform values and folded subtrees. -- -- For example, one can find the maximum depth of a tree: -- -- >>> printTree exampleTree -- []─┬─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> :set -XGeneralizedNewtypeDeriving -- >>> import GHC.Natural -- >>> import Data.Semigroup -- >>> :{ -- newtype Max = Max { getMax :: Natural } deriving (Num, Enum) -- instance Semigroup Max where -- (<>) = mappend -- instance Monoid Max where -- mempty = Max 0 -- Max a `mappend` Max b = Max $ a `max` b -- :} -- -- >>> getMax $ treeFoldMap (const 0) succ exampleTree -- 4 treeFoldMap :: (Monoid m, TreeLike tree) => (a -> m) -> (m -> m) -> tree a -> m treeFoldMap f g = getConst . treeTraverse (Const . f) (Const . g . treeFoldMap f g) instance TreeLike Tree where treeTraverse f g (Node a as) = Node <$> f a <*> traverse g as instance TreeLike BinaryTree where treeTraverse _ _ Leaf = pure Leaf treeTraverse f g (Branch l a r) = Branch <$> g l <*> f a <*> g r -- | -- Use 'Product' to combine a pair of 'TreeLike' values into a single tree. -- -- >>> smallBinaryTree = Branch (Branch Leaf [0,1] Leaf) [0] (Branch Leaf [0,2] Leaf) -- >>> smallRoseTree = Node [1] [Node [1,0] [], Node [1,1] [], Node [1,2] [], Node [1,3] []] -- >>> printTree $ Pair smallBinaryTree smallRoseTree -- ┌────────────────────┐ -- │ │ -- ┌───[0]───┐ [1]──┬─────┬┴────┬─────┐ -- │ │ │ │ │ │ -- ┌[0,1]┐ ┌[0,2]┐ [1,0] [1,1] [1,2] [1,3] -- │ │ │ │ -- ╵ ╵ ╵ ╵ -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- postorder visit (Pair smallBinaryTree smallRoseTree) `evalStateT` 0 -- [0,1] -- [0,2] -- [0] -- [1,0] -- [1,1] -- [1,2] -- [1,3] -- [1] -- >>> printTree traversed -- ┌───────┐ -- │ │ -- ┌─2─┐ 7┬─┬┴┬─┐ -- │ │ │ │ │ │ -- ┌0┐ ┌1┐ 3 4 5 6 -- │ │ │ │ -- ╵ ╵ ╵ ╵ instance (TreeLike fst, TreeLike snd) => TreeLike (Product fst snd) where treeTraverse _ g (Pair x y) = Pair <$> g x <*> g y -- | Use 'Sum' to unify two different types of trees into a single type. -- -- >>> smallBinaryTree = Branch (Branch Leaf [0,1] Leaf) [0] (Branch Leaf [0,2] Leaf) -- >>> smallRoseTree = Node [1] [Node [1,0] [], Node [1,1] [], Node [1,2] [], Node [1,3] []] -- >>> someTree b = if not b then InL smallBinaryTree else InR smallRoseTree -- >>> :t someTree -- someTree :: Num a => Bool -> Sum BinaryTree Tree [a] -- >>> printTree (someTree False) -- ╷ -- │ -- ┌───[0]───┐ -- │ │ -- ┌[0,1]┐ ┌[0,2]┐ -- │ │ │ │ -- ╵ ╵ ╵ ╵ -- >>> printTree (someTree True) -- ╷ -- │ -- [1]──┬─────┬┴────┬─────┐ -- │ │ │ │ -- [1,0] [1,1] [1,2] [1,3] instance (TreeLike left, TreeLike right) => TreeLike (Sum left right) where treeTraverse _ g (InL x) = InL <$> g x treeTraverse _ g (InR y) = InR <$> g y -- | -- A newtype wrapper to allow traversing an entire traversable of trees -- simultaneously. -- -- >>> printTree $ Forest exampleTrees -- ┌─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- levelorder visit (Forest exampleTrees) `evalStateT` 0 -- [0] -- [1] -- [2] -- [3] -- [1,0] -- [2,0] -- [2,1] -- [3,0] -- [3,1] -- [3,2] -- [2,1,0] -- [3,1,0] -- [3,2,0] -- [3,2,1] -- [3,2,1,0] -- >>> printTree traversed -- ┌──┬───┬────────┐ -- │ │ │ │ -- 0 1┤ 2┬┴─┐ 3┬──┬┴────┐ -- │ │ │ │ │ │ -- 4 5 6┴┐ 7 8┴┐ 9─┬┴──┐ -- │ │ │ │ -- 10 11 12 13┴┐ -- │ -- 14 -- -- This is more of a convenience than a necessity, as @'Forest' t tree ~ -- 'Compose' ('Flat' t) tree@ -- -- >>> printTree . Compose $ Flat exampleTrees -- ┌─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] newtype Forest t tree a = Forest { getForest :: t (tree a) } deriving Functor instance (Traversable t, TreeLike tree) => TreeLike (Forest t tree) where treeTraverse _ g = fmap Forest . traverse g . getForest -- | -- A newtype wrapper for @[a]@ whose `TreeLike` instance -- treats each cons-cell as a tree containing one value and one subtree. -- -- >>> printTree $ List [1..5] -- 1─┐ -- │ -- 2┴┐ -- │ -- 3┴┐ -- │ -- 4┴┐ -- │ -- 5┤ -- │ -- ╵ -- >>> import Data.Foldable (toList) -- >>> toList . PostOrder $ List [1..5] -- [5,4,3,2,1] -- -- Contrast with @'Flat' [] a@: -- -- >>> printTree $ Flat [1..5] -- 1─2─3─4─5 -- >>> toList . PostOrder $ Flat [1..5] -- [1,2,3,4,5] -- newtype List a = List { getList :: [a] } deriving Functor instance TreeLike List where treeTraverse f g (List as) = List <$> case as of [] -> pure [] a:as -> (:) <$> f a <*> (fmap getList . g .List) as -- | -- A newtype wraper for @t a@ whose `TreeLike` instance treats -- the @t a@ as a flat structure with no subtrees. -- -- >>> printTree $ Flat [1..5] -- 1─2─3─4─5 -- >>> import Data.Foldable (toList) -- >>> toList . PostOrder $ Flat [1..5] -- [1,2,3,4,5] newtype Flat t a = Flat { getFlat :: t a } deriving Functor instance Traversable t => TreeLike (Flat t) where treeTraverse f _ (Flat ta) = Flat <$> traverse f ta -- | -- Treat subtrees and values of @outer (inner a)@ as subtrees of -- @'Compose' outer inner a@. -- -- For example -- -- >>> :{ -- exampleCompose = Compose $ -- Branch -- (Branch Leaf (Node 'a' [Node 'b' [], Node 'c' [], Node 'd' []]) Leaf) -- (Node 'e' [Node 'f' [Node 'g' [], Node 'h' []]]) -- (Branch Leaf (Node 'i' [Node 'i' [Node 'j' [Node 'k' []]]]) Leaf) -- :} -- -- >>> printTree exampleCompose -- ┌─────────────┬───────────────┐ -- │ │ │ -- ┌───────┼───────┐ 'e'─┴──┐ ┌────┬─┴──────┐ -- │ │ │ │ │ │ │ -- ╵ 'a'─┬─┴─┬───┐ ╵ 'f'─┼───┐ ╵ 'i'┴──┐ ╵ -- │ │ │ │ │ │ -- 'b' 'c' 'd' 'g' 'h' 'i'┴─┐ -- │ -- 'j'─┐ -- │ -- 'k' -- >>> treeFoldMap (const ["value"]) (const ["subtree"]) exampleCompose -- ["subtree","subtree","subtree"] instance (TreeLike outer, TreeLike inner) => TreeLike (Compose outer inner) where treeTraverse _ g (Compose trees) = Compose <$> treeTraverse g (fmap getCompose . g . Compose) trees -- | Traverse all the values in a tree in left-to-right order. -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- inorder visit exampleBinaryTree `evalStateT` 0 -- [L,L] -- [L,L,R] -- [L] -- [L,R,L] -- [L,R,L,R] -- [L,R] -- [] -- [R] -- [R,R,L] -- [R,R] -- [R,R,R] -- >>> printTree traversed -- ┌──────6───┐ -- │ │ -- ┌──2┴───┐ ┌7─┴──┐ -- │ │ │ │ -- ┌0┴┐ ┌─┴5┐ ╵ ┌─9┴─┐ -- │ │ │ │ │ │ -- ╵ ┌1┐ ┌3┴┐ ╵ ┌8┐ ┌10┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌4┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> printTree exampleTree -- []─┬─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> traversed <- inorder visit exampleTree `evalStateT` 0 -- [] -- [0] -- [1] -- [1,0] -- [2] -- [2,0] -- [2,1] -- [2,1,0] -- [3] -- [3,0] -- [3,1] -- [3,1,0] -- [3,2] -- [3,2,0] -- [3,2,1] -- [3,2,1,0] -- >>> printTree traversed -- 0┬──┬───┬─────────┐ -- │ │ │ │ -- 1 2┤ 4┬┴─┐ 8┬───┬┴─────┐ -- │ │ │ │ │ │ -- 3 5 6┤ 9 10┴┐ 12─┬┴──┐ -- │ │ │ │ -- 7 11 13 14┴┐ -- │ -- 15 inorder :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> f (tree b) inorder f = treeTraverse f (inorder f) -- | Traverse all the values of a node, then recurse into each of its subtrees -- in left-to-right order. -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- preorder visit exampleBinaryTree `evalStateT` 0 -- [] -- [L] -- [L,L] -- [L,L,R] -- [L,R] -- [L,R,L] -- [L,R,L,R] -- [R] -- [R,R] -- [R,R,L] -- [R,R,R] -- >>> printTree traversed -- ┌──────0───┐ -- │ │ -- ┌──1┴───┐ ┌7─┴──┐ -- │ │ │ │ -- ┌2┴┐ ┌─┴4┐ ╵ ┌─8┴─┐ -- │ │ │ │ │ │ -- ╵ ┌3┐ ┌5┴┐ ╵ ┌9┐ ┌10┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌6┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> printTree exampleTree -- []─┬─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> traversed <- inorder visit exampleTree `evalStateT` 0 -- [] -- [0] -- [1] -- [1,0] -- [2] -- [2,0] -- [2,1] -- [2,1,0] -- [3] -- [3,0] -- [3,1] -- [3,1,0] -- [3,2] -- [3,2,0] -- [3,2,1] -- [3,2,1,0] -- >>> printTree traversed -- 0┬──┬───┬─────────┐ -- │ │ │ │ -- 1 2┤ 4┬┴─┐ 8┬───┬┴─────┐ -- │ │ │ │ │ │ -- 3 5 6┤ 9 10┴┐ 12─┬┴──┐ -- │ │ │ │ -- 7 11 13 14┴┐ -- │ -- 15 preorder :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> f (tree b) preorder f = runPhasesForwards . treeTraverse (now . f) (later . preorder f) -- | Traverse all the values of a node after recursing into each of its -- subtrees in left-to-right order. -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- postorder visit exampleBinaryTree `evalStateT` 0 -- [L,L,R] -- [L,L] -- [L,R,L,R] -- [L,R,L] -- [L,R] -- [L] -- [R,R,L] -- [R,R,R] -- [R,R] -- [R] -- [] -- >>> printTree traversed -- ┌──────10───┐ -- │ │ -- ┌──5┴───┐ ┌9─┴─┐ -- │ │ │ │ -- ┌1┴┐ ┌─┴4┐ ╵ ┌─8─┐ -- │ │ │ │ │ │ -- ╵ ┌0┐ ┌3┴┐ ╵ ┌6┐ ┌7┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌2┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> printTree exampleTree -- []─┬─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> traversed <- postorder visit exampleTree `evalStateT` 0 -- [0] -- [1,0] -- [1] -- [2,0] -- [2,1,0] -- [2,1] -- [2] -- [3,0] -- [3,1,0] -- [3,1] -- [3,2,0] -- [3,2,1,0] -- [3,2,1] -- [3,2] -- [3] -- [] -- >>> printTree traversed -- 15┬──┬───┬─────────┐ -- │ │ │ │ -- 0 2┤ 6┬┴─┐ 14┬──┬┴────┐ -- │ │ │ │ │ │ -- 1 3 5┤ 7 9┤ 13─┬┴──┐ -- │ │ │ │ -- 4 8 10 12┴┐ -- │ -- 11 postorder :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> f (tree b) postorder f = runPhasesBackwards . treeTraverse (now . f) (later . postorder f) -- | Traverse all the values of a tree in left-to-right breadth-first order. -- (i.e. all nodes of depth @0@, then all nodes of depth @1@, then all nodes of -- depth @2@, etc.) -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- levelorder visit exampleBinaryTree `evalStateT` 0 -- [] -- [L] -- [R] -- [L,L] -- [L,R] -- [R,R] -- [L,L,R] -- [L,R,L] -- [R,R,L] -- [R,R,R] -- [L,R,L,R] -- >>> printTree traversed -- ┌──────0───┐ -- │ │ -- ┌──1─┴───┐ ┌2─┴─┐ -- │ │ │ │ -- ┌3┴┐ ┌──┴4┐ ╵ ┌─5─┐ -- │ │ │ │ │ │ -- ╵ ┌6┐ ┌7┴─┐ ╵ ┌8┐ ┌9┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌10┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> printTree exampleTree -- []─┬─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> traversed <- levelorder visit exampleTree `evalStateT` 0 -- [] -- [0] -- [1] -- [2] -- [3] -- [1,0] -- [2,0] -- [2,1] -- [3,0] -- [3,1] -- [3,2] -- [2,1,0] -- [3,1,0] -- [3,2,0] -- [3,2,1] -- [3,2,1,0] -- >>> printTree traversed -- 0┬──┬───┬─────────┐ -- │ │ │ │ -- 1 2┤ 3┬┴─┐ 4┬──┬─┴────┐ -- │ │ │ │ │ │ -- 5 6 7┴┐ 8 9┴┐ 10─┬┴──┐ -- │ │ │ │ -- 11 12 13 14┴┐ -- │ -- 15 levelorder :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> f (tree b) levelorder = \f -> runPhasesForwards . schedule f where schedule :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> Phases f (tree b) schedule f = treeTraverse (now . f) (delay . schedule f) -- | Traverse all the values of a tree in left-to-right inverse breadth-first order. -- (i.e. all nodes of @n@, then all nodes of depth @n-1@, then all nodes of -- depth @n-2@, etc.) -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> visit a = StateT $ \e -> print a >> return (e, succ e) -- >>> traversed <- rlevelorder visit exampleBinaryTree `evalStateT` 0 -- [L,R,L,R] -- [L,L,R] -- [L,R,L] -- [R,R,L] -- [R,R,R] -- [L,L] -- [L,R] -- [R,R] -- [L] -- [R] -- [] -- >>> printTree traversed -- ┌──────10───┐ -- │ │ -- ┌──8┴───┐ ┌9─┴─┐ -- │ │ │ │ -- ┌5┴┐ ┌─┴6┐ ╵ ┌─7─┐ -- │ │ │ │ │ │ -- ╵ ┌1┐ ┌2┴┐ ╵ ┌3┐ ┌4┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌0┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> printTree exampleTree -- []─┬─────┬───────────┬─────────────────────────────┐ -- │ │ │ │ -- [0] [1]┴─┐ [2]──┬─┴─────┐ [3]──┬───────┬──┴──────────────┐ -- │ │ │ │ │ │ -- [1,0] [2,0] [2,1]───┐ [3,0] [3,1]───┐ [3,2]───┬─┴────────┐ -- │ │ │ │ -- [2,1,0] [3,1,0] [3,2,0] [3,2,1]────┐ -- │ -- [3,2,1,0] -- >>> traversed <- rlevelorder visit exampleTree `evalStateT` 0 -- [3,2,1,0] -- [2,1,0] -- [3,1,0] -- [3,2,0] -- [3,2,1] -- [1,0] -- [2,0] -- [2,1] -- [3,0] -- [3,1] -- [3,2] -- [0] -- [1] -- [2] -- [3] -- [] -- >>> printTree traversed -- 15─┬──┬─────┬────────┐ -- │ │ │ │ -- 11 12┐ 13┬┴─┐ 14┬──┼────┐ -- │ │ │ │ │ │ -- 5 6 7┤ 8 9┤ 10┬┴─┐ -- │ │ │ │ -- 1 2 3 4┤ -- │ -- 0 rlevelorder :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> f (tree b) rlevelorder = \f -> runPhasesBackwards . schedule f where schedule :: (Applicative f, TreeLike tree) => (a -> f b) -> tree a -> Phases f (tree b) schedule f = treeTraverse (now . f) (delay . schedule f) -- | 'Tree' wrapper to use 'inorder' traversal -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> _ <- traverse print $ InOrder exampleBinaryTree -- [L,L] -- [L,L,R] -- [L] -- [L,R,L] -- [L,R,L,R] -- [L,R] -- [] -- [R] -- [R,R,L] -- [R,R] -- [R,R,R] newtype InOrder tree a = InOrder { getInOrder :: tree a } deriving Functor instance TreeLike tree => Foldable (InOrder tree) where foldMap = foldMapDefault instance TreeLike tree => Traversable (InOrder tree) where traverse f = fmap InOrder . inorder f . getInOrder -- | 'Tree' wrapper to use 'preorder' traversal -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> _ <- traverse print $ PreOrder exampleBinaryTree -- [] -- [L] -- [L,L] -- [L,L,R] -- [L,R] -- [L,R,L] -- [L,R,L,R] -- [R] -- [R,R] -- [R,R,L] -- [R,R,R] newtype PreOrder tree a = PreOrder { getPreOrder :: tree a } deriving Functor instance TreeLike tree => Foldable (PreOrder tree) where foldMap = foldMapDefault instance TreeLike tree => Traversable (PreOrder tree) where traverse f = fmap PreOrder . preorder f . getPreOrder -- | 'Tree' wrapper to use 'postorder' traversal -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> _ <- traverse print $ PostOrder exampleBinaryTree -- [L,L,R] -- [L,L] -- [L,R,L,R] -- [L,R,L] -- [L,R] -- [L] -- [R,R,L] -- [R,R,R] -- [R,R] -- [R] -- [] newtype PostOrder tree a = PostOrder { getPostOrder :: tree a } deriving Functor instance TreeLike tree => Foldable (PostOrder tree) where foldMap = foldMapDefault instance TreeLike tree => Traversable (PostOrder tree) where traverse f = fmap PostOrder . postorder f . getPostOrder -- | 'Tree' wrapper to use 'levelorder' traversal -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> _ <- traverse print $ LevelOrder exampleBinaryTree -- [] -- [L] -- [R] -- [L,L] -- [L,R] -- [R,R] -- [L,L,R] -- [L,R,L] -- [R,R,L] -- [R,R,R] -- [L,R,L,R] newtype LevelOrder tree a = LevelOrder { getLevelOrder :: tree a } deriving Functor instance TreeLike tree => Foldable (LevelOrder tree) where foldMap = foldMapDefault instance TreeLike tree => Traversable (LevelOrder tree) where traverse f = fmap LevelOrder . levelorder f . getLevelOrder -- | 'Tree' wrapper to use 'rlevelorder' traversal -- -- >>> printTree exampleBinaryTree -- ┌──────────────────────[]────────┐ -- │ │ -- ┌─────────[L]──┴─────────────┐ ┌[R]────┴──────┐ -- │ │ │ │ -- ┌[L,L]────┐ ┌────────┴──[L,R]┐ ╵ ┌────[R,R]────┐ -- │ │ │ │ │ │ -- ╵ ┌[L,L,R]┐ ┌[L,R,L]─────┐ ╵ ┌[R,R,L]┐ ┌[R,R,R]┐ -- │ │ │ │ │ │ │ │ -- ╵ ╵ ╵ ┌[L,R,L,R]┐ ╵ ╵ ╵ ╵ -- │ │ -- ╵ ╵ -- >>> _ <- traverse print $ RLevelOrder exampleBinaryTree -- [L,R,L,R] -- [L,L,R] -- [L,R,L] -- [R,R,L] -- [R,R,R] -- [L,L] -- [L,R] -- [R,R] -- [L] -- [R] -- [] newtype RLevelOrder tree a = RLevelOrder { getRLevelOrder :: tree a } deriving Functor instance TreeLike tree => Foldable (RLevelOrder tree) where foldMap = foldMapDefault instance TreeLike tree => Traversable (RLevelOrder tree) where traverse f = fmap RLevelOrder . rlevelorder f . getRLevelOrder -- $setup -- >>> :set -XDeriveFunctor -- >>> import Control.Monad.State -- >>> data Direction = L | R deriving Show -- >>> :{ -- next :: a -> State Int Int -- next = const . state $ \n -> (n, n+1) -- label :: ((a -> State Int Int) -> tree a -> State Int (tree Int)) -> tree a -> tree Int -- label traversal tree = traversal next tree `evalState` (0 :: Int) -- :} -- -- >>> :{ -- exampleTrees :: [Tree [Int]] -- exampleTrees = -- [ Node [0] [] -- , Node [1] [Node [1,0] []] -- , Node [2] [Node [2,0] [], Node [2,1] [Node [2,1,0] []]] -- , Node [3] -- [ Node [3,0] [] -- , Node [3,1] [Node [3,1,0] []] -- , Node [3,2] [Node [3,2,0] [], Node [3,2,1] [Node [3,2,1,0] []]] -- ] -- ] -- exampleTree :: Tree [Int] -- exampleTree = Node [] exampleTrees -- exampleBinaryTree :: BinaryTree [Direction] -- exampleBinaryTree = -- Branch -- ( Branch -- ( Branch -- Leaf -- [L,L] -- (Branch Leaf [L,L,R] Leaf) -- ) -- [L] -- ( Branch -- ( Branch -- Leaf -- [L,R,L] -- (Branch Leaf [L,R,L,R] Leaf) -- ) -- [L,R] -- Leaf -- ) -- ) -- [] -- ( Branch -- Leaf -- [R] -- ( Branch -- (Branch Leaf [R,R,L] Leaf) -- [R,R] -- (Branch Leaf [R,R,R] Leaf) -- ) -- ) -- :}