# Zipper monad/TravelTree

### From HaskellWiki

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

TheZipperTree

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)