public
Last active

Initial algebras and final coalgebras

  • Download Gist
algebras.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
{-# LANGUAGE RankNTypes, DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
module Main where
import Criterion.Main (defaultMain, bench, bgroup, nf)
 
--------------------------------------------------------------------------------
-- Fixed points of a functor
 
newtype Mu f = Mu { muF :: f (Mu f) }
 
--------------------------------------------------------------------------------
-- Initial algebras
 
type Algebra f a = f a -> a
 
-- | This is a generic catamorphism.
ffold :: Functor f => Algebra f a -> Mu f -> a
ffold h = go h where go g = g . fmap (go g) . muF
--ffold h = h . fmap (ffold h) . muF -- This is a slow definition
{-# INLINE[1] ffold #-}
 
fbuild :: Functor f => (forall b. Algebra f b -> b) -> Mu f
fbuild g = g Mu
{-# INLINE[1] fbuild #-}
 
--------------------------------------------------------------------------------
-- Final coalgebras
 
type Coalgebra f a = a -> f a
 
-- | This is a generic anamorphism.
funfold :: Functor f => Coalgebra f b -> b -> Mu f
funfold h = go h where go g = Mu . fmap (go g) . g
--funfold h = Mu . fmap (funfold h) . h -- This is a slow definition
{-# INLINE[1] funfold #-}
 
funbuild :: Functor f => (Coalgebra f (Mu f) -> b) -> b
funbuild g = g muF
{-# INLINE[1] funbuild #-}
 
--------------------------------------------------------------------------------
-- Meta/hylomorphisms, and RULE optimizations
 
hylo :: Functor f => Algebra f c -> Coalgebra f a -> a -> c
hylo f h = ffold f . funfold h
{-# INLINE[2] hylo #-}
 
meta :: Functor f => Coalgebra f b -> Algebra f b -> Mu f -> Mu f
meta f h = funfold f . ffold h
{-# INLINE[2] meta #-}
 
{-# RULES
-- Builder rule for catamorphisms
"ffold/fbuild" forall f (g :: forall b. Algebra f b -> b).
ffold f (fbuild g) = g f
 
-- Builder rule for anamorphisms
"funfold/funbuild" forall f g.
funfold f (funbuild g) = g f
 
-- Hylomorphism rule
"ffold/funfold" forall f g x.
ffold f (funfold g x) = f (g x)
 
-- Metamorphism rule
"funfold/ffold" forall f g x.
funfold f (ffold g x) = g (f x)
#-}
 
--------------------------------------------------------------------------------
-- Naturals
 
-- μX. 1 + X
data NatF f = Z | S f
deriving (Eq, Show, Functor)
type Nat = Mu NatF
 
instance Eq Nat where
(Mu f) == (Mu g) = f == g
 
addN :: Nat -> Nat -> Nat
addN (Mu Z) m = m
addN (Mu (S f)) m = Mu $ S (addN f m)
{-# INLINE addN #-}
 
toI :: Nat -> Int
toI = ffold g
where g Z = 0
g (S x) = 1 + x
{-# INLINE toI #-}
 
nat1 :: Nat
nat1 = s (s (s z))
where z = Mu Z
s x = Mu (S x)
 
nat2 :: Nat
nat2 = s (s z)
where z = Mu Z
s x = Mu (S x)
 
--------------------------------------------------------------------------------
-- Lists
 
-- μX. 1 + A * X
data ListF a f = Nil | Cons a f
deriving (Eq, Show, Functor)
type List a = Mu (ListF a)
 
instance Eq a => Eq (List a) where
(Mu f) == (Mu g) = f == g
 
lengthL :: List a -> Int
lengthL = ffold g
where g Nil = 0
g (Cons _ f) = 1 + f
{-# INLINE lengthL #-}
 
mapL :: (a -> b) -> List a -> List b
mapL f = ffold g
where g Nil = Mu Nil
g (Cons a x) = Mu (Cons (f a) x)
{-# INLINE mapL #-}
 
-- | Different implementation via fbuild, which should fuse
-- with other List functions.
mapL2 :: (a -> b) -> List a -> List b
mapL2 f xs = fbuild (\h -> ffold (h . g) xs)
where g Nil = Nil
g (Cons a x) = Cons (f a) x
{-# INLINE mapL2 #-}
 
-- | Different implementation via hylomorphisms.
mapL3 :: (a -> b) -> List a -> List b
mapL3 f = hylo g muF
where
g Nil = Mu Nil
g (Cons a x) = Mu $ Cons (f a) x
{-# INLINE mapL3 #-}
 
list1 :: List Int
list1 = c 1 (c 2 (c 3 (c 4 (c 5 (c 6 (c 7 (c 8 n)))))))
where n = Mu Nil
c a r = Mu (Cons a r)
 
--------------------------------------------------------------------------------
-- Trees
 
-- μX. A + A*X*X
data TreeF a f = Leaf a | Tree a f f
deriving (Eq, Show, Functor)
type Tree a = Mu (TreeF a)
 
instance Eq a => Eq (Tree a) where
(Mu f) == (Mu g) = f == g
 
depthT :: Tree a -> Int
depthT = ffold g
where g (Leaf _) = 0
g (Tree _ l r) = 1 + max l r
{-# INLINE depthT #-}
 
sumT :: Tree a -> Int
sumT = ffold g
where g (Leaf _) = 1
g (Tree _ l r) = l + r
{-# INLINE sumT #-}
 
tree1 :: Tree Int
tree1 = tree 7 (tree 5 (leaf 2) (leaf 6))
(tree 9 (leaf 8)
(tree 11 (leaf 10)
(leaf 13)))
where
tree x l r = Mu (Tree x l r)
leaf x = Mu (Leaf x)
 
--------------------------------------------------------------------------------
-- Driver and benchmarks
 
main :: IO ()
main = defaultMain
[ bgroup "nat"
[ bench "add1" $ nf toI (addN nat1 nat2)
, bench "add2" $ nf toI (addN nat2 nat1)
]
, bgroup "list"
[ bench "length" $ nf lengthL list1
, bench "map" $ nf lengthL $ mapL (+1) list1
, bench "map2" $ nf lengthL $ mapL2 (+1) list1
, bench "map3" $ nf lengthL $ mapL3 (+1) list1
]
, bgroup "tree"
[ bench "depth" $ nf depthT tree1
, bench "sum" $ nf sumT tree1
]
, bgroup "rewrite"
[ bench "length/map[ffold/ffold]" $ nf (lengthL . mapL (+1)) list1
-- The ffold/fbuild rule cuts runtime in half.
, bench "length/map[ffold/fbuild]" $ nf (lengthL . mapL2 (+1)) list1
]
]

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.