tree-monad-alg-of-prog.hs

{-# LANGUAGE FlexibleInstances #-}

-- From exercise 2.40 in Algebra of Programming (Bird, 1997)

data TreeF a b = Leaf a | Branch b b

newtype Mu f = InF { outF :: f (Mu f) }

type Tree a = Mu (TreeF a)

treeF _ (Leaf x)     = Leaf x
treeF f (Branch x y) = Branch (f x) (f y)

cata f = f . treeF (cata f) . outF

-- or.... alpha . inl
leaf :: a -> Tree a
leaf       = InF . Leaf
-- or.... alpha . inr
branch :: Tree a -> Tree a -> Tree a
branch x y = InF (Branch x y)

t1 = branch (leaf 1) (branch (leaf 2) (leaf 3))

t2 = branch (leaf t1) (leaf t1)

instance Show a => Show (Mu (TreeF a)) where
  show x = case outF x of
    Leaf a     -> show a
    Branch x y -> "(" ++ show x ++ ", " ++ show y ++ ")"

-- Let F be a bifunctor with the collection of initial algebras alpha_A : T A <- F(A, T A).
-- The construction T can be made into a functor by defining
--
--   T f = cata (alpha . F(f, id))

tree :: (a -> b) -> Tree a -> Tree b
tree f = cata alg where
  alg (Leaf x) = leaf (f x)
  alg (Branch x y) = branch x y

sumTree = cata alg where
  alg (Leaf x) = x
  alg (Branch x y) = x + y

join :: Tree (Tree a) -> Tree a
join = cata alg where
  alg (Leaf x) = x
  alg (Branch x y) = branch x y
  
-- leaf and join form a monad

-- InF is the initial algebra

-- the natural transformation laws get translated to:
--   leaf . f = tree f . leaf
--   join . (tree (tree f)) = tree f . join

-- the monad laws get translated to
--   join . tree leaf = id = join . leaf
--   join . join = join . tree join