Kurze Form der allgemeinen Katamorphismenfaltung.

catas.hs

import Data.Foldable ( Foldable, foldMap )
import Data.Function ( on )
import Data.Monoid   ( Monoid ( .. ) )

type Algebra f a = f a -> a

newtype Mu f = Fix ( f (Mu f) )

inject :: f (Mu f) -> Mu f
inject = Fix

eject :: Mu f -> f (Mu f)
eject (Fix x) = x

data ListF a f = ConsF a f | NilF  -- nicht induktiv!

type List a = Mu (ListF a)        -- induktiv

-- Smart-Konstruktoren

cons :: a -> List a -> List a
cons x xs = Fix (ConsF x xs)

infixr 7 <:>
(<:>) :: a -> List a -> List a
(<:>) = cons

nil :: List a
nil = Fix NilF

instance Functor (ListF a) where

    fmap f NilF = NilF
    fmap f (ConsF xa yb) = ConsF xa (f yb)

cata :: Functor f => Algebra f b -> Mu f -> b
cata g = g . fmap (cata g) . eject

hello :: List Char
hello = 'h' <:> 'e' <:> 'l' <:> 'l' <:> 'o' <:> nil

mkListAlgebra :: (a -> b -> b) -> b -> Algebra (ListF a) b
mkListAlgebra c _ (ConsF x xs) = c x xs
mkListAlgebra _ n NilF         = n

showAlgebra :: Show a => Algebra (ListF a) String
showAlgebra = mkListAlgebra (\x xs -> unwords [show x, ":", show xs]) "[]"

lengthAlgebra :: Algebra (ListF a) Int
lengthAlgebra = mkListAlgebra (\_ -> (1 +)) 0

numbers :: List Int
numbers = 4 <:> 8 <:> 15 <:> 16 <:> 23 <:> 42 <:> nil

sumAlgebra :: Num n => Algebra (ListF n) n
sumAlgebra = mkListAlgebra (+) 0 

andAlgebra :: Algebra (ListF Bool) Bool
andAlgebra = mkListAlgebra (&&) True

mapAlgebra :: (a -> b) -> Algebra (ListF a) (List b)
mapAlgebra f = mkListAlgebra (cons . f) nil



data TreeF a b f = BranchF f a f | LeafF b | EmptyF

instance Functor (TreeF a b) where

    fmap f (BranchF l v r)  = BranchF (f l) v (f r)
    fmap _ (LeafF x)        = LeafF x
    fmap _ EmptyF           = EmptyF

type Tree a b = Mu (TreeF a b)

data TreeU a = BranchU (TreeU a) a (TreeU a) | LeafU a | EmptyU
    deriving Show

transform :: Tree a b -> TreeU (Either a b)
transform = trafo . eject where
    trafo EmptyF          = EmptyU
    trafo (LeafF x)       = LeafU (Right x)
    trafo (BranchF l x r) = BranchU (transform l) (Left x) (transform r)

branch :: Tree a b -> a -> Tree a b -> Tree a b
branch left v right = Fix (BranchF left v right)

leaf :: b -> Tree a b
leaf x = Fix (LeafF x)

empty :: Tree a b
empty = Fix EmptyF

data Arith = Mult | Plus | Pow

instance Show Arith where

    show Mult = "*"
    show Plus = "+"
    show Pow  = "^"

toFun :: Num n => Arith -> n -> n -> n
toFun Mult = (*)
toFun Plus = (+)

compTree :: Tree Arith Int
compTree = branch (branch (leaf 2) Plus (leaf 3)) Mult (leaf 4)

mkTreeAlgebra :: (c -> a -> c -> c) -> (b -> c) -> c -> Algebra (TreeF a b) c
mkTreeAlgebra br le em (BranchF l v r) = br l v r
mkTreeAlgebra br le em (LeafF x)       = le x
mkTreeAlgebra br le em EmptyF          = em

depthAlgebra :: Algebra (TreeF a b) Int
depthAlgebra = mkTreeAlgebra (\l _ r -> 1 + max l r) (const 1) 0

showAlgebraTree :: (Show a, Show b) => Algebra (TreeF a b) String
showAlgebraTree = mkTreeAlgebra (\l v r -> concat ["(", unwords [l, show v, r], ")"]) show "°"

evalAlgebra :: Num n => Algebra (TreeF Arith n) n
evalAlgebra = mkTreeAlgebra (flip toFun) id 0

-- Transformation: Foldable.foldr vs. cata

-- The free monoid

data Free a = Free a :*: Free a | Single a | One

-- Answers the question, whether the value is the abstract product of two other values or not.

isComposite :: Free a -> Bool
isComposite (_ :*: _) = True
isComposite _         = False

instance Show a => Show (Free a) where
    
    showsPrec _ One        = showString "<1>"
    showsPrec _ (Single a) = shows a
    showsPrec p (x :*: y)  =   showParen (isComposite x) (showsPrec p x) 
                             . showString " <*> " 
                             . showParen (isComposite y) (showsPrec p y) 

-- The free monoid can be turned into a list.

toList :: Free a -> [a]
toList (x :*: y)  = toList x ++ toList y
toList (Single x) = [x]
toList One        = []

-- Eq instance that satisfies the monoid properties (see below).

instance Eq a => Eq (Free a) where

    (==) = (==) `on` toList

instance Monoid (Free a) where

    mappend = (:*:)
    mempty  = One

instance Foldable TreeU where

    foldMap f = go where
        go EmptyU = mempty
        go (LeafU val) = f val
        go (BranchU l val r) = go l `mappend` f val `mappend` go r

cataLikeFoldTree :: (c -> a -> c -> c) -> (b -> c) -> c -> Tree a b -> c
cataLikeFoldTree br le em = g . foldMap Single . transform where

    g (x :*: Single (Left val) :*: y) = br (g x) val (g y)
    g (Single (Right x))              = le x
    g One                             = em