mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 19:22:50 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
257
src-3.0/GF/Data/Zipper.hs
Normal file
257
src-3.0/GF/Data/Zipper.hs
Normal file
@@ -0,0 +1,257 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Zipper
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/11 20:27:05 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.9 $
|
||||
--
|
||||
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.Zipper (-- * types
|
||||
Tr(..),
|
||||
Path(..),
|
||||
Loc(..),
|
||||
-- * basic (original) functions
|
||||
leaf,
|
||||
goLeft, goRight, goUp, goDown,
|
||||
changeLoc,
|
||||
changeNode,
|
||||
forgetNode,
|
||||
-- * added sequential representation
|
||||
goAhead,
|
||||
goBack,
|
||||
-- ** n-ary versions
|
||||
goAheadN,
|
||||
goBackN,
|
||||
-- * added mappings between locations and trees
|
||||
loc2tree,
|
||||
loc2treeMarked,
|
||||
tree2loc,
|
||||
goRoot,
|
||||
goLast,
|
||||
goPosition,
|
||||
getPosition,
|
||||
keepPosition,
|
||||
-- * added some utilities
|
||||
traverseCollect,
|
||||
scanTree,
|
||||
mapTr,
|
||||
mapTrM,
|
||||
mapPath,
|
||||
mapPathM,
|
||||
mapLoc,
|
||||
mapLocM,
|
||||
foldTr,
|
||||
foldTrM,
|
||||
mapSubtrees,
|
||||
mapSubtreesM,
|
||||
changeRoot,
|
||||
nthSubtree,
|
||||
arityTree
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq)
|
||||
|
||||
data Path a =
|
||||
Top
|
||||
| Node ([Tr a], (Path a, a), [Tr a])
|
||||
deriving Show
|
||||
|
||||
leaf :: a -> Tr a
|
||||
leaf a = Tr (a,[])
|
||||
|
||||
newtype Loc a = Loc (Tr a, Path a) deriving Show
|
||||
|
||||
goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a)
|
||||
goLeft (Loc (t,p)) = case p of
|
||||
Top -> Bad "left of top"
|
||||
Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right))
|
||||
Node _ -> Bad "left of first"
|
||||
goRight (Loc (t,p)) = case p of
|
||||
Top -> Bad "right of top"
|
||||
Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right))
|
||||
Node _ -> Bad "right of first"
|
||||
goUp (Loc (t,p)) = case p of
|
||||
Top -> Bad "up of top"
|
||||
Node (left, (up,v), right) ->
|
||||
return $ Loc (Tr (v, reverse left ++ (t:right)), up)
|
||||
goDown (Loc (t,p)) = case t of
|
||||
Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees))
|
||||
_ -> Bad "down of empty"
|
||||
|
||||
changeLoc :: Loc a -> Tr a -> Err (Loc a)
|
||||
changeLoc (Loc (_,p)) t = return $ Loc (t,p)
|
||||
|
||||
changeNode :: (a -> a) -> Loc a -> Loc a
|
||||
changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p)
|
||||
|
||||
forgetNode :: Loc a -> Err (Loc a)
|
||||
forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p)
|
||||
forgetNode _ = Bad $ "not a one-branch tree"
|
||||
|
||||
-- added sequential representation
|
||||
|
||||
-- | a successor function
|
||||
goAhead :: Loc a -> Err (Loc a)
|
||||
goAhead s@(Loc (t,p)) = case (t,p) of
|
||||
(Tr (_,_:_),Node (_,_,_:_)) -> goDown s
|
||||
(Tr (_,[]), _) -> upsRight s
|
||||
(_, _) -> goDown s
|
||||
where
|
||||
upsRight t = case goRight t of
|
||||
Ok t' -> return t'
|
||||
Bad _ -> goUp t >>= upsRight
|
||||
|
||||
-- | a predecessor function
|
||||
goBack :: Loc a -> Err (Loc a)
|
||||
goBack s@(Loc (t,p)) = case goLeft s of
|
||||
Ok s' -> downRight s'
|
||||
_ -> goUp s
|
||||
where
|
||||
downRight s = case goDown s of
|
||||
Ok s' -> case goRight s' of
|
||||
Ok s'' -> downRight s''
|
||||
_ -> downRight s'
|
||||
_ -> return s
|
||||
|
||||
-- n-ary versions
|
||||
|
||||
goAheadN :: Int -> Loc a -> Err (Loc a)
|
||||
goAheadN i st
|
||||
| i < 1 = return st
|
||||
| otherwise = goAhead st >>= goAheadN (i-1)
|
||||
|
||||
goBackN :: Int -> Loc a -> Err (Loc a)
|
||||
goBackN i st
|
||||
| i < 1 = return st
|
||||
| otherwise = goBack st >>= goBackN (i-1)
|
||||
|
||||
-- added mappings between locations and trees
|
||||
|
||||
loc2tree :: Loc a -> Tr a
|
||||
loc2tree (Loc (t,p)) = case p of
|
||||
Top -> t
|
||||
Node (left,(p',v),right) ->
|
||||
loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p'))
|
||||
|
||||
loc2treeMarked :: Loc a -> Tr (a, Bool)
|
||||
loc2treeMarked (Loc (Tr (a,ts),p)) =
|
||||
loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
|
||||
where
|
||||
(mark, nomark) = (\a -> (a,True), \a -> (a, False))
|
||||
|
||||
tree2loc :: Tr a -> Loc a
|
||||
tree2loc t = Loc (t,Top)
|
||||
|
||||
goRoot :: Loc a -> Loc a
|
||||
goRoot = tree2loc . loc2tree
|
||||
|
||||
goLast :: Loc a -> Err (Loc a)
|
||||
goLast = rep goAhead where
|
||||
rep f s = err (const (return s)) (rep f) (f s)
|
||||
|
||||
goPosition :: [Int] -> Loc a -> Err (Loc a)
|
||||
goPosition p = go p . goRoot where
|
||||
go [] s = return s
|
||||
go (p:ps) s = goDown s >>= apply p goRight >>= go ps
|
||||
|
||||
getPosition :: Loc a -> [Int]
|
||||
getPosition = reverse . getp where
|
||||
getp (Loc (t,p)) = case p of
|
||||
Top -> []
|
||||
Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p'))
|
||||
|
||||
keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a))
|
||||
keepPosition f s = do
|
||||
let p = getPosition s
|
||||
s' <- f s
|
||||
goPosition p s'
|
||||
|
||||
apply :: Monad m => Int -> (a -> m a) -> a -> m a
|
||||
apply n f a = case n of
|
||||
0 -> return a
|
||||
_ -> f a >>= apply (n-1) f
|
||||
|
||||
-- added some utilities
|
||||
|
||||
traverseCollect :: Path a -> [a]
|
||||
traverseCollect p = reverse $ case p of
|
||||
Top -> []
|
||||
Node (_, (p',v), _) -> v : traverseCollect p'
|
||||
|
||||
scanTree :: Tr a -> [a]
|
||||
scanTree (Tr (a,ts)) = a : concatMap scanTree ts
|
||||
|
||||
mapTr :: (a -> b) -> Tr a -> Tr b
|
||||
mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts)
|
||||
|
||||
mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b)
|
||||
mapTrM f (Tr (x,ts)) = do
|
||||
fx <- f x
|
||||
fts <- mapM (mapTrM f) ts
|
||||
return $ Tr (fx,fts)
|
||||
|
||||
mapPath :: (a -> b) -> Path a -> Path b
|
||||
mapPath f p = case p of
|
||||
Node (ts1, (p,v), ts2) ->
|
||||
Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2)
|
||||
Top -> Top
|
||||
|
||||
mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b)
|
||||
mapPathM f p = case p of
|
||||
Node (ts1, (p,v), ts2) -> do
|
||||
ts1' <- mapM (mapTrM f) ts1
|
||||
p' <- mapPathM f p
|
||||
v' <- f v
|
||||
ts2' <- mapM (mapTrM f) ts2
|
||||
return $ Node (ts1', (p',v'), ts2')
|
||||
Top -> return Top
|
||||
|
||||
mapLoc :: (a -> b) -> Loc a -> Loc b
|
||||
mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p)
|
||||
|
||||
mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b)
|
||||
mapLocM f (Loc (t,p)) = do
|
||||
t' <- mapTrM f t
|
||||
p' <- mapPathM f p
|
||||
return $ (Loc (t',p'))
|
||||
|
||||
foldTr :: (a -> [b] -> b) -> Tr a -> b
|
||||
foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts)
|
||||
|
||||
foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b
|
||||
foldTrM f (Tr (x,ts)) = do
|
||||
fts <- mapM (foldTrM f) ts
|
||||
f x fts
|
||||
|
||||
mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a
|
||||
mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts)
|
||||
|
||||
mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a)
|
||||
mapSubtreesM f t = do
|
||||
Tr (x,ts) <- f t
|
||||
ts' <- mapM (mapSubtreesM f) ts
|
||||
return $ Tr (x, ts')
|
||||
|
||||
-- | change the root without moving the pointer
|
||||
changeRoot :: (a -> a) -> Loc a -> Loc a
|
||||
changeRoot f loc = case loc of
|
||||
Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
|
||||
Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right))
|
||||
where
|
||||
chPath pv = case pv of
|
||||
(Top,a) -> (Top, f a)
|
||||
(Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
|
||||
|
||||
nthSubtree :: Int -> Tr a -> Err (Tr a)
|
||||
nthSubtree n (Tr (a,ts)) = ts !? n
|
||||
|
||||
arityTree :: Tr a -> Int
|
||||
arityTree (Tr (_,ts)) = length ts
|
||||
Reference in New Issue
Block a user