concrete examples of hylomorphism & metamorphism

hylometa.hs

import Data.Maybe
import Test.QuickCheck

-- ----------------------------------------------------------------------------
-- catamorphism & anamorphism over list

lcata :: (alpha -> beta -> beta) -> beta -> [alpha] -> beta
lcata f b []     = b
lcata f b (a:as) = f a (lcata f b as)

lana :: (beta -> Maybe(alpha, beta)) -> beta -> [alpha]
lana f b = case f b of
  Just (a, b') -> a:lana f b'
  Nothing      -> []

-- ----------------------------------------------------------------------------
-- recursive hylo & metamorphism over list

lhylo :: beta -> (alpha -> Maybe(gam, alpha)) -> (gam -> beta -> beta) -> alpha -> beta
lhylo init f g a = case f a of
  Nothing     -> init
  Just (x, y) -> g x (lhylo init f g y)

lmeta :: (gam -> Maybe (beta, gam)) -> (alpha -> gam -> gam) -> gam -> [alpha] -> [beta]
lmeta f g c x = case f c of
  Just(b, c') -> b:(lmeta f g c' x)
  Nothing     -> case x of
    []   -> []
    a:x' -> lmeta f g (g a c) x'

-- ----------------------------------------------------------------------------
-- map f . map g = map (f . g)
-- execution example: mapE (* 3) (+ 3) [1..20]

-- map with catamorphism
mapC f = lcata func []
  where
    func x xs = (f x):xs

-- map with anamorphism
mapA f = lana func
  where
    func []     = Nothing
    func (x:xs) = Just(f x, xs)

-- map fusion with hylomorphism
mapH f g = lcata func1 [] . lana func2
  where
    func1 x xs = (f x):xs
    func2 []     = Nothing
    func2 (x:xs) = Just(g x, xs)

-- map fusion with fusioned hylomorphism
mapHF f g = lhylo [] func2 func1
  where
    func1 x xs = (f x):xs
    func2 []     = Nothing
    func2 (x:xs) = Just(g x, xs)

-- map fusion with metamorphism
mapE f g = lana func2 . lcata func1 []
  where
    func1 x xs = (g x):xs
    func2 []     = Nothing
    func2 (x:xs) = Just(f x, xs)

-- map fusion with fusioned metamorphism
mapEF f g = lmeta func2 func1 []
  where
    func1 x xs = (f x):xs
    func2 []     = Nothing
    func2 (x:xs) = Just(g x, xs)

-- ----------------------------------------------------------------------------
-- sorting with hylomorphism & metamorphism

data Tree alpha = Node(Maybe(alpha, Tree(alpha), Tree(alpha))) deriving Show

foldt :: (Maybe(alpha, beta, beta) -> beta) -> Tree(alpha) -> beta
foldt f (Node Nothing)         = f Nothing
foldt f (Node (Just(a, t, u))) = f $ Just(a, foldt f t, foldt f u)

unfoldt :: (beta -> Maybe(alpha, beta, beta)) -> beta -> Tree(alpha)
unfoldt f b = case f b of
  Nothing         -> Node Nothing
  Just(a, b1, b2) -> Node(Just(a, unfoldt f b1, unfoldt f b2))

partition :: (Ord alpha) => [alpha] -> Maybe(alpha, [alpha], [alpha])
partition []          = Nothing
partition (a:as)      = Just(a, filter (< a) as, filter (> a) as)

join :: Maybe (alpha, [alpha], [alpha]) -> [alpha]
join Nothing          = []
join (Just(a, x, y))  = x ++ [a] ++ y

quicksort :: (Ord alpha) => [alpha] -> [alpha]
quicksort = foldt join . unfoldt partition

insert :: (Ord alpha) =>  alpha -> Tree(alpha) -> Tree(alpha)
insert a t = merge (Node(Just(a, e, e)), t)
  where
    e = Node Nothing

splitMin ::  (Ord alpha) => Tree(alpha) -> Maybe(alpha, Tree(alpha))
splitMin (Node t) = case t of
  Nothing       -> Nothing
  Just(a, u, v) -> Just(a, merge(v, u))

merge :: (Ord alpha) => (Tree(alpha), Tree(alpha)) -> Tree(alpha)
merge(t, Node Nothing) = t
merge(Node Nothing, u) = u
merge(Node x, Node y)  = if a < b
  then Node(Just(a, t2, merge(t1, Node y)))
  else Node(Just(b, u2, merge(u1, Node x)))
  where
    Just(a, t1, t2) = x
    Just(b, u1, u2) = y

heapsort :: (Ord alpha) => [alpha] -> [alpha]
heapsort = lana splitMin . lcata insert (Node Nothing)

isSorted xs = and $ zipWith (<=) xs (drop 1 xs)

-- quickCheck checkQuicksort
checkQuicksort xs = isSorted $ quicksort xs
  where types = xs :: [Int]

-- quickCheck checkHeapsort
checkHeapsort xs = isSorted $ quicksort xs
  where types = xs :: [Int]

-- ----------------------------------------------------------------------------
-- filter examples

-- filter with catamorphism
filterC f = lcata func []
  where
    func x xs = if f x then x:xs else xs

-- map filter fusion with metamorphism
mapfilterM f g = lana func2 . lcata func1 []
  where
    func1 x xs   = if f x then x:xs else xs
    func2 []     = Nothing
    func2 (x:xs) = Just(g x, xs)

-- mapfilterM (5 <) (5 +) [1..10]

-- map filter fusion with fusioned metamorphism
mapfilterMF f g = lmeta func2 func1 []
  where
    func1 x xs   = if f x then x:xs else xs
    func2 []     = Nothing
    func2 (x:xs) = Just(g x, xs)

-- mapfilterMF (5 <) (5 +) [1..10]