User talk:Kr.angelov
Revision as of 06:36, 24 May 2008 by Kr.angelov (talk | contribs)
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
--
-- Copyright (c) Krasimir Angelov 2008.
--
-- Generic zipper implementation for Data.Tree
--
module Data.Tree.Zipper
( TreeLoc(..), TreeCxt(..)
-- * Moving Around
, down
, firstChild
, lastChild
, up
, left
, right
, top
, getTree
-- * Node classification
, isTop
, isChild
, isFirst
, isLast
, hasChildren
-- * Tree-specific Mutation
, insertLeft
, insertRight
, insertDown
, insertDownAt
, delete
-- * Monad
, modifyLabel
, putLabel
, getLabel
) where
import Data.Tree
data TreeCxt a = Top
| Child { label :: a,
parent :: TreeCxt a, -- parent's context
lefts :: [Tree a], -- siblings to the left
rights :: [Tree a] -- siblings to the right
}
deriving (Show, Eq)
data TreeLoc a = Loc { tree :: Tree a,
treeCxt :: TreeCxt a
}
deriving (Show, Eq)
-- Moving Around
--
-- | move down to the nth child
down :: Int -> TreeLoc a -> Maybe (TreeLoc a)
down n (Loc (Node v cs) c) = case splitChildren [] cs (n+1) of
Just (t:ls,rs) -> let c' = Child { label = v,
parent = c,
lefts = ls,
rights = rs }
in Just (Loc { tree = t, treeCxt = c' })
Nothing -> Nothing
-- | move down to the first child
firstChild :: TreeLoc a -> Maybe (TreeLoc a)
firstChild (Loc (Node _ [] ) _) = Nothing
firstChild (Loc (Node v (t:ts)) c) = let c' = Child { label = v,
parent = c,
lefts = [],
rights = ts }
in Just (Loc { tree = t, treeCxt = c' })
-- | move down to the last child
lastChild :: TreeLoc a -> Maybe (TreeLoc a)
lastChild (Loc (Node v ts) c) =
case reverse ts of
[] -> Nothing
(t:ts) -> let c' = Child { label = v,
parent = c,
lefts = ts,
rights = [] }
in Just (Loc { tree = t, treeCxt = c' })
-- | move up
up :: TreeLoc a -> Maybe (TreeLoc a)
up (Loc _ Top ) = Nothing
up (Loc t (Child v c ls rs)) = Just (Loc { tree = Node v (combChildren ls t rs), treeCxt = c })
-- | move left a sibling
left :: TreeLoc a -> Maybe (TreeLoc a)
left (Loc t Top ) = Nothing
left (Loc t (Child v c ls rs)) =
case ls of
[] -> Nothing
(l:ls) -> let c' = Child { label = v,
parent = c,
lefts = ls,
rights = t : rs }
in Just (Loc { tree = l, treeCxt = c' })
-- | move right a sibling
right :: TreeLoc a -> Maybe (TreeLoc a)
right (Loc t Top ) = Nothing
right (Loc t (Child v c ls rs)) =
case rs of
[] -> Nothing
(r:rs) -> let c' = Child { label = v,
parent = c,
lefts = t:ls,
rights = rs }
in Just (Loc { tree = r, treeCxt = c' })
-- | get the Loc corresponding to the top of the tree
top :: Tree a -> TreeLoc a
top t = (Loc t Top)
-- | move to the top node
getTree :: TreeLoc a -> Tree a
getTree (Loc t Top ) = t
getTree (Loc t (Child v c ls rs)) = getTree (Loc { tree = Node v (combChildren ls t rs), treeCxt = c })
-- 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 the first node in its siblings list?
isFirst :: TreeLoc a -> Bool
isFirst loc = case loc of
(Loc _ Top ) -> True
(Loc _ (Child _ _ [] _)) -> True
(Loc _ _ ) -> False
-- | is the last node in its siblings list?
isLast :: TreeLoc a -> Bool
isLast loc = case loc of
(Loc _ Top ) -> True
(Loc _ (Child _ _ _ [])) -> True
(Loc _ _ ) -> False
-- | is there children
hasChildren :: TreeLoc a -> Bool
hasChildren = not . null . subForest . tree
-- Tree-specific Mutation
--
-- | insert a subtree to the left of the current node
insertLeft :: Tree a -> TreeLoc a -> Maybe (TreeLoc a)
insertLeft t' (Loc _ Top) = Nothing
insertLeft t' (Loc t c ) = let c' = Child { label = label c,
parent = parent c,
rights = t : rights c,
lefts = lefts c }
in Just (Loc { tree = t', treeCxt = c' })
-- | insert a subtree to the right of the current node
insertRight :: Tree a -> TreeLoc a -> Maybe (TreeLoc a)
insertRight t' (Loc _ Top) = Nothing
insertRight t' (Loc t c ) = let c' = Child { label = label c,
parent = parent c,
rights = rights c,
lefts = t:lefts c }
in Just (Loc { tree = t', treeCxt = c' })
-- | insert a subtree as the last child of the current node
insertDown :: Tree a -> TreeLoc a -> TreeLoc a
insertDown t' (Loc (Node v cs) c) = let c' = Child { label = v,
parent = c,
rights = [],
lefts = reverse cs }
in Loc { tree = t', treeCxt = c' }
-- | insert a subtree as the nth child of the current node
insertDownAt :: Tree a -> Int -> TreeLoc a -> Maybe (TreeLoc a)
insertDownAt t' n (Loc (Node v cs) c) = case splitChildren [] cs n of
Just (ls,rs) -> let c' = Child { label = v,
parent = c,
lefts = ls,
rights = rs }
in Just (Loc { tree = t', treeCxt = c' })
Nothing -> Nothing
-- | delete the current subtree. move right if possible, otherwise left if
-- possible, otherwise fail
delete :: TreeLoc a -> Maybe (TreeLoc a)
delete (Loc _ Top) = Nothing
-- if no siblings, move up
delete l@(Loc t c) | isLast l && isFirst l =
let c' = Child { label = label $ parent c,
parent = parent $ parent c,
lefts = lefts $ parent c,
rights = rights $ parent c }
in Just (Loc { tree = Node (label c) [], treeCxt = c' })
-- if the last node, move left
| isLast l =
let c' = Child { label = label c,
parent = parent c,
lefts = tail $ lefts c,
rights = rights c }
in Just (Loc { tree = head $ lefts c, treeCxt = c' })
-- otherwise, just move right
| otherwise =
let c' = Child { label = label c,
parent = parent c,
lefts = lefts c,
rights = tail $ rights c }
in Just (Loc { tree = head $ rights c, treeCxt = c' })
-- Monad
--
-- | modify the label at the current node
modifyLabel :: (a -> a) -> TreeLoc a -> TreeLoc a
modifyLabel f (Loc (Node v ts) c) = Loc (Node (f v) ts) c
-- | put a new label at the current node
putLabel :: a -> TreeLoc a -> TreeLoc a
putLabel v (Loc (Node _ ts) c) = Loc (Node v ts) c
-- | get the current label
getLabel :: TreeLoc a -> a
getLabel = rootLabel . tree
-- Utils
--
splitChildren acc xs 0 = Just (acc,xs)
splitChildren acc (x:xs) n = splitChildren (x:acc) xs $! n-1
splitChildren acc [] n = Nothing
combChildren ls t rs = foldl (flip (:)) (t:rs) ls