summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLouisWasserman <>2009-08-27 16:28:49 (GMT)
committerLuite Stegeman <luite@luite.com>2009-08-27 16:28:49 (GMT)
commit07d2b1d779a0c9bca6b17f14172ade18c3c6bded (patch)
tree6adf3d0faf1f7b323cd43d93c85ba6512b54d911
parentfe8f437277e2fa7280eeefb9b3bebbad6b53381c (diff)
version 0.0.1.10.0.1.1
-rw-r--r--Setup.hs2
-rw-r--r--Setup.lhs3
-rw-r--r--TrieMap.cabal4
-rw-r--r--TrieMap.hs86
-rw-r--r--TrieMap/MapTypes.hs36
-rw-r--r--TrieMap/RadixTrie.hs235
-rw-r--r--TrieMap/Reflection.hs8
-rw-r--r--TrieMap/TrieAlgebraic.hs109
8 files changed, 279 insertions, 204 deletions
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
index 9a994af..0000000
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..5bde0de
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/TrieMap.cabal b/TrieMap.cabal
index d5acf05..5312deb 100644
--- a/TrieMap.cabal
+++ b/TrieMap.cabal
@@ -1,5 +1,5 @@
name: TrieMap
-version: 0.0.1.0
+version: 0.0.1.1
license: BSD3
license-file: LICENSE
maintainer: wasserman.louis@gmail.com
@@ -21,7 +21,7 @@ description: Generalized trie implementation that automatically infers map types
build-type: Simple
build-depends:
- base >= 4 && <= 5, containers
+ base >= 4 && <= 5, containers == 0.2.0.1
exposed-modules:
TrieMap
TrieMap.Algebraic
diff --git a/TrieMap.hs b/TrieMap.hs
index dfd084d..474555e 100644
--- a/TrieMap.hs
+++ b/TrieMap.hs
@@ -157,6 +157,7 @@ module TrieMap (
import Control.Monad
import Data.Monoid
import Data.Traversable
+import TrieMap.MapTypes
import TrieMap.Applicative
import TrieMap.Algebraic
import TrieMap.TrieAlgebraic
@@ -175,7 +176,7 @@ import Prelude hiding (lookup, foldr, null, filter, foldl, map)
import qualified Prelude as Prelude
-- | A 'TrieMap' is a size-tracking wrapper around a generalized trie map.
-data TrieMap k m a = TrieMap {sizeMap :: Int, trieMap :: m a}
+data TrieMap k m a = TrieMap {sizeMap :: Int, trieMap :: m (Elem a)}
instance (Eq k, Eq a, Algebraic k, TrieKey (Alg k) m) => Eq (TrieMap k m a) where
(==) = (==) `on` assocs
@@ -187,26 +188,26 @@ instance (Show k, Show a, Algebraic k, TrieKey (Alg k) m) => Show (TrieMap k m a
show m = "fromList " ++ show (assocs m)
instance (Algebraic k, Algebraic a, TrieKey (Alg k) m) => Algebraic (TrieMap k m a) where
- type Alg (TrieMap k m a) = (Int, [(Alg k, Alg a)])
- toAlg (TrieMap n m) = (n, build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m))
- fromAlg (n, xs) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs]
+ type Alg (TrieMap k m a) = ([(Alg k, Alg a)], Int)
+ toAlg (TrieMap n m) = (build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m), n)
+ fromAlg (xs, n) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs]
instance Functor m => Functor (TrieMap k m) where
- fmap f (TrieMap n m) = TrieMap n (fmap f m)
+ fmap f (TrieMap n m) = TrieMap n (fmap (fmap f) m)
instance Foldable m => Foldable (TrieMap k m) where
- foldr f z = foldr f z . trieMap
- foldl f z = foldl f z . trieMap
- foldMap f = foldMap f . trieMap
+ foldr f z = foldr (\ (Elem x) z -> f x z) z . trieMap
+ foldl f z = foldl (\ z (Elem x) -> f z x) z . trieMap
+ foldMap f = foldMap (f . getElem) . trieMap
instance Traversable m => Traversable (TrieMap k m) where
- traverse f (TrieMap n m) = TrieMap n <$> traverse f m
+ traverse f (TrieMap n m) = TrieMap n <$> traverse (traverse f) m
instance (Algebraic k, TrieKey (Alg k) m) => Monoid (TrieMap k m a) where
mempty = empty
mappend = union
-mkTrieMap :: (Algebraic k, TrieKey (Alg k) m) => m a -> TrieMap k m a
+mkTrieMap :: (Algebraic k, TrieKey (Alg k) m) => m (Elem a) -> TrieMap k m a
mkTrieMap m = TrieMap (sizeAlg m) m
-- | Lookup the value of a key in the map.
@@ -214,7 +215,7 @@ mkTrieMap m = TrieMap (sizeAlg m) m
-- The function will return the corresponding value as @('Just' value)@,
-- or 'Nothing' if the key isn't in the map.
lookup :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Maybe a
-lookup k = lookupAlg (toAlg k) . trieMap
+lookup k = fmap getElem . lookupAlg (toAlg k) . trieMap
-- | Is the key a member of the map? See also 'notMember'.
--
@@ -249,7 +250,7 @@ findWithDefault v = fromMaybe v .: lookup
--
-- > singleton 1 'a' == fromList [(1, 'a')]
singleton :: (Algebraic k, TrieKey (Alg k) m) => k -> a -> TrieMap k m a
-singleton k v = TrieMap 1 (insertAlg (toAlg k) v emptyAlg)
+singleton k v = TrieMap 1 (insertAlg (toAlg k) (Elem v) emptyAlg)
-- | Find the value at a key.
-- Calls 'error' when the element can not be found.
@@ -293,7 +294,7 @@ fromListWith = fromListWithKey . const
-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
-- > fromListWithKey f [] == empty
fromListWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
-fromListWithKey f xs = mkTrieMap $ fromListAlg (f . fromAlg) [(toAlg k, v) | (k, v) <- xs]
+fromListWithKey f xs = mkTrieMap $ fromListAlg (\ k (Elem v1) (Elem v2) -> Elem (f (fromAlg k) v1 v2)) [(toAlg k, Elem v) | (k, v) <- xs]
-- | /O(n)/. Build a map from an ascending list in linear time.
-- /The precondition (input list is ascending) is not checked./
@@ -317,14 +318,15 @@ fromAscListWith = fromAscListWithKey . const
-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
fromAscListWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
-fromAscListWithKey f xs = mkTrieMap $ fromAscListAlg (f . fromAlg) [(toAlg k, v) | (k, v) <- xs]
+fromAscListWithKey f xs = mkTrieMap $ fromAscListAlg g [(toAlg k, Elem v) | (k, v) <- xs] where
+ g k (Elem v1) (Elem v2) = Elem (f (fromAlg k) v1 v2)
-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
-- /The precondition is not checked./
--
-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
fromDistinctAscList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a
-fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, v) | (k, v) <- xs]
+fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, Elem v) | (k, v) <- xs]
-- | Insert a new key and value in the map.
-- If the key is already present in the map, the associated value is
@@ -368,8 +370,9 @@ insertWithKey f k = snd .: insertLookupWithKey f k
-- is a pair where the first element is equal to (@'lookup' k map@)
-- and the second element equal to (@'insertWithKey' f k x map@).
insertLookupWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> (Maybe a, TrieMap k m a)
-insertLookupWithKey f k v (TrieMap n m) = case alterLookupAlg (\ v' -> (v', Just $ maybe v (f k v) v')) (toAlg k) m of
+insertLookupWithKey f k v (TrieMap n m) = case alterLookupAlg g (toAlg k) m of
(old, m') -> (old, TrieMap (if isJust old then n else n + 1) m')
+ where g v' = (fmap getElem v', Just $ Elem $ maybe v (f k v . getElem) v')
-- | The expression (@'update' f k map@) updates the value @x@
-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
@@ -404,8 +407,9 @@ updateWithKey f = snd .: updateLookupWithKey f
-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
updateLookupWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
updateLookupWithKey f k (TrieMap n m) =
- case alterLookupAlg (\ v -> let v' = v >>= f k in ((isNothing v' && isJust v, maybe v Just v'), v')) (toAlg k) m of
+ case alterLookupAlg g (toAlg k) m of
((del, res), m') -> (res, TrieMap (if del then n - 1 else n) m')
+ where g v = let v' = v >>= f k . getElem in ((isNothing v' && isJust v, maybe (fmap getElem v) Just v'), fmap Elem v')
-- | Delete a key and its value from the map. When the key is not
-- a member of the map, the original map is returned.
@@ -439,7 +443,8 @@ alter f k = snd . alterLookup f k
alterLookup :: (Algebraic k, TrieKey (Alg k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
alterLookup f k (TrieMap n m) = case alterLookupAlg g (toAlg k) m of
((old, delta), m') -> (old, TrieMap (n + delta) m')
- where g v = let fv = f v in ((v, just1 fv - just1 v), fv)
+ where g Nothing = let fv = f Nothing in ((Nothing, just1 fv), fmap Elem fv)
+ g (Just (Elem v)) = let fv = f (Just v) in ((Just v, just1 fv - 1), fmap Elem fv)
just1 = maybe 0 (const 1)
-- | /O(n)/. Map a function over all values in the map.
@@ -458,7 +463,7 @@ map = fmap
-- | Essentially equivalent to 'traverse' with a function that takes both the key and the value as arguments.
mapAppWithKey :: (Algebraic k, TrieKey (Alg k) m, Applicative f) =>
(k -> a -> f b) -> TrieMap k m a -> f (TrieMap k m b)
-mapAppWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (f . fromAlg) m
+mapAppWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) m
-- | Equivalent to 'traverse'.
mapApp :: (Algebraic k, TrieKey (Alg k) m, Applicative f) => (a -> f b) -> TrieMap k m a -> f (TrieMap k m b)
@@ -469,7 +474,7 @@ mapApp = traverse
-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
mapMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
-mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (f . fromAlg) . trieMap
+mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) . trieMap
-- | /O(n)/. Map values and collect the 'Just' results.
--
@@ -499,7 +504,7 @@ mapEither = mapEitherWithKey . const
-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
mapEitherWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
mapEitherWithKey f (TrieMap _ m) = (mkTrieMap mL, mkTrieMap mR)
- where (mL, mR) = mapEitherAlg (f . fromAlg) m
+ where (mL, mR) = mapEitherAlg (\ k (Elem v) -> either (Left . Elem) (Right . Elem) (f (fromAlg k) v)) m
-- |
-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
@@ -626,11 +631,11 @@ fold = foldr
-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
foldWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> b) -> b -> TrieMap k m a -> b
-foldWithKey f z = foldWithKeyAlg (f . fromAlg) z . trieMap
+foldWithKey f z = foldWithKeyAlg (\ k (Elem v) -> f (fromAlg k) v) z . trieMap
-- | /O(n+m)/. Union with a combining function that may discard some elements.
unionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (f . fromAlg) `on` trieMap
+unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (\ k (Elem v1) (Elem v2) -> Elem <$> f (fromAlg k) v1 v2) `on` trieMap
-- | /O(n+m)/.
-- Union with a combining function.
@@ -666,7 +671,7 @@ unionsWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [TrieMap k m
unionsWith = unionsWithKey . const
unionsWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
-unionsWithKey f = mkTrieMap . foldl' (unionMaybeAlg (\ k x y -> Just (f (fromAlg k) x y))) emptyAlg
+unionsWithKey f = mkTrieMap . foldl' (unionMaybeAlg (\ k (Elem x) (Elem y) -> Just $ Elem $ f (fromAlg k) x y)) emptyAlg
. Prelude.map trieMap
-- | O(n+m). Symmetric difference. Equivalent to @'unionMaybeWith' (\ _ _ -> Nothing)@.
@@ -676,7 +681,8 @@ symDifference = unionMaybeWith (\ _ _ -> Nothing)
-- | /O(n+m)/. Intersection of two maps with a combining function that may discard some elements.
intersectionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) =>
(k -> a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
-intersectionMaybeWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ intersectAlg (f . fromAlg) m1 m2
+intersectionMaybeWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $
+ intersectAlg (\ k (Elem a) (Elem b) -> Elem <$> f (fromAlg k) a b) m1 m2
-- | /O(n+m)/. Intersection with a combining function.
--
@@ -712,7 +718,8 @@ intersection = intersectionWith const
-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
-- > == singleton 3 "3:b|B"
differenceWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
-differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ differenceAlg (f . fromAlg) m1 m2
+differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $
+ differenceAlg (\ k (Elem x) (Elem y) -> Elem <$> f (fromAlg k) x y) m1 m2
-- | /O(n+m)/. Difference with a combining function.
-- When two equal keys are
@@ -724,7 +731,7 @@ differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ differenceAlg (f
-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
-- > == singleton 3 "b:B"
differenceWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
-differenceWith f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ differenceAlg (const f) m1 m2
+differenceWith = differenceWithKey . const
-- | /O(n+m)/. Difference of two maps.
-- Return elements of the first map not existing in the second map.
@@ -802,7 +809,8 @@ deleteFindMax = fromMaybe (error "cannot return the maximal element of an empty
-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
updateMin :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
updateMin f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
- where (del, m') = updateMinAlg (const (checkNothing . f)) m
+ where (del, m') = updateMinAlg (const (checkNothing . g)) m
+ g (Elem x) = Elem <$> f x
-- | Update the value at the maximal key.
--
@@ -810,7 +818,8 @@ updateMin f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
updateMax :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
updateMax f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
- where (del, m') = updateMaxAlg (const (checkNothing . f)) m
+ where (del, m') = updateMaxAlg (const (checkNothing . g)) m
+ g (Elem x) = Elem <$> f x
-- | Update the value at the minimal key.
--
@@ -818,7 +827,8 @@ updateMax f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
updateMinWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
updateMinWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
- where (del, m') = updateMinAlg (checkNothing .: f . fromAlg) m
+ where (del, m') = updateMinAlg (checkNothing .: g) m
+ g k (Elem v) = Elem <$> f (fromAlg k) v
-- | Update the value at the maximal key.
--
@@ -826,7 +836,8 @@ updateMinWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
updateMaxWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
updateMaxWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
- where (del, m') = updateMaxAlg (checkNothing .: f . fromAlg) m
+ where (del, m') = updateMaxAlg (checkNothing .: g) m
+ g k (Elem v) = Elem <$> f (fromAlg k) v
-- | Retrieves the value associated with the minimal key of the
-- map, and the map stripped of that element, or 'Nothing' if passed an
@@ -836,7 +847,7 @@ updateMaxWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
-- > minView empty == Nothing
minView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
minView (TrieMap n m) = do
- (~(_, v), m') <- getMinAlg m
+ (~(_, Elem v), m') <- getMinAlg m
return (v, TrieMap (n-1) m')
-- | Retrieves the value associated with the maximal key of the
@@ -846,7 +857,7 @@ minView (TrieMap n m) = do
-- > maxView empty == Nothing
maxView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
maxView (TrieMap n m) = do
- (~(_, v), m') <- getMaxAlg m
+ (~(_, Elem v), m') <- getMaxAlg m
return (v, TrieMap (n-1) m')
-- | Retrieves the minimal (key,value) pair of the map, and
@@ -856,7 +867,7 @@ maxView (TrieMap n m) = do
-- > minViewWithKey empty == Nothing
minViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
minViewWithKey (TrieMap n m) = do
- (~(k, v), m') <- getMinAlg m
+ (~(k, Elem v), m') <- getMinAlg m
return ((fromAlg k, v), TrieMap (n-1) m')
-- | Retrieves the maximal (key,value) pair of the map, and
@@ -866,7 +877,7 @@ minViewWithKey (TrieMap n m) = do
-- > maxViewWithKey empty == Nothing
maxViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
maxViewWithKey (TrieMap n m) = do
- ~(~(k, v), m') <- getMaxAlg m
+ ~(~(k, Elem v), m') <- getMaxAlg m
return ((fromAlg k, v), TrieMap (n-1) m')
-- | /O(n+m)/.
@@ -893,7 +904,8 @@ isSubmapOf = isSubmapOfBy (==)
-}
isSubmapOfBy :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Bool) -> TrieMap k m a -> TrieMap k m b -> Bool
-isSubmapOfBy (<=) (TrieMap n1 m1) (TrieMap n2 m2) = (Prelude.<=) n1 n2 && isSubmapAlg (<=) m1 m2
+isSubmapOfBy (<=) (TrieMap n1 m1) (TrieMap n2 m2) = (Prelude.<=) n1 n2 && isSubmapAlg (<<=) m1 m2
+ where Elem x <<= Elem y = x <= y
-- | The expression (@'split' k map@) is a pair @(map1,map2)@ where
-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
@@ -917,7 +929,7 @@ split k m = case splitLookup k m of
-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
splitLookup :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> (TrieMap k m a, Maybe a, TrieMap k m a)
-splitLookup k (TrieMap n m) = case splitLookupAlg (\ v -> (Nothing, Just v, Nothing)) (toAlg k) m of
+splitLookup k (TrieMap n m) = case splitLookupAlg (\ (Elem v) -> (Nothing, Just v, Nothing)) (toAlg k) m of
(mL, v, mR) -> (mkTrieMap mL, v, mkTrieMap mR)
-- TODO: Somehow, avoid the mkTrieMap call. Is this possible? I don't think so, without a sophisticated range-mconcat operation
-- with monoids or some crazy shit like that. \ No newline at end of file
diff --git a/TrieMap/MapTypes.hs b/TrieMap/MapTypes.hs
index 713ce48..b5b829b 100644
--- a/TrieMap/MapTypes.hs
+++ b/TrieMap/MapTypes.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeOperators, FlexibleContexts, StandaloneDeriving #-}
+{-# LANGUAGE IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving #-}
module TrieMap.MapTypes where
@@ -6,6 +6,7 @@ import Data.Foldable
import Data.Traversable
import Control.Applicative
import Prelude hiding (foldl, foldr)
+import qualified Data.IntMap as IMap
-- | 'ProdMap' is used to hold a map on the product of two key types.
newtype ProdMap m1 m2 v = PMap {unPMap :: m1 (m2 v)} deriving (Eq, Ord)
@@ -13,15 +14,33 @@ newtype ProdMap m1 m2 v = PMap {unPMap :: m1 (m2 v)} deriving (Eq, Ord)
-- | 'UnionMap' is used to hold a map on the sum of two key types.
data UnionMap m1 m2 v = m1 v :+: m2 v deriving (Eq, Ord)
-data Edge k m v = Edge [k] (Maybe v) (m (Edge k m v))
+data Edge k m v = Edge {-# UNPACK #-} !Int [k] (Maybe v) (m (Edge k m v))
type MEdge k m v = Maybe (Edge k m v)
-- | 'RadixTrie' is used to hold a map on a list of keys.
newtype RadixTrie k m v = Radix {unRad :: MEdge k m v}
+newtype Elem a = Elem {getElem :: a} deriving (Eq, Ord)
+
+instance Functor Elem where
+ fmap f (Elem x) = Elem (f x)
+
+instance Foldable Elem where
+ foldr f z (Elem a) = a `f` z
+ foldl f z (Elem a) = z `f` a
+
+instance Traversable Elem where
+ traverse f (Elem x) = Elem <$> f x
+
infixr 5 `ProdMap`
infixr 5 :+:
+class Sized a where
+ getSize :: a -> Int
+
+instance Sized (Elem a) where
+ getSize _ = 1
+
instance (Functor m1, Functor m2) => Functor (ProdMap m1 m2) where
fmap f (PMap m) = PMap (fmap (fmap f) m)
@@ -43,22 +62,25 @@ instance (Traversable m1, Traversable m2) => Traversable (UnionMap m1 m2) where
traverse f (m1 :+: m2) = liftA2 (:+:) (traverse f m1) (traverse f m2)
instance Functor m => Functor (Edge k m) where
- fmap f (Edge ks v ts) = Edge ks (fmap f v) (fmap (fmap f) ts)
+ fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts)
instance Functor m => Functor (RadixTrie k m) where
fmap f (Radix e) = Radix (fmap (fmap f) e)
instance Foldable m => Foldable (Edge k m) where
- foldr f z (Edge _ v ts) = foldr (flip (foldr f)) (foldr f z v) ts
- foldl f z (Edge _ v ts) = foldl f (foldl (foldl f) z ts) v
+ foldr f z (Edge _ _ v ts) = foldr (flip (foldr f)) (foldr f z v) ts
+ foldl f z (Edge _ _ v ts) = foldl f (foldl (foldl f) z ts) v
instance Foldable m => Foldable (RadixTrie k m) where
foldr f z (Radix e) = foldr (flip (foldr f)) z e
foldl f z (Radix e) = foldl (foldl f) z e
instance Traversable m => Traversable (Edge k m) where
- traverse f (Edge ks v ts) =
- liftA2 (Edge ks) (traverse f v) (traverse (traverse f) ts)
+ traverse f (Edge n ks v ts) =
+ liftA2 (Edge n ks) (traverse f v) (traverse (traverse f) ts)
instance Traversable m => Traversable (RadixTrie k m) where
traverse f (Radix e) = Radix <$> traverse (traverse f) e
+
+instance Traversable IMap.IntMap where
+ traverse f m = IMap.fromDistinctAscList <$> traverse (\ (k, v) -> ((,) k) <$> f v) (IMap.assocs m) \ No newline at end of file
diff --git a/TrieMap/RadixTrie.hs b/TrieMap/RadixTrie.hs
index 3a7034e..1ea5b6b 100644
--- a/TrieMap/RadixTrie.hs
+++ b/TrieMap/RadixTrie.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-}
+{-# LANGUAGE IncoherentInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-}
module TrieMap.RadixTrie (RadixTrie) where
@@ -19,10 +19,10 @@ import TrieMap.Applicative
import Prelude hiding (null, foldr, all)
instance (Eq k, Eq v, TrieKey k m) => Eq (Edge k m v) where
- Edge ks1 v1 ts1 == Edge ks2 v2 ts2 = ks1 == ks2 && v1 == v2 && assocsAlg ts1 == assocsAlg ts2
+ 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 =
+ 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)
@@ -30,11 +30,15 @@ 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)
+ 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))
@@ -63,7 +67,8 @@ instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where
fromAscListAlg f xs = Radix (edgeFromAscList f xs)
fromDistAscListAlg = fromAscListAlg (\ _ v _ -> v)
- isSubmapAlg (<=) (Radix e1) (Radix e2) = isSubmapAlg (isSubmapEdge (<=)) e1 e2
+ 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
@@ -74,52 +79,58 @@ instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where
-- sizeEdge :: Edge k m v -> Int
-- sizeEdge (Edge n _ _ _) = n
--- edge :: TrieKey k m => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v
--- edge ks v ts = Edge (maybe id (const (+1)) v $ foldl' (\ n e -> n + sizeEdge e) 0 ts) ks v ts
+{-# INLINE edge #-}
+edge :: (Sized v, TrieKey k m) => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v
+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
+lookupEdge (==) ks (Edge _ ls v ts) = procEdge ks ls where
procEdge (k:ks) (l:ls)
- | k == l = procEdge ks ls
+ | k == l = procEdge ks ls
procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge (==) ks
procEdge [] [] = v
procEdge _ _ = Nothing
-edgeFromList :: (Eq k, TrieKey k m) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
-edgeFromList f xs = guardNullEdge $ Edge [] v0 $ mapMaybeAlg (\ k -> edgeFromList (f . (k:))) $ fromListAlg (const (flip (++))) ys
+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, [(ks, v)]):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) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
+edgeFromAscList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
edgeFromAscList _ [] = Nothing
-edgeFromAscList f xs = Just $ case groupHead f xs of
- (Nothing, [(k, ~(Edge ks v ts))])
- -> Edge (k:ks) v ts
- (ans, xs') -> Edge [] ans (fromDistAscListAlg xs')
+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) => ([k] -> v -> v -> v) -> [([k], v)] -> (Maybe v, [(k, Edge k m v)])
+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 (Seq.singleton (ks, v)) xs) where
- groupHead' k0 xs ((k:ks, v):ys)
- | k == k0 = groupHead' k0 (xs |> (ks, v)) ys
- | otherwise = (k0, fromJust $ edgeFromAscList (f . (k0:)) (toList xs)):groupHead' k (Seq.singleton (ks, v)) ys
- groupHead' k0 xs [] = [(k0, fromJust $ edgeFromAscList (f . (k0:)) (toList xs))]
- groupHead' _ _ _ = error "Violation of ascending invariant!"
+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 :: TrieKey k m => [k] -> Maybe v -> MEdge k m v
-maybeSingleEdge ks = fmap (\ v -> Edge ks (Just v) emptyAlg)
+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 (Edge ks (Just v) ts)
+getSingleEdge (Edge _ ks (Just v) ts)
| nullAlg ts = Just (ks, v)
-getSingleEdge (Edge ks Nothing ts) = do
+getSingleEdge (Edge _ ks Nothing ts) = do
(x, e') <- getSingleAlg ts
(xs, v) <- getSingleEdge e'
return (ks ++ x:xs, v)
@@ -127,158 +138,164 @@ getSingleEdge _ = Nothing
{-# INLINE guardNullEdge #-}
guardNullEdge :: TrieKey k m => Edge k m v -> MEdge k m v
-guardNullEdge (Edge ks Nothing ts)
+guardNullEdge (Edge n ks Nothing ts)
| nullAlg ts = Nothing
- | Just (x, Edge xs v ts') <- getSingleAlg ts
- = Just (Edge (ks ++ x:xs) v ts')
+ | Just (x, Edge n' xs v ts') <- getSingleAlg ts
+ = Just (Edge n' (ks ++ x:xs) v ts')
guardNullEdge e = Just e
-alterLookupEdge :: (TrieKey k m) => (k -> k -> Bool) ->
+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 ls0 v ts) = procEdge 0 ks0 ls0 where
+alterLookupEdge (==) f ks0 e@(Edge n0 ls0 v 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
+ | otherwise = fmap (Just . g) (f Nothing)
where g Nothing = e
- g (Just v') = Edge (take i ks0) Nothing $
- fromListAlg' [(k, Edge ks (Just v') emptyAlg), (l, Edge ls v ts)]
+ 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)
+ proc = fmap (guardNullEdge . edge ls0 v)
procEdge i [] (l:ls) = fmap (Just . g) $ f Nothing
where g Nothing = e
- g (Just v') = Edge ks0 (Just v') $ insertAlg l (Edge ls v ts) emptyAlg
- procEdge i [] [] = (ans, guardNullEdge (Edge ks0 fv ts))
+ 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) =
+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) => ([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)
+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 => ([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)
+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 -> mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts
- tsL = mapMaybeAlg (const fst) ts'
- tsR = mapMaybeAlg (const snd) ts'
+ ts' = mapWithKeyAlg (\ x -> Elem . mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts
+ tsL = mapMaybeAlg (\ _ (Elem (tsL, _)) -> tsL) ts'
+ tsR = mapMaybeAlg (\ _ (Elem (_, tsR)) -> tsR) ts'
-mapAppEdge :: (Applicative f, TrieKey k m) => ([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)
+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)
-unionMaybeEdge :: (Eq k, TrieKey k m) => ([k] -> v -> v -> Maybe v) -> Edge k m v -> Edge k m v -> MEdge k m v
-unionMaybeEdge f (Edge ks0 vK tsK) (Edge ls0 vL tsL) = procEdge 0 ks0 ls0 where
+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
procEdge i _ _ | i `seq` False = undefined
procEdge i (k:ks) (l:ls)
| k == l = procEdge (i+1) ks ls
- | otherwise = Just $ Edge (take i ks0) Nothing $ fromListAlg' [(k, Edge ks vK tsK), (l, Edge ls vL tsL)]
- procEdge _ [] (l:ls) = guardNullEdge $ Edge ks0 vK $ alterAlg g l tsK
- where g Nothing = Just (Edge ls vL tsL)
- g (Just e') = unionMaybeEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge ls vL tsL)
- procEdge _ (k:ks) [] = guardNullEdge $ Edge ls0 vL $ alterAlg g k tsL
- where g Nothing = Just $ Edge ks vK tsK
- g (Just e') = unionMaybeEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge ks vK tsK) e'
- procEdge _ [] [] = guardNullEdge $ Edge ks0 (unionMaybe (f ks0) vK vL) $
+ | 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) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c
-intersectEdge f (Edge ks0 vK tsK) (Edge ls0 vL tsL) = procEdge ks0 ls0 where
+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
procEdge (k:ks) (l:ls)
| k == l = procEdge ks ls
| otherwise = Nothing
procEdge (k:ks) [] = do
e' <- lookupAlg k tsL
- Edge xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge ks vK tsK) e'
- return (Edge (ls0 ++ k:xs) vX tsX)
+ 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)
procEdge [] (l:ls) = do
e' <- lookupAlg l tsK
- Edge xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge ls vL tsL)
- return (Edge (ks0 ++ l:xs) vX tsX)
- procEdge [] [] = guardNullEdge $ Edge ks0 (intersectMaybe (f ks0) vK vL) $
+ 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
-differenceEdge :: (Eq k, TrieKey k m) => ([k] -> v -> w -> Maybe v) -> Edge k m v -> Edge k m w -> MEdge k m v
-differenceEdge f e@(Edge ks0 vK tsK) (Edge ls0 vL tsL) = procEdge ks0 ls0 where
+{-# 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
procEdge (k:ks) (l:ls)
| k == l = procEdge ks ls
procEdge (k:ks) []
| Just e' <- lookupAlg k tsL
- = do Edge xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge ks vK tsK) e'
- return (Edge (ls0 ++ k:xs) vX tsX)
- procEdge [] (l:ls) = guardNullEdge $ Edge ks0 vK $ alterAlg g l tsK
+ = 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 ls vL tsL)
- procEdge [] [] = guardNullEdge $ Edge ks0 (differenceMaybe (f ks0) vK vL) $
+ 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
-getMinEdge :: TrieKey k m => Edge k m v -> (([k], v), MEdge k m v)
-getMinEdge (Edge ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge ks Nothing ts)
-getMinEdge (Edge ks _ ts)
+{-# 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')
+ = ((ks ++ l:ls, v), guardNullEdge $ edge ks Nothing $ maybe ts' (\ e' -> snd $ updateMinAlg (\ _ _ -> (False, Just e')) ts) e')
getMinEdge _ = error "Uncompacted edge"
-getMaxEdge :: TrieKey k m => Edge k m v -> (([k], v), MEdge k m v)
-getMaxEdge (Edge ks v0 ts)
+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 ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge ks Nothing ts)
+ = ((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 => ([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
+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 => ([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
+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 => (a -> b -> Bool) -> Edge k m a -> Edge k m b -> Bool
-isSubmapEdge (<=) (Edge ks vK tsK) (Edge ls vL tsL) = procEdge ks ls where
+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 <- lookupAlg k tsL
- = isSubmapEdge (<=) (Edge ks vK tsK) e
+ | Just e <- lookup k tsL
+ = isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) e
procEdge [] []
- | Nothing <- vK = isSubmapAlg (isSubmapEdge (<=)) tsK tsL
+ | Nothing <- vK = tsK <<= tsL
| Just x <- vK, Just y <- vL, x <= y
- = isSubmapAlg (isSubmapEdge (<=)) tsK tsL
+ = tsK <<= tsL
procEdge _ _ = False
validEdge :: TrieKey k m => Edge k m v -> Bool
-validEdge (Edge _ Nothing m)
+validEdge (Edge _ _ Nothing m)
| nullAlg m = False
| Just{} <- getSingleAlg m
= False
-validEdge (Edge _ _ m)
+validEdge (Edge _ _ _ m)
= valid m && all validEdge m
-splitEdge :: (Ord k, 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)
-splitEdge f ks0 (Edge ls0 v ts) = procEdge ks0 ls0 where
+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 -> (Nothing, Nothing, Just (Edge ls0 v ts))
+ LT -> answerLess
EQ -> procEdge ks ls
- GT -> (Just (Edge ks0 v ts), Nothing, Nothing)
+ 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) = (Nothing, Nothing, Just $ Edge ls0 v ts)
+ (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 = (Nothing, Nothing, Just (Edge ls0 v ts))
+ = (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
diff --git a/TrieMap/Reflection.hs b/TrieMap/Reflection.hs
index 1c4b91c..1118c6d 100644
--- a/TrieMap/Reflection.hs
+++ b/TrieMap/Reflection.hs
@@ -3,12 +3,18 @@
module TrieMap.Reflection where
-- import TrieMap.Fixpoint
+import TrieMap.MapTypes
import TrieMap.TrieAlgebraic
import TrieMap.Algebraic
import TrieMap.Applicative
import TrieMap.RadixTrie()
import qualified TrieMap.TrieAlgebraic as TA
+instance Algebraic v => Algebraic (Elem v) where
+ type Alg (Elem v) = Alg v
+ toAlg (Elem v) = toAlg v
+ fromAlg v = Elem (fromAlg v)
+
instance Algebraic (m1 (m2 v)) => Algebraic (ProdMap m1 m2 v) where
type Alg (ProdMap m1 m2 v) = Alg (m1 (m2 v))
toAlg (PMap m) = toAlg m
@@ -19,7 +25,7 @@ instance (Algebraic (m1 v), Algebraic (m2 v)) => Algebraic (UnionMap m1 m2 v) wh
toAlg (m1 :+: m2) = (toAlg m1, toAlg m2)
fromAlg (m1, m2) = fromAlg m1 :+: fromAlg m2
-instance (Ord k, Algebraic k, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where
+instance (Ord k, Algebraic k, Sized v, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where
type Alg (RadixTrie k m v) = Alg [([k], v)]
toAlg m = toAlg (build (\ c n -> foldWithKeyAlg (curry c) n m))
fromAlg = fromDistAscListAlg . fromAlg \ No newline at end of file
diff --git a/TrieMap/TrieAlgebraic.hs b/TrieMap/TrieAlgebraic.hs
index 009a949..b235b02 100644
--- a/TrieMap/TrieAlgebraic.hs
+++ b/TrieMap/TrieAlgebraic.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards #-}
+{-# LANGUAGE FlexibleInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards, IncoherentInstances #-}
module TrieMap.TrieAlgebraic (TrieKey (..), ProdMap (..), UnionMap(..), RadixTrie(..), Edge (..), Ordered (..), unionMaybe, intersectMaybe, differenceMaybe, mapWithKeyAlg, assocsAlg, insertAlg, alterAlg, fromListAlg') where
@@ -35,36 +35,40 @@ instance Functor Ordered where
-- | TrieKey defines a bijection between map types and algebraic key types.
class (Eq a, Foldable m, Traversable m) => TrieKey a m | a -> m, m -> a where
- emptyAlg :: m v
- nullAlg :: m v -> Bool
- sizeAlg :: m v -> Int
- getSingleAlg :: m v -> Maybe (a, v)
- guardNullAlg :: m v -> Maybe (m v)
- {-# SPECIALIZE alterAlg :: (Maybe v -> Id (b, Maybe v)) -> a -> m v -> Id (b, m v) #-}
- alterLookupAlg :: (Maybe v -> (b, Maybe v)) -> a -> m v -> (b, m v)
- lookupAlg :: a -> m v -> Maybe v
- foldWithKeyAlg :: (a -> v -> x -> x) -> x -> m v -> x
- mapAppAlg :: Applicative f => (a -> v -> f w) -> m v -> f (m w)
- mapMaybeAlg :: (a -> v -> Maybe w) -> m v -> m w
- mapEitherAlg :: (a -> v -> Either x y) -> m v -> (m x, m y)
- unionMaybeAlg :: (a -> v -> v -> Maybe v) -> m v -> m v -> m v
- intersectAlg :: (a -> v -> w -> Maybe x) -> m v -> m w -> m x
- differenceAlg :: (a -> v -> w -> Maybe v) -> m v -> m w -> m v
- fromDistAscListAlg :: [(a, v)] -> m v
- fromAscListAlg :: (a -> v -> v -> v) -> [(a, v)] -> m v
- fromListAlg :: (a -> v -> v -> v) -> [(a, v)] -> m v
- getMinAlg :: m v -> Maybe ((a, v), m v)
- getMaxAlg :: m v -> Maybe ((a, v), m v)
- updateMinAlg :: (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)
- updateMaxAlg :: (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)
- valid :: m v -> Bool
- isSubmapAlg :: (v -> w -> Bool) -> m v -> m w -> Bool
- splitLookupAlg :: (v -> (Maybe v, Maybe x, Maybe v)) -> a -> m v -> (m v, Maybe x, m v)
+ emptyAlg :: Sized v => m v
+ nullAlg :: Sized v => m v -> Bool
+ sizeAlg :: Sized v => m v -> Int
+ getSingleAlg :: Sized v => m v -> Maybe (a, v)
+ guardNullAlg :: Sized v => m v -> Maybe (m v)
+-- {-# SPECIALIZE alterAlg :: Sized v => (Maybe v -> Id (b, Maybe v)) -> a -> m v -> Id (b, m v) #-}
+ alterLookupAlg :: Sized v => (Maybe v -> (b, Maybe v)) -> a -> m v -> (b, m v)
+ lookupAlg :: Sized v => a -> m v -> Maybe v
+ foldWithKeyAlg :: Sized v => (a -> v -> x -> x) -> x -> m v -> x
+ mapAppAlg :: (Applicative f, Sized v, Sized w) => (a -> v -> f w) -> m v -> f (m w)
+ mapMaybeAlg :: (Sized v, Sized w) => (a -> v -> Maybe w) -> m v -> m w
+ mapEitherAlg :: (Sized v, Sized x, Sized y) => (a -> v -> Either x y) -> m v -> (m x, m y)
+ unionMaybeAlg :: Sized v => (a -> v -> v -> Maybe v) -> m v -> m v -> m v
+ intersectAlg :: (Sized v, Sized w, Sized x) => (a -> v -> w -> Maybe x) -> m v -> m w -> m x
+ differenceAlg :: (Sized v, Sized w) => (a -> v -> w -> Maybe v) -> m v -> m w -> m v
+ fromDistAscListAlg :: Sized v => [(a, v)] -> m v
+ fromAscListAlg :: Sized v => (a -> v -> v -> v) -> [(a, v)] -> m v
+ fromListAlg :: Sized v => (a -> v -> v -> v) -> [(a, v)] -> m v
+ getMinAlg :: Sized v => m v -> Maybe ((a, v), m v)
+ getMaxAlg :: Sized v => m v -> Maybe ((a, v), m v)
+ updateMinAlg :: Sized v => (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)
+ updateMaxAlg :: Sized v => (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)
+ valid :: Sized v => m v -> Bool
+ isSubmapAlg :: (Sized v, Sized w) => (v -> w -> Bool) -> m v -> m w -> Bool
+ splitLookupAlg :: (Sized v) => (v -> (Maybe v, Maybe x, Maybe v)) -> a -> m v -> (m v, Maybe x, m v)
lookupAlg k = fst . alterLookupAlg (\ v -> (v, v)) k
guardNullAlg m
| nullAlg m = Nothing
| otherwise = Just m
+ getSingleAlg m = do
+ ((k, v), m') <- getMinAlg m
+ guard (nullAlg m')
+ return (k, v)
fromListAlg f = foldr (\ (k, v) -> alterAlg (Just . maybe v (f k v)) k) emptyAlg
fromAscListAlg _ [] = emptyAlg
fromAscListAlg f ((k, v):xs) = fromDistAscListAlg (distinct k v xs) where
@@ -79,28 +83,36 @@ class (Eq a, Foldable m, Traversable m) => TrieKey a m | a -> m, m -> a where
updateMaxAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMaxAlg m)
valid = (`seq` True)
-fromListAlg' :: TrieKey k m => [(k, v)] -> m v
+instance (TrieKey k m, Sized a) => Sized (m a) where
+ {-# SPECIALIZE instance (Sized a, TrieKey k1 m1, TrieKey k2 m2) => Sized (ProdMap m1 m2 a) #-}
+ {-# SPECIALIZE instance (Sized a, TrieKey k1 m1, TrieKey k2 m2) => Sized (UnionMap m1 m2 a) #-}
+ {-# SPECIALIZE instance Sized a => Sized (Maybe a) #-}
+ {-# SPECIALIZE instance Sized a => Sized (IntMap a) #-}
+ {-# SPECIALIZE instance (Ord k, Sized a) => Sized (Map k a) #-}
+ getSize = sizeAlg
+
+fromListAlg' :: (Sized v, TrieKey k m) => [(k, v)] -> m v
fromListAlg' = fromListAlg (const const)
-singletonAlg :: TrieKey k m => k -> v -> m v
+singletonAlg :: (Sized v, TrieKey k m) => k -> v -> m v
singletonAlg k v = insertAlg k v emptyAlg
-mapWithKeyAlg :: TrieKey k m => (k -> v -> w) -> m v -> m w
+mapWithKeyAlg :: (Sized v, Sized w, TrieKey k m) => (k -> v -> w) -> m v -> m w
mapWithKeyAlg f m = unId (mapAppAlg (\ k v -> Id (f k v)) m)
-- mapMaybeWithKeyAlg :: TrieKey k m => (k -> v -> Maybe w) -> m v -> m w
-- mapMaybeWithKeyAlg f m = unId (mapAppMaybeAlg (\ k v -> Id (f k v)) m)
-insertAlg :: TrieKey k m => k -> v -> m v -> m v
+insertAlg :: (Sized v, TrieKey k m) => k -> v -> m v -> m v
insertAlg k v = alterAlg (const (Just v)) k
-alterAlg :: TrieKey k m => (Maybe v -> Maybe v) -> k -> m v -> m v
+alterAlg :: (Sized v, TrieKey k m) => (Maybe v -> Maybe v) -> k -> m v -> m v
alterAlg f k = snd . alterLookupAlg (\ x -> ((), f x)) k
-- alterLookupAlg :: TrieKey k m => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a)
-- alterLookupAlg f = unId .: alterAppAlg (Id . f)
-foldrAlg :: TrieKey k m => (a -> b -> b) -> b -> m a -> b
+foldrAlg :: (Sized a, TrieKey k m) => (a -> b -> b) -> b -> m a -> b
foldrAlg = foldWithKeyAlg . const
unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
@@ -126,13 +138,13 @@ filterRight _ (Right x) = Just x
filterRight _ _ = Nothing
{-# INLINE assocsAlg #-}
-assocsAlg :: TrieKey k m => m a -> [(k, a)]
+assocsAlg :: (Sized a, TrieKey k m) => m a -> [(k, a)]
assocsAlg m = build (\ c n -> foldWithKeyAlg (\ k v xs -> (k,v) `c` xs) n m)
instance (Eq a1, Eq a2, TrieKey a1 m1, TrieKey a2 m2) => TrieKey (a1, a2) (m1 `ProdMap` m2) where
emptyAlg = PMap emptyAlg
nullAlg (PMap m) = nullAlg m
- sizeAlg (PMap m) = foldl' (\ n m -> n + sizeAlg m) 0 m
+ sizeAlg (PMap m) = sizeAlg m
getSingleAlg (PMap m) = do (k1, m') <- getSingleAlg m
(k2, v) <- getSingleAlg m'
return ((k1, k2), v)
@@ -144,16 +156,16 @@ instance (Eq a1, Eq a2, TrieKey a1 m1, TrieKey a2 m2) => TrieKey (a1, a2) (m1 `P
PMap <$> mapAppAlg (\ k1 -> mapAppAlg (\ k2 -> f (k1, k2))) m
mapMaybeAlg f (PMap m) =
PMap $ mapMaybeAlg (\ k1 -> guardNullAlg . mapMaybeAlg (\ k2 -> f (k1, k2))) m
- mapEitherAlg f (PMap m) = (PMap (fmap fst m'), PMap (fmap snd m'))
- where m' = mapWithKeyAlg (\ k1 -> mapEitherAlg (\ k2 -> f (k1, k2))) m
+ mapEitherAlg f (PMap m) = (PMap (fmap (\ (Elem (mL, _)) -> mL) m'), PMap (fmap (\ (Elem (_, mR)) -> mR) m'))
+ where m' = mapWithKeyAlg (\ k1 -> Elem . mapEitherAlg (\ k2 -> f (k1, k2))) m
unionMaybeAlg f (PMap m1) (PMap m2) =
PMap (unionMaybeAlg (\ k1 -> guardNullAlg .: unionMaybeAlg (\ k2 -> f (k1, k2))) m1 m2)
intersectAlg f (PMap m1) (PMap m2) =
PMap (intersectAlg (\ k1 -> guardNullAlg .: intersectAlg (\ k2 -> f (k1, k2))) m1 m2)
differenceAlg f (PMap m1) (PMap m2) =
PMap (differenceAlg (\ k1 -> guardNullAlg .: differenceAlg (\ k2 -> f (k1, k2))) m1 m2)
- fromListAlg f xs = PMap $ mapWithKeyAlg (\ k1 -> fromListAlg (\ k2 -> f (k1, k2))) $
- fromListAlg (const (++)) [(k1, [(k2, v)]) | ((k1, k2), v) <- xs]
+ fromListAlg f xs = PMap $ mapWithKeyAlg (\ k1 (Elem xs) -> fromListAlg (\ k2 -> f (k1, k2)) xs) $
+ fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k1, Elem [(k2, v)]) | ((k1, k2), v) <- xs]
fromDistAscListAlg xs = PMap $ fromDistAscListAlg [(k1, fromDistAscListAlg ys) | (k1, ys) <- breakFst xs]
fromAscListAlg f xs = PMap $ fromDistAscListAlg [(k1, fromAscListAlg (\ k2 -> f (k1, k2)) ys) | (k1, ys) <- breakFst xs]
getMinAlg (PMap m) = do
@@ -195,9 +207,9 @@ instance (TrieKey a1 m1, TrieKey a2 m2) => TrieKey (Either a1 a2) (m1 `UnionMap`
(Nothing, Just (k, v)) -> Just (Right k, v)
_ -> Nothing
alterLookupAlg f (Left k) (m1 :+: m2) =
- fmap (:+: m2) $ alterLookupAlg f k m1
+ (:+: m2) <$> alterLookupAlg f k m1
alterLookupAlg f (Right k) (m1 :+: m2) =
- fmap (m1 :+:) $ alterLookupAlg f k m2
+ (m1 :+:) <$> alterLookupAlg f k m2
lookupAlg k (m1 :+: m2) = either (`lookupAlg` m1) (`lookupAlg` m2) k
foldWithKeyAlg f z (m1 :+: m2) = foldWithKeyAlg (f . Left) (foldWithKeyAlg (f . Right) z m2) m1
mapAppAlg f (m1 :+: m2) =
@@ -250,7 +262,7 @@ pullEither (Right k, v) = Right (k, v)
instance TrieKey Int IntMap where
emptyAlg = IMap.empty
nullAlg = IMap.null
- sizeAlg = IMap.size
+ sizeAlg = foldl' (\ n x -> n + getSize x) 0
getSingleAlg m
| IMap.size m == 1, [(k, v)] <- IMap.toList m
= Just (k, v)
@@ -290,7 +302,7 @@ instance TrieKey Int IntMap where
instance Ord k => TrieKey (Ordered k) (Map k) where
emptyAlg = Map.empty
nullAlg = Map.null
- sizeAlg = Map.size
+ sizeAlg = foldl' (\ n x -> n + getSize x) 0
getSingleAlg m
| Map.size m == 1, (k, v) <- Map.findMin m
= Just (Ord k, v)
@@ -331,7 +343,7 @@ instance Ord k => TrieKey (Ordered k) (Map k) where
instance TrieKey () Maybe where
emptyAlg = Nothing
nullAlg = isNothing
- sizeAlg = maybe 0 (const 1)
+ sizeAlg = maybe 0 getSize
getSingleAlg = fmap ((,) ())
lookupAlg _ = id
alterLookupAlg f _ = f
@@ -348,6 +360,7 @@ instance TrieKey () Maybe where
fromListAlg _ [] = Nothing
fromListAlg f ((_, v):xs) = Just (foldr (f () . snd) v xs)
fromAscListAlg = fromListAlg
+ fromDistAscListAlg = fmap snd . listToMaybe
getMinAlg = fmap g where
g v = (((), v), Nothing)
getMaxAlg = fmap g where
@@ -357,8 +370,12 @@ instance TrieKey () Maybe where
isSubmapAlg _ Nothing _ = True
isSubmapAlg _ _ Nothing = False
isSubmapAlg (<=) (Just x) (Just y) = x <= y
- splitLookupAlg f _ (Just v) = f v
- splitLookupAlg _ _ _ = (Nothing, Nothing, Nothing)
+ splitLookupAlg f _ = maybe (Nothing, Nothing, Nothing) f
first :: (a -> c) -> (a, b) -> (c, b)
-first f (x, y) = (f x, y) \ No newline at end of file
+first f (x, y) = (f x, y)
+
+{-# RULES
+ "sizeAlg/Map/Elem" forall (m :: Map k (Elem v)) . sizeAlg m = Map.size m;
+ "sizeAlg/IMap/Elem" forall (m :: IntMap (Elem v)) . sizeAlg m = IMap.size m;
+ #-} \ No newline at end of file