module ELynx.Data.Tree.Zipper
(
TreePos (..),
fromTree,
toTree,
goUp,
goRoot,
goLeft,
goRight,
goChild,
goPath,
unsafeGoPath,
insertTree,
insertBranch,
insertLabel,
)
where
import Data.Foldable
import ELynx.Data.Tree.Rooted
data TreePos e a = Pos
{
current :: Tree e a,
before :: Forest e a,
after :: Forest e a,
parents :: [([Tree e a], e, a, [Tree e a])]
}
deriving (Show, Eq)
fromTree :: Tree e a -> TreePos e a
fromTree t = Pos {current = t, before = [], after = [], parents = []}
toTree :: TreePos e a -> Tree e a
toTree = current . goRoot
getForest :: TreePos e a -> Forest e a
getForest pos = foldl (flip (:)) (current pos : after pos) (before pos)
goUp :: TreePos e a -> Maybe (TreePos e a)
goUp pos = case parents pos of
(ls, br, lb, rs) : ps ->
Just
Pos
{ current = Node br lb $ getForest pos,
before = ls,
after = rs,
parents = ps
}
[] -> Nothing
goRoot :: TreePos e a -> TreePos e a
goRoot pos = maybe pos goRoot (goUp pos)
goLeft :: TreePos e a -> Maybe (TreePos e a)
goLeft pos =
case before pos of
t : ts ->
Just
pos
{ current = t,
before = ts,
after = current pos : after pos
}
[] -> Nothing
goRight :: TreePos e a -> Maybe (TreePos e a)
goRight pos =
case after pos of
t : ts ->
Just
pos
{ current = t,
before = current pos : before pos,
after = ts
}
[] -> Nothing
goChild :: Int -> TreePos e a -> Maybe (TreePos e a)
goChild n pos = case current pos of
(Node br lb ts)
| null ts -> Nothing
| length ts <= n -> Nothing
| otherwise ->
Just $
Pos
{ current = head rs',
before = reverse ls',
after = tail rs',
parents = (before pos, br, lb, after pos) : parents pos
}
where
(ls', rs') = splitAt n ts
goPath :: [Int] -> TreePos e a -> Maybe (TreePos e a)
goPath pos pth = foldlM (flip goChild) pth pos
unsafeGoChild :: Int -> TreePos e a -> TreePos e a
unsafeGoChild n pos = case current pos of
(Node br lb ts)
| null ts -> error "unsafeGoChild: Forest is empty."
| length ts <= n -> error "unsafeGoChild: Forest is too short."
| otherwise ->
Pos
{ current = head rs',
before = reverse ls',
after = tail rs',
parents = (before pos, br, lb, after pos) : parents pos
}
where
(ls', rs') = splitAt n ts
unsafeGoPath :: [Int] -> TreePos e a -> TreePos e a
unsafeGoPath pos pth = foldl (flip unsafeGoChild) pth pos
insertTree :: Tree e a -> TreePos e a -> TreePos e a
insertTree t pos = pos {current = t}
insertBranch :: e -> TreePos e a -> TreePos e a
insertBranch br pos = case current pos of
Node _ lb ts -> pos {current = Node br lb ts}
insertLabel :: a -> TreePos e a -> TreePos e a
insertLabel lb pos = case current pos of
Node br _ ts -> pos {current = Node br lb ts}