Personal tools

Zipper monad/TravelTree

From HaskellWiki

Jump to: navigation, search
TravelTree
is a library based on the Zipper monad which is used for traversing binary trees. Read the documentation for the Zipper monad if you haven't already.

Contents

1 Definition

data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Show, Eq)
 
data Cxt a = Top
           | L (Cxt  a) (Tree a)
           | R (Tree a) (Cxt  a)
             deriving (Show)
 
type TreeLoc    a = Loc (Cxt a) (Tree a)
type TravelTree a = Travel (TreeLoc a) (Tree a)
We go with the standard definition of a labelless binary tree.
Cxt
is for storing the context of an element, and
TreeLoc
for precisely defining the position of an element within a tree, at the same time as defining the tree itself. See Zipper for an explanation of that idiom.

2 Functions

2.1 Moving around

There are five main functions for stringing together
TravelTree
computations:
left,  -- moves down a level, through the left branch
right, -- moves down a level, through the right branch
swap,  -- moves from a left branch to a right branch, or vice versa
up,    -- moves to the node's parent
top    -- moves to the top node
:: TravelTree a

All five return the subtree at the new location.

2.2 Mutation

The three mutation functions defined by the generic Zipper monad (
modifyStruct
,
getStruct
and
putStruct
) are of course available, but there are no
TravelTree
-specific mutation functions.

2.3 Node classification

There are four functions you can call to find out what kind of node a given location points to:

isTop,   -- is the location the top node?
isChild, -- is the location the child of some other node (i.e. not the top)?
isLeft,  -- is the location a left branch?
isRight  -- is the location a right branch?
:: TreeLoc a -> Bool
Note that these functions are not monadic but instead take a
TreeLoc
. The
TreeLoc
pointing to the current node is stored as the state in a
TravelTree
computation. Thus to call these functions within a
do
block, use
liftM
:
do top <- liftM isTop get
   when top $ right >> return ()

3 Examples

The following examples use as the example tree:

t = Branch (Branch (Branch (Leaf 1) (Leaf 2))
                   (Leaf 3))
           (Branch (Leaf 4)
                   (Leaf 5))
(thumbnail)
The example tree

3.1 A simple path

This is a very simple example showing how to use the movement functions:

leftLeftRight :: TravelTree a
leftLeftRight = do left
                   left
                   right

Result of evaluation:

*Tree> (getTop t) `traverse` leftLeftRight
Leaf 2

3.2 Tree reverser

This is a more in-depth example showing
getTree
and
putTree
, but is still rather contrived as it's easily done without the zipper (the zipper-less version is shown below).

The algorithm reverses the tree, in the sense that at every branch, the two subtrees are swapped over.

revTree :: Tree a -> Tree a
revTree t = (getTop t) `traverse` revTree' where
    revTree' :: TravelTree a
    revTree' = do t <- getTree
                        case t of
                          Branch _ _ -> do left
                                           l' <- revTree'
                                           swap
                                           r' <- revTree'
                                           up
                                           putTree $ Branch r' l'
                          Leaf x     -> return $ Leaf x
 
-- without using the zipper:
revTreeZipless :: Tree a -> Tree a
revTreeZipless (Leaf x)       = Leaf x
revTreeZipless (Branch xs ys) = Branch (revTreeZipless ys) (revTreeZipless xs)

Result of evaluation:

*Tree> revTree $ Branch (Leaf 1) (Branch (Branch (Leaf 2) (Leaf 3)) (Leaf 4))
Branch (Branch (Leaf 4) (Branch (Leaf 3) (Leaf 2))) (Leaf 1)

3.2.1 Generalisation

Einar Karttunen (musasabi) suggested generalising this to a recursive tree mapper:

treeMap :: (a -> Tree a)                -- what to put at leaves
        -> (Tree a -> Tree a -> Tree a) -- what to put at branches
        -> (Tree a -> Tree a)           -- combinator function
treeMap leaf branch = \t -> (getTop t) `traverse` treeMap' where
    treeMap' = do t <- getTree
                  case t of
                    Branch _ _ -> do left
                                     l' <- treeMap'
                                     swap
                                     r' <- treeMap'
                                     up
                                     putTree $ branch l' r'
                    Leaf x     -> return $ leaf x
