summaryrefslogtreecommitdiff
path: root/TrieMap/RadixTrie.hs
diff options
context:
space:
mode:
Diffstat (limited to 'TrieMap/RadixTrie.hs')
-rw-r--r--TrieMap/RadixTrie.hs495
1 files changed, 234 insertions, 261 deletions
diff --git a/TrieMap/RadixTrie.hs b/TrieMap/RadixTrie.hs
index 1ea5b6b..2ab4432 100644
--- a/TrieMap/RadixTrie.hs
+++ b/TrieMap/RadixTrie.hs
@@ -1,301 +1,274 @@
-{-# LANGUAGE IncoherentInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-}
+{-# LANGUAGE IncoherentInstances, PatternGuards, MultiParamTypeClasses, UndecidableInstances #-}
-module TrieMap.RadixTrie (RadixTrie) where
+module TrieMap.RadixTrie where
+
+import Control.Applicative
-import Control.Applicative hiding (Alternative(..))
-import Control.Monad
-import Data.Foldable
-import Data.Traversable
-import Data.Monoid
import Data.Maybe
-import Data.Ord
+import Data.Monoid
+import Data.Foldable
import Data.Sequence (Seq, (|>))
import qualified Data.Sequence as Seq
+import Data.Traversable
+import TrieMap.Algebraic
+import TrieMap.Applicative
import TrieMap.MapTypes
import TrieMap.TrieAlgebraic
-import TrieMap.Applicative
-
-import Prelude hiding (null, foldr, all)
-
-instance (Eq k, Eq v, TrieKey k m) => Eq (Edge k m v) where
- Edge n1 ks1 v1 ts1 == Edge n2 ks2 v2 ts2 = n1 == n2 && ks1 == ks2 && v1 == v2 && assocsAlg ts1 == assocsAlg ts2
-
-instance (Ord k, Ord v, TrieKey k m) => Ord (Edge k m v) where
- Edge _ ks1 v1 ts1 `compare` Edge _ ks2 v2 ts2 =
- compare ks1 ks2 `mappend` compare v1 v2 `mappend` comparing assocsAlg ts1 ts2
-
-deriving instance (Eq k, Eq v, TrieKey k m) => Eq (RadixTrie k m v)
-deriving instance (Ord k, Ord v, TrieKey k m) => Ord (RadixTrie k m v)
-deriving instance (Show k, Show v, Functor m, Show (m String)) => Show (RadixTrie k m v)
-
-instance (Show k, Show v, Functor m, Show (m String)) => Show (Edge k m v) where
- show (Edge _ k v ts) = "Edge " ++ show k ++ " " ++ show v ++ " " ++ show (fmap show ts)
-
-instance Sized (Edge k m v) where
- getSize (Edge n _ _ _) = n
-instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where
- emptyAlg = Radix Nothing
- nullAlg = isNothing . unRad
- sizeAlg (Radix e) = maybe 0 getSize e
- getSingleAlg (Radix e) = e >>= getSingleEdge
- guardNullAlg (Radix e) = do e <- guardNullEdge =<< e
- return (Radix (Just e))
- lookupAlg ks = unRad >=> lookupEdge (==) ks
--- sizeAlg (Radix e) = maybe 0 sizeEdge e
- alterLookupAlg f k = fmap Radix .
- maybe (fmap (maybeSingleEdge k) $ f Nothing)
- (alterLookupEdge (==) f k) . unRad
- foldWithKeyAlg f z = foldr (flip (foldWithKeyEdge f)) z . unRad
- mapMaybeAlg f (Radix e) = Radix (e >>= mapMaybeEdge f)
- mapEitherAlg f (Radix Nothing) = (emptyAlg, emptyAlg)
- mapEitherAlg f (Radix (Just e)) = (Radix e1, Radix e2)
- where (e1, e2) = mapEitherEdge f e
--- mapMaybeAlg f (Radix e) = (Radix . join) <$> traverse (mapAppMaybeEdge f) e
- mapAppAlg f = fmap Radix . traverse (mapAppEdge f) . unRad
- unionMaybeAlg f (Radix e1) (Radix e2) = Radix (unionMaybe (unionMaybeEdge f) e1 e2)
- intersectAlg f (Radix e1) (Radix e2) = Radix (intersectMaybe (intersectEdge f) e1 e2)
- differenceAlg f (Radix e1) (Radix e2) = Radix (differenceMaybe (differenceEdge f) e1 e2)
-
- getMinAlg (Radix e) = fmap (fmap Radix . getMinEdge) e
- getMaxAlg (Radix e) = fmap (fmap Radix . getMaxEdge) e
--- updateMinAlg f (Radix e) = Radix $ e >>= updateMinEdge f
--- updateMaxAlg f (Radix e) = Radix $ e >>= updateMaxEdge f
-
- fromListAlg f xs = Radix (edgeFromList f xs)
- fromAscListAlg f xs = Radix (edgeFromAscList f xs)
- fromDistAscListAlg = fromAscListAlg (\ _ v _ -> v)
-
- isSubmapAlg (<=) (Radix e1) (Radix e2) = isSubmapAlg subEdge e1 e2 -- hehe, using the Maybe instance here!
- where subEdge = isSubmapEdge (==) (<=) lookupAlg $! isSubmapAlg subEdge
-
- valid (Radix e) = maybe True validEdge e
-
- splitLookupAlg _ _ (Radix Nothing) = (Radix Nothing, Nothing, Radix Nothing)
- splitLookupAlg f k (Radix (Just e)) = case splitEdge f k e of
+import Prelude hiding (foldr)
+
+instance Sized (Edge k m a) where
+ getSize (Edge s _ _ _) = s
+
+instance TrieKeyT [] RadixTrie where
+ compareKeyT (a:as) (b:bs) = compareKey a b `mappend` compareKeyT as bs
+ compareKeyT [] (_:_) = LT
+ compareKeyT (_:_) [] = GT
+ compareKeyT [] [] = EQ
+ emptyT = Radix Nothing
+ nullT (Radix m) = isNothing m
+ sizeT (Radix m) = getSize m
+ getSingleT (Radix m) = m >>= getSingleEdge
+ guardNullT (Radix m) = m >>= guardNullEdge >>= return . Radix . Just
+ alterLookupT f ks (Radix Nothing) = (Radix . single ks) <$> f Nothing
+ alterLookupT f ks (Radix (Just e)) = Radix <$> alterLookupEdge f ks e
+ lookupT ks (Radix m) = m >>= lookupEdge ks
+ foldWithKeyT f z (Radix m) = foldr (foldEdge f) z m
+ mapAppT f (Radix m) = Radix <$> traverse (mapAppEdge f) m
+ mapMaybeT f (Radix m) = Radix (m >>= mapMaybeEdge f)
+ mapEitherT f (Radix m) = radBoth (maybe (Nothing, Nothing) (mapEitherEdge f) m)
+ where radBoth (e1, e2) = (Radix e1, Radix e2)
+ fromDistAscListT = fromAscListT (\ _ x _ -> x)
+ fromAscListT _ [] = Radix Nothing
+ fromAscListT f (x:xs) = Radix (Just (groupAscHeads' f x xs))
+ fromListT f xs = Radix (groupHeads f xs)
+ splitLookupT _ _ (Radix Nothing) = (emptyT, Nothing, emptyT)
+ splitLookupT f k (Radix (Just e)) = case splitLookupEdge f k e of
(eL, ans, eR) -> (Radix eL, ans, Radix eR)
-
--- sizeEdge :: Edge k m v -> Int
--- sizeEdge (Edge n _ _ _) = n
-
-{-# INLINE edge #-}
-edge :: (Sized v, TrieKey k m) => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v
+ isSubmapT (<=) (Radix m1) (Radix m2) = isSubmapAlg (isSubEdge (<=)) m1 m2
+ getMinT (Radix m) = fmap (Radix <$>) (m >>= getMinEdge)
+ getMaxT (Radix m) = fmap (Radix <$>) (m >>= getMaxEdge)
+ updateMinT _ (Radix Nothing) = (False, Radix Nothing)
+ updateMinT f (Radix (Just e)) = Radix <$> updateMinEdge f e
+ updateMaxT _ (Radix Nothing) = (False, Radix Nothing)
+ updateMaxT f (Radix (Just e)) = Radix <$> updateMaxEdge f e
+ unionT f (Radix m1) (Radix m2) = Radix (unionMaybe (unionEdge f) m1 m2)
+ intersectT f (Radix m1) (Radix m2) = Radix (intersectMaybe (intersectEdge f) m1 m2)
+ differenceT f (Radix m1) (Radix m2) = Radix (differenceMaybe (differenceEdge f) m1 m2)
+
+instance TrieKey k m => TrieKey [k] (RadixTrie k m) where
+ compareKey = compareKeyT
+ emptyAlg = emptyT
+ nullAlg = nullT
+ getSingleAlg = getSingleT
+ guardNullAlg = guardNullT
+ sizeAlg = sizeT
+ lookupAlg = lookupT
+ alterLookupAlg = alterLookupT
+ mapAppAlg = mapAppT
+ mapMaybeAlg = mapMaybeT
+ mapEitherAlg = mapEitherT
+ foldWithKeyAlg = foldWithKeyT
+ unionMaybeAlg = unionT
+ intersectAlg = intersectT
+ differenceAlg = differenceT
+ getMinAlg = getMinT
+ getMaxAlg = getMaxT
+ updateMinAlg = updateMinT
+ updateMaxAlg = updateMaxT
+ isSubmapAlg = isSubmapT
+ splitLookupAlg = splitLookupT
+
+single :: (Sized a, TrieKey k m) => [k] -> Maybe a -> MEdge k m a
+single ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)
+
+edge :: (Sized a, TrieKey k m) => [k] -> Maybe a -> m (Edge k m a) -> Edge k m a
edge ks v ts = Edge (getSize v + getSize ts) ks v ts
-lookupEdge :: TrieKey k m => (k -> k -> Bool) -> [k] -> Edge k m v -> Maybe v
-lookupEdge (==) ks (Edge _ ls v ts) = procEdge ks ls where
- procEdge (k:ks) (l:ls)
- | k == l = procEdge ks ls
- procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge (==) ks
- procEdge [] [] = v
- procEdge _ _ = Nothing
-
-edgeFromList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
-edgeFromList f xs = guardNullEdge $ edge [] v0 $ mapMaybeAlg (\ k (Elem xs)-> edgeFromList (f . (k:)) xs) $
- fromListAlg (\ _ (Elem xs) (Elem ys) -> Elem (ys ++ xs)) ys
- where part ([], v) (v0, ys) = (Just $ maybe v (flip (f []) v) v0, ys)
- part (k:ks, v) (v0, ys) = (v0, (k, Elem [(ks, v)]):ys)
- (v0, ys) = foldr part (Nothing, []) xs
-
-edgeFromAscList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
-edgeFromAscList _ [] = Nothing
-edgeFromAscList f (x:xs) = Just $ edgeFromAscList' f x xs
-
-edgeFromAscList' :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> ([k], v) -> [([k], v)] -> Edge k m v
-edgeFromAscList' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg
-edgeFromAscList' f x xs = case groupHead f (x:xs) of
- (Nothing, [(k, ~(Edge n ks v ts))])
- -> Edge n (k:ks) v ts
- (ans, xs') -> edge [] ans (fromDistAscListAlg xs')
-
-groupHead :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> (Maybe v, [(k, Edge k m v)])
-groupHead f (([], v):xs) = case groupHead f xs of
- (v', ans) -> (Just $ maybe v (f [] v) v', ans)
-groupHead f ((k:ks, v):xs) = (Nothing, groupHead' k (ks, v) Seq.empty xs) where
- groupHead' k0 x xs ((k:ks, v):ys)
- | k == k0 = groupHead' k0 x (xs |> (ks, v)) ys
- | otherwise = (k0, edgeFromAscList' (f . (k0:)) x (toList xs)):groupHead' k (ks, v) Seq.empty ys
- groupHead' k0 x xs [] = [(k0, edgeFromAscList' (f . (k0:)) x (toList xs))]
- groupHead' _ _ _ _ = error "Violation of ascending invariant!"
-groupHead _ [] = (Nothing, [])
- {-guardNullEdge $ Edge [] v0 $ mapMaybeAlg (\ k -> edgeFromAscList (f . (k:))) $ fromAscListAlg (const (flip (++))) ys
- where part ([], v) (v0, ys) = (Just $ maybe v (flip (f []) v) v0, ys)
- part (k:ks, v) (v0, ys) = (v0, (k, [(ks, v)]):ys)
- (v0, ys) = foldr part (Nothing, []) xs-}
-
-maybeSingleEdge :: Sized v => TrieKey k m => [k] -> Maybe v -> MEdge k m v
-maybeSingleEdge ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)
-
-getSingleEdge :: (TrieKey k m) => Edge k m v -> Maybe ([k], v)
+getSingleEdge :: TrieKey k m => Edge k m a -> Maybe ([k], a)
getSingleEdge (Edge _ ks (Just v) ts)
| nullAlg ts = Just (ks, v)
getSingleEdge (Edge _ ks Nothing ts) = do
- (x, e') <- getSingleAlg ts
- (xs, v) <- getSingleEdge e'
- return (ks ++ x:xs, v)
+ (l, e') <- getSingleAlg ts
+ (ls, v) <- getSingleEdge e'
+ return (ks ++ l:ls, v)
getSingleEdge _ = Nothing
-{-# INLINE guardNullEdge #-}
-guardNullEdge :: TrieKey k m => Edge k m v -> MEdge k m v
-guardNullEdge (Edge n ks Nothing ts)
+guardNullEdge :: TrieKey k m => Edge k m a -> MEdge k m a
+guardNullEdge (Edge s ks Nothing ts)
| nullAlg ts = Nothing
- | Just (x, Edge n' xs v ts') <- getSingleAlg ts
- = Just (Edge n' (ks ++ x:xs) v ts')
+ | Just (l, Edge _ ls v ts') <- getSingleAlg ts
+ = Just (Edge s (ks ++ l:ls) v ts')
guardNullEdge e = Just e
-alterLookupEdge :: (TrieKey k m, Sized v) => (k -> k -> Bool) ->
- (Maybe v -> (a, Maybe v)) -> [k] -> Edge k m v -> (a, MEdge k m v)
-alterLookupEdge (==) f ks0 e@(Edge n0 ls0 v ts) = procEdge 0 ks0 ls0 where
+alterLookupEdge :: (Eq k, TrieKey k m, Sized a) => (Maybe a -> (b, Maybe a)) -> [k] -> Edge k m a -> (b, MEdge k m a)
+alterLookupEdge f ks0 e@(Edge s ls0 v0 ts) = procEdge 0 ks0 ls0 where
procEdge i _ _ | i `seq` False = undefined
procEdge i (k:ks) (l:ls)
| k == l = procEdge (i+1) ks ls
- | otherwise = fmap (Just . g) (f Nothing)
- where g Nothing = e
- g (Just v') = let nV = getSize v' in Edge (n0 + nV) (take i ks0) Nothing $
- fromListAlg' [(k, Edge nV ks (Just v') emptyAlg), (l, Edge n0 ls v ts)]
- procEdge i (k:ks) [] = proc (alterLookupAlg g k ts) where
- g Nothing = maybeSingleEdge ks <$> f Nothing
- g (Just e') = alterLookupEdge (==) f ks e'
- proc = fmap (guardNullEdge . edge ls0 v)
- procEdge i [] (l:ls) = fmap (Just . g) $ f Nothing
- where g Nothing = e
- g (Just v') = Edge (getSize v' + n0) ks0 (Just v') $ insertAlg l (Edge n0 ls v ts) emptyAlg
- procEdge i [] [] = (ans, guardNullEdge (Edge (getSize fv - getSize v + n0) ks0 fv ts))
- where (ans, fv) = f v
-
-foldWithKeyEdge :: TrieKey k m => ([k] -> v -> x -> x) -> x -> Edge k m v -> x
-foldWithKeyEdge f z (Edge _ ks v ts) =
- foldr (f ks) (foldWithKeyAlg (\ x -> flip (foldWithKeyEdge (\ xs -> f (ks ++ x:xs)))) z ts) v
-
-mapMaybeEdge :: (TrieKey k m, Sized w) => ([k] -> v -> Maybe w) -> Edge k m v -> MEdge k m w
-mapMaybeEdge f (Edge _ ks v ts) = guardNullEdge $
- edge ks (join $ traverse (f ks) v) (mapMaybeAlg (\ x -> mapMaybeEdge (\ xs -> f (ks ++ x:xs))) ts)
-
-mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> Either b c) -> Edge k m a -> (MEdge k m b, MEdge k m c)
-mapEitherEdge f (Edge _ ks v ts) =
- (guardNullEdge $ edge ks vL tsL, guardNullEdge $ edge ks vR tsR)
- where (vL, vR) = case fmap (f ks) v of
- Nothing -> (Nothing, Nothing)
- Just (Left v) -> (Just v, Nothing)
- Just (Right v) -> (Nothing, Just v)
- ts' = mapWithKeyAlg (\ x -> Elem . mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts
- tsL = mapMaybeAlg (\ _ (Elem (tsL, _)) -> tsL) ts'
- tsR = mapMaybeAlg (\ _ (Elem (_, tsR)) -> tsR) ts'
+ | otherwise = breakEdge <$> f Nothing where
+ breakEdge Nothing = Just e
+ breakEdge (Just v) = let sV = getSize v in
+ Just (Edge (sV + s) (take i ls0) Nothing
+ (fromListAlg (\ _ v _ -> v) [(k, Edge sV ks (Just v) emptyAlg), (l, Edge s ls v0 ts)]))
+ procEdge _ [] (l:ls) = splitEdge <$> f Nothing where
+ splitEdge Nothing = Just e
+ splitEdge (Just v) = let sV = getSize v in
+ Just (Edge (sV + s) ks0 (Just v) (singletonAlg l (Edge s ls v0 ts)))
+ procEdge _(k:ks) [] = (guardNullEdge . edge ls0 v0) <$> alterLookupAlg g k ts where
+ g Nothing = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg) <$> f Nothing
+ g (Just e) = alterLookupEdge f ks e
+ procEdge _ [] [] = fmap (\ v -> guardNullEdge $ edge ls0 v ts) (f v0)
+
+lookupEdge :: (Eq k, TrieKey k m) => [k] -> Edge k m a -> Maybe a
+lookupEdge ks (Edge _ ls v ts) = procEdge ks ls where
+ procEdge (k:ks) (l:ls)
+ | k == l = procEdge ks ls
+ procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge ks
+ procEdge [] [] = v
+ procEdge _ _ = Nothing
-mapAppEdge :: (Applicative f, TrieKey k m, Sized w) => ([k] -> v -> f w) -> Edge k m v -> f (Edge k m w)
-mapAppEdge f (Edge _ ks v ts) = liftA2 (edge ks) (traverse (f ks) v) (mapAppAlg (\ x -> mapAppEdge (\ xs -> f (ks ++ x:xs))) ts)
+foldEdge :: TrieKey k m => ([k] -> a -> b -> b) -> Edge k m a -> b -> b
+foldEdge f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyAlg (\ l -> foldEdge (\ ls -> f (ks ++ l:ls))) z ts) v
+
+mapAppEdge :: (TrieKey k m, Applicative f, Sized b) => ([k] -> a -> f b) -> Edge k m a -> f (Edge k m b)
+mapAppEdge f (Edge _ ks v ts) = edge ks <$> traverse (f ks) v <*> mapAppAlg (\ l -> mapAppEdge (\ ls -> f (ks ++ l:ls))) ts
+
+mapMaybeEdge :: (TrieKey k m, Sized b) => ([k] -> a -> Maybe b) -> Edge k m a -> MEdge k m b
+mapMaybeEdge f (Edge _ ks v ts) =
+ guardNullEdge (edge ks (v >>= f ks) (mapMaybeAlg (\ l -> mapMaybeEdge (\ ls -> f (ks ++ l:ls))) ts))
+
+mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> (Maybe b, Maybe c)) -> Edge k m a ->
+ (MEdge k m b, MEdge k m c)
+mapEitherEdge f (Edge _ ks v ts) = guardBoth (edge ks vL tsL, edge ks vR tsR)
+ where (vL, vR) = maybe (Nothing, Nothing) (f ks) v
+ ts' = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts
+ (tsL, tsR) = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts
+ guardBoth (e1, e2) = (guardNullEdge e1, guardNullEdge e2)
+
+groupAscHeads' :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> ([k], a) -> [([k], a)] -> Edge k m a
+groupAscHeads' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg
+groupAscHeads' f x xs = group0 Nothing (x:xs) where
+ group0 v0 (([], v):xs) = group0 (Just (maybe v (f [] v) v0)) xs
+ group0 (Just v0) [] = Edge (getSize v0) [] (Just v0) emptyAlg
+ group0 v0 ((k:ks, v):xs) = group1 Seq.empty k (ks, v) Seq.empty xs where
+ group1 ts k vk vs ((l:ls, v):xs)
+ | k == l = group1 ts k vk (vs |> (ls, v)) xs
+ | otherwise = group1 (ts |> (k, groupAscHeads' (f . (k:)) vk (toList vs))) l (ls, v) Seq.empty xs
+ group1 ts k v vs []
+ | Nothing <- v0, Seq.null ts, Edge s xs vX tsX <- groupAscHeads' (f . (k:)) v (toList vs)
+ = Edge s (k:xs) vX tsX
+ | otherwise
+ = edge [] v0 (fromDistAscListAlg (toList ts ++ [(k, groupAscHeads' (f . (k:)) v (toList vs))]))
+
+groupHeads :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> [([k], a)] -> MEdge k m a
+groupHeads _ [] = Nothing
+groupHeads f xs = guardNullEdge $ edge [] v0 (mapMaybeAlg (\ k (Elem xs) -> groupHeads (f . (k:)) xs) $
+ fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k, Elem [(ks, v)]) | (k, ks, v) <- ts])
+ where (v0, ts) = let proc ([], v) (v0, ts) = (Just (maybe v (f [] v) v0), ts)
+ proc (k:ks, v) (v0, ts) = (v0, (k, ks, v):ts)
+ in foldr proc (Nothing, []) xs
+
+mapEdge :: (Sized b, TrieKey k m) => ([k] -> a -> b) -> Edge k m a -> Edge k m b
+mapEdge f (Edge _ ks v ts) = edge ks (fmap (f ks) v) (mapWithKeyAlg (\ l -> mapEdge (\ ls -> f (ks ++ l:ls))) ts)
+
+splitLookupEdge :: (Sized a, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a ->
+ (MEdge k m a, Maybe b, MEdge k m a)
+splitLookupEdge f ks e@(Edge s ls v ts) = procEdge ks ls where
+ procEdge (k:ks) (l:ls) = case compareKey k l of
+ LT -> (Nothing, Nothing, Just e)
+ GT -> (Just e, Nothing, Nothing)
+ EQ -> procEdge ks ls
+ procEdge (k:ks) [] = case splitLookupAlg g k ts of
+ (tsL, ans, tsR) -> (guardNullEdge (edge ls v tsL), ans, guardNullEdge (edge ls Nothing tsR))
+ where g = splitLookupEdge f ks
+ procEdge [] (l:ls) = (Nothing, Nothing, Just e)
+ procEdge [] [] = case v of
+ Nothing -> (Nothing, Nothing, Just e)
+ Just v -> case f v of
+ (vL, ans, vR) -> (single ls vL, ans, guardNullEdge (edge ls vR ts))
+
+isSubEdge :: (TrieKey k m, Sized a, Sized b) => (a -> b -> Bool) -> Edge k m a -> Edge k m b -> Bool
+isSubEdge (<=) (Edge sK ks vK tsK) (Edge _ ls vL tsL) = procEdge ks ls where
+ procEdge (k:ks) (l:ls)
+ | k == l = procEdge ks ls
+ procEdge (k:ks) []
+ | Just e' <- lookupAlg k tsL
+ = isSubEdge (<=) (Edge sK ks vK tsK) e'
+ procEdge [] [] = isSubmapAlg (<=) vK vL && isSubmapAlg (isSubEdge (<=)) tsK tsL
+
+getMinEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)
+getMinEdge (Edge s ks (Just v) ts) = Just ((ks, v), guardNullEdge (Edge (s - getSize v) ks Nothing ts))
+getMinEdge (Edge _ ks Nothing ts) = do
+ ((l, e'), ts') <- getMinAlg ts
+ ((ls, v), e'') <- getMinEdge e'
+ return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts')
+ (\ e'' -> Just $ snd $ updateMinAlg (\ _ _ -> (False, Just e'')) ts) e''))
+
+getMaxEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)
+getMaxEdge (Edge _ ks v0 ts)
+ | nullAlg ts = maybe Nothing (\ v -> Just ((ks, v), Nothing)) v0
+ | otherwise = do
+ ((l, e'), ts') <- getMaxAlg ts
+ ((ls, v), e'') <- getMaxEdge e'
+ return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts')
+ (\ e'' -> Just $ snd $ updateMaxAlg (\ _ _ -> (False, Just e'')) ts) e''))
+
+updateMinEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)
+updateMinEdge f (Edge _ ks (Just v) ts)
+ = fmap (\ v -> guardNullEdge (edge ks v ts)) (f ks v)
+updateMinEdge f (Edge _ ks Nothing ts) = fmap (guardNullEdge . edge ks Nothing) (updateMinAlg g ts) where
+ g l = updateMinEdge (\ ls -> f (ks ++ l:ls))
+
+updateMaxEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)
+updateMaxEdge f (Edge _ ks (Just v) ts)
+ | nullAlg ts = fmap (\ v -> guardNullEdge (edge ks v ts)) (f ks v)
+updateMaxEdge f (Edge _ ks v ts) = fmap (guardNullEdge . edge ks v) (updateMinAlg g ts) where
+ g l = updateMinEdge (\ ls -> f (ks ++ l:ls))
-unionMaybeEdge :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> Maybe v) -> Edge k m v -> Edge k m v -> MEdge k m v
-unionMaybeEdge f (Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge 0 ks0 ls0 where
+unionEdge :: (TrieKey k m, Sized a) => ([k] -> a -> a -> Maybe a) -> Edge k m a -> Edge k m a -> MEdge k m a
+unionEdge f (Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge 0 ks0 ls0 where
procEdge i _ _ | i `seq` False = undefined
procEdge i (k:ks) (l:ls)
| k == l = procEdge (i+1) ks ls
- | otherwise = Just $ Edge (nK + nL) (take i ks0) Nothing $ fromListAlg' [(k, Edge nK ks vK tsK), (l, Edge nL ls vL tsL)]
- procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK
- where g Nothing = Just (Edge nL ls vL tsL)
- g (Just e') = unionMaybeEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)
- procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL
- where g Nothing = Just $ Edge nK ks vK tsK
- g (Just e') = unionMaybeEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
- procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe (f ks0) vK vL) $
- unionMaybeAlg (\ x -> unionMaybeEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
-
-intersectEdge :: (Eq k, TrieKey k m, Sized c) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c
-intersectEdge f (Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge ks0 ls0 where
+ | otherwise = Just (Edge (sK + sL) (take i ks0) Nothing
+ (insertAlg k (Edge sK ks vK tsK) $ singletonAlg l (Edge sL ls vL tsL)))
+ procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL where
+ g Nothing = Just (Edge sK ks vK tsK)
+ g (Just e) = unionEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e
+ procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK where
+ g Nothing = Just (Edge sL ls vL tsL)
+ g (Just e) = unionEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)
+ procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe (f ks0) vK vL) $
+ unionMaybeAlg (\ x -> unionEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+
+intersectEdge :: (TrieKey k m, Sized c) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c
+intersectEdge f (Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge ks0 ls0 where
procEdge (k:ks) (l:ls)
| k == l = procEdge ks ls
| otherwise = Nothing
procEdge (k:ks) [] = do
e' <- lookupAlg k tsL
- Edge nX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
- return (Edge nX (ls0 ++ k:xs) vX tsX)
+ Edge sX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e'
+ return (Edge sX (ls0 ++ k:xs) vX tsX)
procEdge [] (l:ls) = do
e' <- lookupAlg l tsK
- Edge nX xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)
- return (Edge nX (ks0 ++ l:xs) vX tsX)
- procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) $
- intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+ Edge sX xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge sL ls vL tsL)
+ return (Edge sX (ks0 ++ l:xs) vX tsX)
+ procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL)
+ (intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL)
-{-# SPECIALIZE differenceEdge :: (Eq k, TrieKey k m) => ([k] -> Elem v -> w -> Maybe (Elem v)) ->
- Edge k m (Elem v) -> Edge k m w -> MEdge k m (Elem v) #-}
-differenceEdge :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> w -> Maybe v) -> Edge k m v -> Edge k m w -> MEdge k m v
-differenceEdge f e@(Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge ks0 ls0 where
+differenceEdge :: (TrieKey k m, Sized a) => ([k] -> a -> b -> Maybe a) -> Edge k m a -> Edge k m b -> MEdge k m a
+differenceEdge f e@(Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge ks0 ls0 where
procEdge (k:ks) (l:ls)
| k == l = procEdge ks ls
procEdge (k:ks) []
| Just e' <- lookupAlg k tsL
- = do Edge nX xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
- return (Edge nX (ls0 ++ k:xs) vX tsX)
- procEdge [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK
- where g Nothing = Nothing
- g (Just e') = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)
- procEdge [] [] = guardNullEdge $ edge ks0 (differenceMaybe (f ks0) vK vL) $
- differenceAlg (\ x -> differenceEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
- procEdge _ _ = Just e
-
-{-# SPECIALIZE getMinEdge :: TrieKey k m => Edge k m (Elem v) -> (([k], Elem v), MEdge k m (Elem v)) #-}
-getMinEdge :: (Sized v, TrieKey k m) => Edge k m v -> (([k], v), MEdge k m v)
-getMinEdge (Edge nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts)
-getMinEdge (Edge nK ks _ ts)
- | Just ((l, e), ts') <- getMinAlg ts, ((ls, v), e') <- getMinEdge e
- = ((ks ++ l:ls, v), guardNullEdge $ edge ks Nothing $ maybe ts' (\ e' -> snd $ updateMinAlg (\ _ _ -> (False, Just e')) ts) e')
-getMinEdge _ = error "Uncompacted edge"
-
-getMaxEdge :: (Sized v, TrieKey k m) => Edge k m v -> (([k], v), MEdge k m v)
-getMaxEdge (Edge nK ks v0 ts)
- | Just ((l, e), ts') <- getMaxAlg ts, ((ls, v), e') <- getMaxEdge e
- = ((ks ++ l:ls, v), guardNullEdge $ edge ks v0 $ maybe ts' (\ e' -> snd $ updateMaxAlg (\ _ _ -> (False, Just e')) ts) e')
-getMaxEdge (Edge nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts)
-getMaxEdge _ = error "Uncompacted edge"
-
-updateMinEdge :: (TrieKey k m, Sized v) => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)
-updateMinEdge f (Edge _ ks (Just v) ts) = fmap (\ v' -> guardNullEdge $ edge ks v' ts) (f ks v)
-updateMinEdge f (Edge _ ks Nothing ts)
- = fmap (guardNullEdge . edge ks Nothing) $ updateMinAlg (\ l -> updateMinEdge (\ ls -> f (ks ++ l:ls))) ts
-
-updateMaxEdge :: (TrieKey k m, Sized v) => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)
-updateMaxEdge f (Edge _ ks (Just v) ts)
- | nullAlg ts = fmap (\ v' -> guardNullEdge $ edge ks v' ts) (f ks v)
-updateMaxEdge f (Edge _ ks v ts) =
- fmap (guardNullEdge . edge ks v) $ updateMaxAlg (\ l -> updateMaxEdge (\ ls -> f (ks ++ l:ls))) ts
-
-isSubmapEdge :: TrieKey k m => (k -> k -> Bool) -> (a -> b -> Bool) -> (k -> m (Edge k m b) -> MEdge k m b) -> (m (Edge k m a) -> m (Edge k m b) -> Bool) ->
- Edge k m a -> Edge k m b -> Bool
-isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) (Edge nL ls vL tsL) = procEdge ks ls where
- procEdge (k:ks) (l:ls)
- | k == l = procEdge ks ls
- procEdge (k:ks) []
- | Just e <- lookup k tsL
- = isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) e
- procEdge [] []
- | Nothing <- vK = tsK <<= tsL
- | Just x <- vK, Just y <- vL, x <= y
- = tsK <<= tsL
- procEdge _ _ = False
-validEdge :: TrieKey k m => Edge k m v -> Bool
-validEdge (Edge _ _ Nothing m)
- | nullAlg m = False
- | Just{} <- getSingleAlg m
- = False
-validEdge (Edge _ _ _ m)
- = valid m && all validEdge m
-
-
-splitEdge :: (Ord k, TrieKey k m, Sized a) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a -> (MEdge k m a, Maybe b, MEdge k m a)
-splitEdge f ks0 e@(Edge nL ls0 v ts) = procEdge ks0 ls0 where
- answerLess = (Nothing, Nothing, Just e) -- if ks0 < ls0
- answerMore = (Just e, Nothing, Nothing) -- if ks0 > ls0
- procEdge (k:ks) (l:ls) = case compare k l of
- LT -> answerLess
- EQ -> procEdge ks ls
- GT -> answerMore
- procEdge (k:ks) [] = case splitLookupAlg (splitEdge f ks) k ts of
- (tsL, ans, tsR) -> (guardNullEdge $ edge ls0 Nothing tsL, ans, guardNullEdge $ edge ls0 v tsR)
- procEdge [] (l:ls) = answerLess
- procEdge [] []
- | Just v <- v, (vL, ans, vR) <- f v
- = (fmap (\ v' -> edge ls0 (Just v') emptyAlg) vL, ans,
- guardNullEdge $ edge ls0 vR ts)
- | otherwise = answerLess -- all children of e match ks0 initially but are longer, and v is Nothing
- \ No newline at end of file
+ = do Edge sX xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e'
+ return (Edge sX (ls0 ++ k:xs) vX tsX)
+ procEdge [] (l:ls) = guardNullEdge $ edge ks0 vK (alterAlg (>>= g) l tsK) where
+ g e = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)
+ procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) $
+ intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+ procEdge _ _ = Just e \ No newline at end of file