CiteULike spl's CiteULike Search Register Log in
CiteULike is a free online bibliography manager. Register and you can start organising your references online.

Upwards and downwards accumulations on trees Export

by: Jeremy Gibbons
Mathematics of Program Construction In MPC 1993 (1993), pp. 122-138.

Citation Format

[Posts]

View FullText article


X Reviews [Write a review of this article]

X Notes for this article

spl has 0 private notes and 1 public note for this article.

This is Haskell code derived from the Bird-Meertens formalism used in this paper. I only encountered one issue when writing this. Note the pairs function and compare it to the original (unnamed) component in the article. 

    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
spl (public note) - 2009-09-09 13:07:37

X Find related articles from these CiteULike users

X Find related articles with these CiteULike tags

X Posting History

X Abstract

An accumulation is a higher-order operation over structured objects of some type; it leaves the shape of an object unchanged, but replaces each element of that object with some accumulated information about the other elements. Upwards and downwards accumulations on trees are two instances of this scheme; they replace each element of a tree with some function—in fact, some homomorphism—of that element's descendants and of its ancestors, respectively. These two operations can be thought of as passing information up and down the tree.We introduce these two accumulations, and show how together they solve the so-called prefix sums problem.


X BibTeX record

X RIS record


Privacy Statement | Terms & Conditions
CiteULike organises scholarly (or academic) papers or literature and provides bibliographic (which means it makes bibliographies) for universities and higher education establishments. It helps undergraduates and postgraduates. People studying for PhDs or in postdoctoral (postdoc) positions. The service is similar in scope to EndNote or RefWorks or any other reference manager like BibTeX, but it is a social bookmarking service for scientists and humanities researchers.