Catamorphisms are Post Order, Anamorphisms are Pre Order

The title says it all.

> {-# LANGUAGE
>     DeriveFunctor,
>     DeriveFoldable,
>     DeriveTraversable,
>     RankNTypes,
>     FlexibleContexts,
>     NoMonomorphismRestriction,
>     UndecidableInstances,
>     ScopedTypeVariables #-}
> 
> import Prelude hiding (mapM)
> import Data.Foldable
> import Data.Traversable
> import Data.Monoid
> import Control.Monad.Writer hiding (mapM)
> import Control.Monad.State hiding (mapM)
> import qualified Data.Map as Map
> 
> data Term = Plus Term Term
>           | Mult Term Term
>           | IntConst Int
>           deriving Show
> 
> data TermF a = PlusF a a
>              | MultF a a
>              | IntConstF Int
>              deriving (Show, Ord, Eq, Functor, Foldable, Traversable)
> 
> newtype Mu f = In {out :: f (Mu f)}
> 
> instance Eq  (f (Mu f)) => Eq  (Mu f) where
>   In x == In y = x == y
> instance Ord (f (Mu f)) => Ord (Mu f) where
>   In x `compare` In y = x `compare` y
> 
> type Term' = Mu TermF
> 
> type Algebra f a = f a -> a
> type CoAlgebra f a = a -> f a
> 
> cata :: Functor f => Algebra f a -> (Mu f -> a)
> cata f (In x) = f (fmap (cata f) x)
> 
> ana :: Functor f => CoAlgebra f a -> (a -> Mu f)
> ana f = In . fmap (ana f) . f
> 
> conv :: Term -> Term'
> conv = ana coAlg
>   where
>     coAlg (Plus x y)   = PlusF x y
>     coAlg (Mult x y)   = MultF x y
>     coAlg (IntConst x) = IntConstF x
> 
> type MonadicAlgebra f m a = f a -> m a
> type MonadicCoAlgebra f m a = a -> m (f a)
> 
> cataM :: (Traversable f, Monad m) =>
>          MonadicAlgebra f m a -> (Mu f -> m a)
> cataM f = f <=< mapM (cataM f) . out
> 
> anaM :: (Traversable f, Monad m) =>
>         MonadicCoAlgebra f m a -> a -> m (Mu f)
> anaM f = f >=> liftM In . mapM (anaM f)
> 
> cataLabelM :: Mu TermF -> Writer [String] (Mu TermF)
> cataLabelM = cataM alg
> 
> alg :: TermF (Mu TermF) -> Writer [String] (Mu TermF)
> alg (PlusF x y)   = tell ["+"]    >> (return $ In $ PlusF x y)
> alg (MultF x y)   = tell ["*"]    >> (return $ In $ MultF x y)
> alg (IntConstF x) = tell [show x] >>  (return $ In $ IntConstF x)
> 
> anaLabelM :: Mu TermF -> Writer [String] (Mu TermF)
> anaLabelM = anaM coAlg
> 
> coAlg :: Mu TermF -> Writer [String] (TermF (Mu TermF))
> coAlg (In (PlusF x y))   = tell ["+"]    >> (return $ PlusF x y)
> coAlg (In (MultF x y))   = tell ["*"]    >> (return $ MultF x y)
> coAlg (In (IntConstF x)) = tell [show x] >> (return $ IntConstF x)
> 
> t0 = let x = (Mult (IntConst 2) (IntConst 3)) 
>          y = (Mult (IntConst 5) (IntConst 7)) 
>      in Plus x y

And now we can see examples:

*Main> execWriter $ cataLabelM $ conv t0
["2","3","*","5","7","*","+"]
*Main> execWriter $ anaLabelM $ conv t0
["+","*","2","3","*","5","7"]

But if we have a term with shared sub-expressions then we are just doing the same work many times. As discussed previously we can use caching to circumvent this.

> type CacheT a b = StateT (Map.Map a b)
> 
> memoise :: (Monad m, Ord a) =>
>            ((a -> CacheT a b m b) -> (a -> CacheT a b m b)) ->
>            (a -> CacheT a b m b)
> memoise f x = gets (Map.lookup x) >>= (`maybe` return)
>   (do y <- f (memoise f) x; modify (Map.insert x y); return y)
> 
> cataMemoM :: (Traversable f, Monad m, Ord (Mu f)) =>
>              MonadicAlgebra f m a -> (Mu f -> m a)
> cataMemoM f = (`evalStateT` Map.empty)
>   . memoise (\cataM_f -> lift . f <=< mapM cataM_f . out)
> 
> anaMemoM :: (Traversable f, Ord a, Monad m) =>
>      MonadicCoAlgebra f m a -> a -> m (Mu f)
> anaMemoM f = (`evalStateT` Map.empty)
>   . memoise (\anaM_f -> lift . f >=> liftM In . mapM anaM_f)
> 
> cataLabelMM :: Mu TermF -> Writer [String] (Mu TermF)
> cataLabelMM = cataMemoM alg
> 
> anaLabelMM :: Mu TermF -> Writer [String] (Mu TermF)
> anaLabelMM = anaMemoM coAlg
> 
> t1 = let x = Mult (IntConst 2) (IntConst 3)
>      in Plus x x

Now nodes still get visited in pre-order using an anamorphism and post-order using a catamorphism but repeated nodes only get visited once.

*Main> execWriter $ cataLabelMM $ conv t1
["2","3","*","+"]
*Main> execWriter $ anaLabelMM $ conv t1
["+","*","2","3"]
Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s