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