revTree
is then easy:
revTreeZipper :: Tree a -> Tree a
revTreeZipper = treeMap Leaf (flip Branch)
It turns out this is a fairly powerful combinator. As with
revTree
, it can change the structure of a tree. Here's another example which turns a tree into one where siblings are sorted, i.e. given a
Branch l r
, if
l
and
r
are leaves, then the value of
l
is less than or equal to that of
r
. Also, if one of
l
or
r
is a
Branch
and the other a
Leaf
, then
l
is the
Leaf
and
r
the
Branch
:
sortSiblings :: Ord a => Tree a -> Tree a
sortSiblings = treeMap Leaf minLeaves where
    minLeaves l@(Branch _ _) r@(Leaf _       ) = Branch r l
    minLeaves l@(Leaf _)     r@(Branch _ _   ) = Branch l r
    minLeaves l@(Branch _ _) r@(Branch _ _   ) = Branch l r
    minLeaves l@(Leaf x)     r@(Leaf y       ) = Branch (Leaf $ min x y)
                                                        (Leaf $ max x y)

Result of evaluation:

*Tree> sortSiblings t
Branch (Branch (Leaf 3) (Branch (Leaf 1) (Leaf 2))) (Branch (Leaf 4) (Leaf 5))

4 Code

The
ZipperTree
library (download):
module ZipperTree where
 
import Control.Monad.State
import Control.Arrow (first, second)
 
import Zipper
 
data Tree a = Leaf a | Branch (Tree a) (Tree a) deriving (Show, Eq)
 
data Cxt a = Top
           | L (Cxt  a) (Tree a)
           | R (Tree a) (Cxt  a)
             deriving (Show)
 
type TreeLoc    a = Loc (Cxt a) (Tree a)
type TravelTree a = Travel (TreeLoc a) (Tree a)
 
-- Utility Functions
--
 
-- repeat an action until the predicate becomes false
while :: Monad m => m Bool -> m a -> m [a]
while p act = do
  b <- p
  if b then liftM2 (:) act (while p act) else return []
 
-- Movement around the tree
--
 
-- swap branches
swap :: TravelTree a
swap = modify left' >> liftM struct get where
    left' (Loc t (R l c)) = Loc { struct = l,
                                  cxt    = L c t }
    left' (Loc t (L c r)) = Loc { struct = r,
                                  cxt    = R t c }
 
-- move down a level, through the left branch
left :: TravelTree a
left = modify left' >> liftM struct get where
    left' (Loc (Leaf _    ) _) = error "Down from leaf"
    left' (Loc (Branch l r) c) = Loc { struct = l,
                                       cxt    = L c r }
 
-- move down a level, through the left branch
right :: TravelTree a
right = modify right' >> liftM struct get where
    right' (Loc (Leaf _    ) _) = error "Down from leaf"
    right' (Loc (Branch l r) c) = Loc { struct = r,
                                        cxt    = R l c }
 
-- move to a node's parent
up :: TravelTree a
up = modify up' >> liftM struct get where 
    up' (Loc _     Top) = error "Up from top"
    up' (Loc t (L c r)) = Loc { struct = Branch t r, cxt = c }
    up' (Loc t (R l c)) = Loc { struct = Branch l t, cxt = c }
 
-- move to the top node
top :: TravelTree a
top = while (liftM isChild get) up >> liftM struct get
 
-- get the Loc corresponding to the top of the tree
-- useful for when calling traverse.
-- e.g. (getTop t) `traverse` myPath
getTop :: Tree a -> TreeLoc a
getTop t = (Loc t Top)
 
-- Node classification
--
 
-- is the top node
isTop :: TreeLoc a -> Bool
isTop loc = case loc of
              (Loc _ Top) -> True
              (Loc _ _  ) -> False
 
-- is not the top node (i.e. the child of some other node)
isChild :: TreeLoc a -> Bool
isChild = not . isTop
 
-- is a left branch
isLeft :: TreeLoc a -> Bool
isLeft loc = case loc of
               (Loc _ Top    ) -> True
               (Loc _ (L _ _)) -> True
               (Loc _ (R _ _)) -> False
 
-- is a right branch
isRight :: TreeLoc a -> Bool
isRight loc = isTop loc || (not $ isLeft loc)