Personal tools

User talk:Kr.angelov

From HaskellWiki

Jump to: navigation, search
--
-- 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