Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
240 lines (175 sloc) 7.58 KB
-- This is Haskell code derived from the Bird-Meertens formulism used by Jeremy
-- Gibbons in "Upwards and downwards accumulations on trees" (1993).
--
-- See http://www.citeulike.org/user/spl/article/5486052 for the article
-- reference and links.
module Accumulations where
import Prelude hiding (last)
import Data.Char (ord)
import Data.Monoid
--------------------------------------------------------------------------------
-- 2. Notation
--------------------------------------------------------------------------------
-- product (unused in my code)
(.||) :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)
(.||) f g (a, b) = (f a, g b)
infixr 9 .||
-- sum (unused in my code)
(.|) :: (a -> c) -> (b -> d) -> Either a b -> Either c d
(.|) f _ (Left a) = Left (f a)
(.|) _ g (Right b) = Right (g b)
-- ↟
fork :: (a -> b) -> (a -> c) -> a -> (b, c)
fork f g a = (f a, g a)
-- ↡ (unused in my code, because it's replaced by constructor alternatives and
-- function arguments)
join :: (b -> a) -> (c -> a) -> Either b c -> a
join h _ (Left a) = h a
join _ k (Right b) = k b
data Tree a
= Leaf a -- △
| Branch (Tree a) a (Tree a) -- ┴
deriving (Eq, Show)
-- postfix * for Tree
instance Functor Tree where
fmap f (Leaf a) = Leaf (f a)
fmap f (Branch x a y) = Branch (fmap f x) (f a) (fmap f y)
-- Examples
five = Branch (Leaf 'b') 'a' (Branch (Leaf 'd') 'c' (Leaf 'e'))
five' = fmap ord five
-- Catamorphism for Tree
cataTree :: (a -> b) -> (b -> a -> b -> b) -> Tree a -> b
cataTree f _ (Leaf a) = f a
cataTree f g (Branch x a y) = g (cataTree f g x) a (cataTree f g y)
leaves = cataTree (const 1) (\u _ v -> u + v)
branches = cataTree (const 0) (\u _ v -> u + 1 + v)
--------------------------------------------------------------------------------
-- 3. Upwards accumulations
--------------------------------------------------------------------------------
subtrees :: Tree a -> Tree (Tree a)
subtrees (Leaf a) = Leaf (Leaf a)
subtrees (Branch x a y) = Branch (subtrees x) (Branch x a y) (subtrees y)
root :: Tree a -> a
root (Leaf a) = a
root (Branch _ a _) = a
prop_subtrees1 x = root (subtrees x) == x
subtrees' :: Tree a -> Tree (Tree a)
subtrees' = cataTree (Leaf . Leaf) (\u a v -> Branch u (Branch (root u) a (root v)) v)
prop_subtrees2 x = subtrees x == subtrees' x
upwards_pass :: (Tree a -> b) -> Tree a -> Tree b
upwards_pass g = fmap g . subtrees
-- ⇑
upwards_accum :: (a -> b) -> (b -> a -> b -> b) -> Tree a -> Tree b
upwards_accum f g = fmap (cataTree f g) . subtrees
sizes = fmap size . subtrees
size = cataTree (const 1) (\u _ v -> u + 1 + v)
sizes' = upwards_accum (const 1) (\u _ v -> u + 1 + v)
prop_sizes x = sizes x == sizes' x
--------------------------------------------------------------------------------
-- 4. Downwards accumulations
--------------------------------------------------------------------------------
data Thread a
= TLeaf a -- ♢
| TLeft (Thread a) a -- ↙, left snoc
| TRight (Thread a) a -- ↘, right snoc
deriving (Eq, Show)
-- Catamorphism for Thread
cataThread :: (a -> b) -> (b -> a -> b) -> (b -> a -> b) -> Thread a -> b
cataThread f _ _ (TLeaf a) = f a
cataThread f g h (TLeft x a) = g (cataThread f g h x) a
cataThread f g h (TRight y a) = h (cataThread f g h y) a
paths :: Tree a -> Tree (Thread a)
paths (Leaf a) = Leaf (TLeaf a)
paths (Branch x a y) = Branch (fmap (left a) (paths x)) (TLeaf a) (fmap (right a) (paths y))
where
-- cons
left b = cataThread (TLeft (TLeaf b)) TLeft TRight
right b = cataThread (TRight (TLeaf b)) TLeft TRight
downwards_pass :: (Thread a -> b) -> Tree a -> Tree b
downwards_pass g = fmap g . paths
-- ⇓
downwards_accum :: (a -> b) -> (b -> a -> b) -> (b -> a -> b) -> Tree a -> Tree b
downwards_accum f g h = fmap (cataThread f g h) . paths
downwards_pass' :: (a -> b) -> (a -> b -> b) -> (a -> b -> b) -> Tree a -> Tree b
downwards_pass' f _ _ (Leaf a) = Leaf (f a)
downwards_pass' f g h (Branch x a y) = Branch (fmap (g a) (downwards_pass' f g h x)) (f a) (fmap (h a) (downwards_pass' f g h y))
data Daerht a
= DLeaf a -- ♢
| DRight a (Daerht a) -- ↗, right cons
| DLeft a (Daerht a) -- ↖, left cons
-- Catamorphism for Daerht
cataDaerht :: (a -> b) -> (a -> b -> b) -> (a -> b -> b) -> Daerht a -> b
cataDaerht f _ _ (DLeaf a) = f a
cataDaerht f g h (DRight a y) = g a (cataDaerht f g h y)
cataDaerht f g h (DLeft a x) = h a (cataDaerht f g h x)
td :: Thread a -> Daerht a
td = cataThread DLeaf right left
where
-- snoc
right p a = cataDaerht (\b -> DRight b (DLeaf a)) DRight DLeft p
left p a = cataDaerht (\b -> DLeft b (DLeaf a)) DRight DLeft p
downwards_pass'' :: (a -> b) -> (a -> b -> b) -> (a -> b -> b) -> Tree a -> Tree b
downwards_pass'' f g h = fmap (cataDaerht f g h) . fmap td . paths
depths :: Tree a -> Tree Int
depths (Leaf a) = Leaf 1
depths (Branch x _ y) = Branch (fmap (+1) (depths x)) 1 (fmap (+1) (depths y))
depths' :: Tree a -> Tree Int
depths' = downwards_accum (const 1) (\u _ -> u + 1) (\v _ -> v + 1)
prop_depths x = depths x == depths' x
--------------------------------------------------------------------------------
-- 5. Parallel prefix
--------------------------------------------------------------------------------
-- Non-empty list
data List a
= One a -- ▢
| Append (List a) (List a) -- ++
-- postfix * for List
instance Functor List where
fmap f (One a) = One (f a)
fmap f (Append x y) = Append (fmap f x) (fmap f y)
-- Catamorphism for List
cataList :: (a -> b) -> (b -> b -> b) -> List a -> b
cataList f _ (One a) = f a
cataList f g (Append x y) = g (cataList f g x) (cataList f g y)
last = cataList id (\u v -> v)
inits = cataList (One . One) (\u v -> Append u (fmap (Append (last u)) v))
ps :: (a -> b) -> (b -> b -> b) -> List a -> List b
ps f g = fmap (cataList f g) . inits
fringe :: Tree a -> List a
fringe = cataTree One (\u _ v -> Append u v)
-- The off-used 's' mentioned inline in the text on page 133
s f g = cataList f g . fringe
tps1 :: (a -> b) -> (b -> b -> b) -> Tree a -> Tree b
tps1 f _ (Leaf a) = Leaf (f a)
tps1 f g (Branch x a y) = Branch (tps1 f g x) (s f g x) (fmap (g (s f g x)) (tps1 f g y))
prop_tps1 f g x = fringe (tps1 f g x) == ps f g (fringe x)
up1 :: (a -> b) -> (b -> b -> b) -> Tree a -> Tree b
up1 f _ (Leaf a) = Leaf (f a)
up1 f g (Branch x a y) = Branch (up1 f g x) (s f g x) (up1 f g y)
down1 :: (b -> b -> b) -> Tree b -> Tree b
down1 _ (Leaf b) = Leaf b
down1 g (Branch x b y) = Branch (down1 g x) b (fmap (g b) (down1 g y))
prop_tps2 f g x = tps1 f g x == down1 g (up1 f g x)
sl :: (a -> b) -> (b -> b -> b) -> Tree a -> b
sl f _ (Leaf a) = f a
sl f g (Branch x _ _) = s f g x
up2 :: (a -> b) -> (b -> b -> b) -> Tree a -> Tree b
up2 f g = fmap (sl f g) . subtrees
s_fork_sl1 :: (a -> b) -> (b -> b -> b) -> Tree a -> (b, b)
s_fork_sl1 f g = fork (s f g) (sl f g)
-- The unnamed right component of the catamorphism for 's ↟ sl'. It doesn't seem
-- to quite match what Gibbons wrote, so I'm not fully convinced it's correct.
pairs :: (b -> b -> b) -> (b, b) -> a -> (b, b) -> (b, b)
pairs g (x, _) _ (y, _) = (g x y, x)
s_fork_sl2 :: (a -> b) -> (b -> b -> b) -> Tree a -> (b, b)
s_fork_sl2 f g = cataTree (fork f f) (pairs g)
up3 :: (a -> b) -> (b -> b -> b) -> Tree a -> Tree b
up3 f g = fmap snd . upwards_accum (fork f f) (pairs g)
down2 :: (Monoid b) => (b -> b -> b) -> Tree b -> Tree b
down2 g = fmap snd . downwards_accum (fork (const mempty) id) plus cros
where
plus (b, c) d = (b, g b d)
cros (b, c) d = (c, g c d)
tps2 :: (Monoid b) => (a -> b) -> (b -> b -> b) -> Tree a -> Tree b
tps2 f g = down2 g . up3 f g
prop_tps3 f g x = tps1 f g x == tps2 f g x
Jump to Line
Something went wrong with that request. Please try again.