# Zipper monad/TravelTree

### From HaskellWiki

< Zipper monad(Difference between revisions)

DavidHouse (Talk | contribs) m (adding download link) |
DavidHouse (Talk | contribs) (removing code, adding entire library download link) |
||

Line 153: | Line 153: | ||

== Code == |
== Code == |
||

− | The <hask>ZipperTree</hask> library ([http://haskell.org/sitewiki/images/8/8b/ZipperTree.hs download]): |
+ | The code for the TravelTree library is quite length, so you can just [http://haskell.org/sitewiki/images/8/8b/ZipperTree.hs download] it. Alternatively, you could download the [http://haskell.org/sitewiki/images/b/b7/Zipper.tar.gz entire zipper library]. |

− | |||

− | <haskell> |
||

− | 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) |
||

− | </haskell> |

## Revision as of 22:29, 19 April 2006

TravelTree

## 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)

Cxt

*context*of an element, and

TreeLoc

## 2 Functions

### 2.1 Moving around

There are five main functions for stringing togetherTravelTree

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

putStruct

TravelTree

### 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

TreeLoc

TreeLoc

TravelTree

do

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))

### 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 showinggetTree

putTree

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

revTreeZipper :: Tree a -> Tree a revTreeZipper = treeMap Leaf (flip Branch)

revTree

Branch l r

l

r

l

r

l

r

Branch

Leaf

l

Leaf

r

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 code for the TravelTree library is quite length, so you can just download it. Alternatively, you could download the entire zipper library.