RoseTree as Foldable

r-tree.hs

data RoseTree a = Rose a [RoseTree a]
                  deriving Show
--      5
--     / \
--    3   7
--   / \
--  1   4

rt = Rose 5 [Rose 3 [Rose 1 [], Rose 4[]], Rose 7 []]

-- Foldable and Traversable via list

children :: RoseTree a -> [RoseTree a]
children (Rose _ ts) = ts

root :: RoseTree a -> a
root (Rose a _) = a

dfs :: RoseTree a -> [RoseTree a]
dfs t = t : concat (map dfs (children t))

bfs :: RoseTree a -> [RoseTree a]
bfs = concat . lev
 where lev t = [t] : foldr cat [] (map lev (children t))
       cat   = combine (++)

combine :: (a -> a -> a) -> ([a] -> [a] -> [a])
combine f (x:xs) (y:ys) = f x y : combine f xs ys
combine f []     ys     = ys
combine f xs     []     = xs

roots :: RoseTree a -> [a]
roots = (map root) . dfs
-- roots = (map root) . bfs

foldMap' :: Monoid m => (a -> m) -> RoseTree a -> m
foldMap' f = foldMap f . roots

foldr' :: (a -> b -> b) -> b -> RoseTree a -> b 
foldr' f z = foldr f z . roots

traverse' :: Applicative f => (a -> f b) -> RoseTree a -> f (RoseTree b)
traverse' k (Rose x rs) = Rose <$> k x <*> sequenceA (map (traverse' k) rs)

-- instance Foldable RoseTree where
--   -- foldr :: (a -> b -> b) -> b -> RoseTree a -> b
--   foldr = foldr'

-- instance Foldable RoseTree where
--   -- foldMap :: Monoid m => (a -> m) -> RoseTree a -> m
--   foldMap = foldMap'

-- instance Traversable RoseTree where
--   -- traverese :: Applicative f => (a -> f b) -> RoseTree a -> f (RoseTree b)
--   traverse = traverse'

-- Catamorphism

-- https://en.wikibooks.org/wiki/Haskell/Other_data_structures
-- https://stackoverflow.com/questions/32898135/mapping-over-a-tree

cat :: (a -> [b] -> b) -> RoseTree a -> b
cat f (Rose a ts) = f a (map (cat f) ts)

-- Functor, Foldable, Traversable via types

fmap' :: (a -> b) -> RoseTree a -> RoseTree b
fmap' f = cat g
  -- g :: a -> [RoseTree b] -> RoseTree b
  -- Rose :: a -> [RoseTree a] -> RoseTree a
  where g = Rose . f

instance Functor RoseTree where
  -- fmap :: (a -> b) -> RoseTree a -> RoseTree b
  fmap = fmap'

foldMap'' :: Monoid m => (a -> m) -> RoseTree a -> m
foldMap'' f = cat g
-- g :: Monoid m => a -> [m] -> m
  where g x ms = f x `mappend` mconcat ms

instance Foldable RoseTree where
  -- foldMap :: Monoid m => (a -> m) -> RoseTree a -> m 
  foldMap = foldMap''

traverse'' :: Applicative f => (a -> f b) -> RoseTree a -> f (RoseTree b)
traverse'' k = cat g where
  -- g :: a -> [f (RoseTree b)] -> f (RoseTree b)
  g x fs = Rose <$> k x <*> sequenceA fs

instance Traversable RoseTree where
  -- traverese :: Applicative f => (a -> f b) -> RoseTree a -> f (RoseTree b)
  traverse = traverse''