summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLouisWasserman <>2009-10-01 20:01:15 (GMT)
committerLuite Stegeman <luite@luite.com>2009-10-01 20:01:15 (GMT)
commitc0ce078049172dd92dde69228599e175d12f3115 (patch)
treec77343eba1d413060f2f1c14c18a32f331d69414
parent3418bbd3d64591c612c7a437b1f51584a97ab455 (diff)
version 0.5.00.5.0
-rw-r--r--Data/TrieMap.hs355
-rw-r--r--Data/TrieMap/Applicative.hs46
-rw-r--r--Data/TrieMap/Class.hs36
-rw-r--r--Data/TrieMap/Class/Instances.hs180
-rw-r--r--Data/TrieMap/IntMap.hs478
-rw-r--r--Data/TrieMap/MultiRec.hs6
-rw-r--r--Data/TrieMap/MultiRec/Class.hs122
-rw-r--r--Data/TrieMap/MultiRec/ConstMap.hs78
-rw-r--r--Data/TrieMap/MultiRec/Eq.hs37
-rw-r--r--Data/TrieMap/MultiRec/FamMap.hs125
-rw-r--r--Data/TrieMap/MultiRec/IMap.hs86
-rw-r--r--Data/TrieMap/MultiRec/Instances.hs9
-rw-r--r--Data/TrieMap/MultiRec/Ord.hs63
-rw-r--r--Data/TrieMap/MultiRec/ProdMap.hs126
-rw-r--r--Data/TrieMap/MultiRec/Sized.hs20
-rw-r--r--Data/TrieMap/MultiRec/TagMap.hs125
-rw-r--r--Data/TrieMap/MultiRec/UnionMap.hs121
-rw-r--r--Data/TrieMap/MultiRec/UnitMap.hs79
-rw-r--r--Data/TrieMap/OrdMap.hs393
-rw-r--r--Data/TrieMap/Regular.hs6
-rw-r--r--Data/TrieMap/Regular/Base.hs60
-rw-r--r--Data/TrieMap/Regular/Class.hs69
-rw-r--r--Data/TrieMap/Regular/ConstMap.hs70
-rw-r--r--Data/TrieMap/Regular/Eq.hs64
-rw-r--r--Data/TrieMap/Regular/IdMap.hs68
-rw-r--r--Data/TrieMap/Regular/Instances.hs9
-rw-r--r--Data/TrieMap/Regular/Ord.hs71
-rw-r--r--Data/TrieMap/Regular/ProdMap.hs84
-rw-r--r--Data/TrieMap/Regular/RadixTrie.hs322
-rw-r--r--Data/TrieMap/Regular/RegMap.hs40
-rw-r--r--Data/TrieMap/Regular/Sized.hs9
-rw-r--r--Data/TrieMap/Regular/UnionMap.hs109
-rw-r--r--Data/TrieMap/Regular/UnitMap.hs75
-rw-r--r--Data/TrieMap/Sized.hs18
-rw-r--r--Data/TrieMap/TrieKey.hs109
-rw-r--r--LICENSE2
-rw-r--r--TrieMap.cabal82
-rw-r--r--TrieMap.hs954
-rw-r--r--TrieMap/Algebraic.hs417
-rw-r--r--TrieMap/Applicative.hs28
-rw-r--r--TrieMap/MapTypes.hs166
-rw-r--r--TrieMap/RadixTrie.hs274
-rw-r--r--TrieMap/Reflection.hs47
-rw-r--r--TrieMap/TrieAlgebraic.hs898
44 files changed, 3719 insertions, 2817 deletions
diff --git a/Data/TrieMap.hs b/Data/TrieMap.hs
new file mode 100644
index 0000000..4800565
--- /dev/null
+++ b/Data/TrieMap.hs
@@ -0,0 +1,355 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+
+module Data.TrieMap (
+ -- * Map type
+ TKey,
+ TMap,
+ -- * Operators
+ (!),
+ (\\),
+ -- * Query
+ null,
+ size,
+ member,
+ notMember,
+ lookup,
+ findWithDefault,
+ -- * Construction
+ empty,
+ singleton,
+ -- ** Insertion
+ insert,
+ insertWith,
+ insertWithKey,
+ -- ** Delete/Update
+ delete,
+ adjust,
+ adjustWithKey,
+ update,
+ updateWithKey,
+ alter,
+ -- * Combine
+ -- ** Union
+ union,
+ unionWith,
+ unionWithKey,
+ unionMaybeWith,
+ unionMaybeWithKey,
+ -- ** Difference
+ difference,
+ differenceWith,
+ differenceWithKey,
+ -- ** Intersection
+ intersection,
+ intersectionWith,
+ intersectionWithKey,
+ intersectionMaybeWith,
+ intersectionMaybeWithKey,
+ -- * Traversal
+ -- ** Map
+ map,
+ mapWithKey,
+ mapKeys,
+ mapKeysWith,
+ mapKeysMonotonic,
+ -- ** Traverse
+ traverseWithKey,
+ -- ** Fold
+ fold,
+ foldWithKey,
+ foldrWithKey,
+ foldlWithKey,
+ -- * Conversion
+ elems,
+ keys,
+ assocs,
+ -- ** Lists
+ fromList,
+ fromListWith,
+ fromListWithKey,
+ -- ** Ordered lists
+ fromAscList,
+ fromAscListWith,
+ fromAscListWithKey,
+ fromDistinctAscList,
+ -- * Filter
+ filter,
+ filterWithKey,
+ partition,
+ partitionWithKey,
+ mapMaybe,
+ mapMaybeWithKey,
+ mapEither,
+ mapEitherWithKey,
+ split,
+ splitLookup,
+ -- * Submap
+ isSubmapOf,
+ isSubmapOfBy,
+ -- * Min/Max
+ findMin,
+ findMax,
+ deleteMin,
+ deleteMax,
+ deleteFindMin,
+ deleteFindMax,
+ updateMin,
+ updateMax,
+ updateMinWithKey,
+ updateMaxWithKey,
+ minView,
+ maxView,
+ minViewWithKey,
+ maxViewWithKey
+ ) where
+
+import Data.TrieMap.Class
+import Data.TrieMap.Class.Instances()
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Applicative
+
+import Control.Applicative hiding (empty)
+import Control.Arrow
+import Data.Maybe hiding (mapMaybe)
+import Data.Monoid(First(..), Last(..))
+-- import Data.Foldable
+-- import Data.Traversable
+
+-- import Generics.MultiRec.Base
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Sized
+import GHC.Exts (build)
+
+import Prelude hiding (lookup, foldr, null, map, filter)
+
+-- newtype Elem a k = Elem {getElem :: a}
+empty :: TKey k => TMap k a
+empty = TMap emptyM
+
+singleton :: TKey k => k -> a -> TMap k a
+singleton k a = insert k a empty
+
+null :: TKey k => TMap k a -> Bool
+null (TMap m) = nullM m
+
+lookup :: TKey k => k -> TMap k a -> Maybe a
+lookup k (TMap m) = unK0 <$> lookupM (toRep k) m
+
+findWithDefault :: TKey k => a -> k -> TMap k a -> a
+findWithDefault a = fromMaybe a .: lookup
+
+(!) :: TKey k => TMap k a -> k -> a
+m ! k = fromMaybe (error "Element not found") (lookup k m)
+
+alter :: TKey k => (Maybe a -> Maybe a) -> k -> TMap k a -> TMap k a
+alter f k (TMap m) = TMap (alterM sizeK0 (fmap K0 . f . fmap unK0) (toRep k) m)
+
+insert :: TKey k => k -> a -> TMap k a -> TMap k a
+insert = insertWith const
+
+insertWith :: TKey k => (a -> a -> a) -> k -> a -> TMap k a -> TMap k a
+insertWith = insertWithKey . const
+
+insertWithKey :: TKey k => (k -> a -> a -> a) -> k -> a -> TMap k a -> TMap k a
+insertWithKey f k a = alter f' k where
+ f' = Just . maybe a (f k a)
+
+delete :: TKey k => k -> TMap k a -> TMap k a
+delete = alter (const Nothing)
+
+adjust :: TKey k => (a -> a) -> k -> TMap k a -> TMap k a
+adjust = adjustWithKey . const
+
+adjustWithKey :: TKey k => (k -> a -> a) -> k -> TMap k a -> TMap k a
+adjustWithKey f = updateWithKey (Just .: f)
+
+update :: TKey k => (a -> Maybe a) -> k -> TMap k a -> TMap k a
+update f = alter (>>= f)
+
+updateWithKey :: TKey k => (k -> a -> Maybe a) -> k -> TMap k a -> TMap k a
+updateWithKey f k = update (f k) k
+
+fold :: TKey k => (a -> b -> b) -> b -> TMap k a -> b
+fold = foldWithKey . const
+
+foldWithKey, foldrWithKey :: TKey k => (k -> a -> b -> b) -> b -> TMap k a -> b
+foldWithKey f z (TMap m) = foldWithKeyM (\ k (K0 a) -> f (fromRep k) a) m z
+foldrWithKey = foldWithKey
+
+foldlWithKey :: TKey k => (b -> k -> a -> b) -> b -> TMap k a -> b
+foldlWithKey f z (TMap m) = foldlWithKeyM (\ k z (K0 a) -> f z (fromRep k) a) m z
+
+traverseWithKey :: (TKey k, Applicative f) => (k -> a -> f b) -> TMap k a -> f (TMap k b)
+traverseWithKey f (TMap m) = TMap <$> traverseWithKeyM sizeK0 (\ k (K0 a) -> K0 <$> f (fromRep k) a) m
+
+map :: TKey k => (a -> b) -> TMap k a -> TMap k b
+map = fmap
+
+mapWithKey :: TKey k => (k -> a -> b) -> TMap k a -> TMap k b
+mapWithKey f (TMap m) = TMap (mapWithKeyM sizeK0 (\ k (K0 a) -> K0 (f (fromRep k) a)) m)
+
+mapKeys :: (TKey k, TKey k') => (k -> k') -> TMap k a -> TMap k' a
+mapKeys f m = fromList [(f k, a) | (k, a) <- assocs m]
+
+mapKeysWith :: (TKey k, TKey k') => (a -> a -> a) -> (k -> k') -> TMap k a -> TMap k' a
+mapKeysWith g f m = fromListWith g [(f k, a) | (k, a) <- assocs m]
+
+mapKeysMonotonic :: (TKey k, TKey k') => (k -> k') -> TMap k a -> TMap k' a
+mapKeysMonotonic f m = fromDistinctAscList [(f k, a) | (k, a) <- assocs m]
+
+union :: TKey k => TMap k a -> TMap k a -> TMap k a
+union = unionWith const
+
+unionWith :: TKey k => (a -> a -> a) -> TMap k a -> TMap k a -> TMap k a
+unionWith = unionWithKey . const
+
+unionWithKey :: TKey k => (k -> a -> a -> a) -> TMap k a -> TMap k a -> TMap k a
+unionWithKey f = unionMaybeWithKey (\ k a b -> Just (f k a b))
+
+unionMaybeWith :: TKey k => (a -> a -> Maybe a) -> TMap k a -> TMap k a -> TMap k a
+unionMaybeWith = unionMaybeWithKey . const
+
+unionMaybeWithKey :: TKey k => (k -> a -> a -> Maybe a) -> TMap k a -> TMap k a -> TMap k a
+unionMaybeWithKey f (TMap m1) (TMap m2) = TMap (unionM sizeK0 f' m1 m2) where
+ f' k (K0 a) (K0 b) = K0 <$> f (fromRep k) a b
+
+symmetricDifference :: TKey k => TMap k a -> TMap k a -> TMap k a
+symmetricDifference = unionMaybeWith (\ _ _ -> Nothing)
+
+intersection :: TKey k => TMap k a -> TMap k b -> TMap k a
+intersection = intersectionWith const
+
+intersectionWith :: TKey k => (a -> b -> c) -> TMap k a -> TMap k b -> TMap k c
+intersectionWith = intersectionWithKey . const
+
+intersectionWithKey :: TKey k => (k -> a -> b -> c) -> TMap k a -> TMap k b -> TMap k c
+intersectionWithKey f = intersectionMaybeWithKey (\ k a b -> Just (f k a b))
+
+intersectionMaybeWith :: TKey k => (a -> b -> Maybe c) -> TMap k a -> TMap k b -> TMap k c
+intersectionMaybeWith = intersectionMaybeWithKey . const
+
+intersectionMaybeWithKey :: TKey k => (k -> a -> b -> Maybe c) -> TMap k a -> TMap k b -> TMap k c
+intersectionMaybeWithKey f (TMap m1) (TMap m2) = TMap (isectM sizeK0 f' m1 m2) where
+ f' k (K0 a) (K0 b) = K0 <$> f (fromRep k) a b
+
+difference, (\\) :: TKey k => TMap k a -> TMap k b -> TMap k a
+difference = differenceWith (\ x _ -> Nothing)
+
+(\\) = difference
+
+differenceWith :: TKey k => (a -> b -> Maybe a) -> TMap k a -> TMap k b -> TMap k a
+differenceWith = differenceWithKey . const
+
+differenceWithKey :: TKey k => (k -> a -> b -> Maybe a) -> TMap k a -> TMap k b -> TMap k a
+differenceWithKey f (TMap m1) (TMap m2) = TMap (diffM sizeK0 f' m1 m2) where
+ f' k (K0 a) (K0 b) = K0 <$> f (fromRep k) a b
+
+minView, maxView :: TKey k => TMap k a -> Maybe (a, TMap k a)
+minView m = first snd <$> minViewWithKey m
+maxView m = first snd <$> maxViewWithKey m
+
+findMin, findMax :: TKey k => TMap k a -> (k, a)
+findMin = maybe (error "empty map has no minimal element") fst . minViewWithKey
+findMax = maybe (error "empty map has no maximal element") fst . maxViewWithKey
+
+deleteMin, deleteMax :: TKey k => TMap k a -> TMap k a
+deleteMin m = maybe m snd (minViewWithKey m)
+deleteMax m = maybe m snd (maxViewWithKey m)
+
+updateMin, updateMax :: TKey k => (a -> Maybe a) -> TMap k a -> TMap k a
+updateMin = updateMinWithKey . const
+updateMax = updateMaxWithKey . const
+
+updateMinWithKey, updateMaxWithKey :: TKey k => (k -> a -> Maybe a) -> TMap k a -> TMap k a
+updateMinWithKey f (TMap m) = TMap (alterMinM sizeK0 (\ k (K0 a) -> K0 <$> f (fromRep k) a) m)
+updateMaxWithKey f (TMap m) = TMap (alterMaxM sizeK0 (\ k (K0 a) -> K0 <$> f (fromRep k) a) m)
+
+deleteFindMin, deleteFindMax :: TKey k => TMap k a -> ((k, a), TMap k a)
+deleteFindMin m = fromMaybe (error "Cannot return the minimal element of an empty map") (minViewWithKey m)
+deleteFindMax m = fromMaybe (error "Cannot return the maximal element of an empty map") (maxViewWithKey m)
+
+minViewWithKey, maxViewWithKey :: TKey k => TMap k a -> Maybe ((k, a), TMap k a)
+minViewWithKey (TMap m) = do
+ ((k, K0 a), m') <- getFirst (extractMinM sizeK0 m)
+ return ((fromRep k, a), TMap m')
+maxViewWithKey (TMap m) = do
+ ((k, K0 a), m') <- getLast (extractMaxM sizeK0 m)
+ return ((fromRep k, a), TMap m')
+
+elems :: TKey k => TMap k a -> [a]
+elems = fmap snd . assocs
+
+keys :: TKey k => TMap k a -> [k]
+keys = fmap fst . assocs
+
+assocs :: TKey k => TMap k a -> [(k, a)]
+assocs m = build (\ c n -> foldWithKey (curry c) n m)
+
+mapEither :: TKey k => (a -> Either b c) -> TMap k a -> (TMap k b, TMap k c)
+mapEither = mapEitherWithKey . const
+
+mapEitherWithKey :: TKey k => (k -> a -> Either b c) -> TMap k a -> (TMap k b, TMap k c)
+mapEitherWithKey f (TMap m) = case mapEitherM sizeK0 sizeK0 f' m of
+ (mL, mR) -> (TMap mL, TMap mR)
+ where f' k (K0 a) = case f (fromRep k) a of
+ Left b -> (Just (K0 b), Nothing)
+ Right c -> (Nothing, Just (K0 c))
+
+mapMaybe :: TKey k => (a -> Maybe b) -> TMap k a -> TMap k b
+mapMaybe = mapMaybeWithKey . const
+
+mapMaybeWithKey :: TKey k => (k -> a -> Maybe b) -> TMap k a -> TMap k b
+mapMaybeWithKey f (TMap m) = TMap (snd (mapEitherM sizeK0 sizeK0 f' m)) where
+ f' k (K0 a) = (Nothing, K0 <$> f (fromRep k) a)
+
+partition :: TKey k => (a -> Bool) -> TMap k a -> (TMap k a, TMap k a)
+partition = partitionWithKey . const
+
+partitionWithKey :: TKey k => (k -> a -> Bool) -> TMap k a -> (TMap k a, TMap k a)
+partitionWithKey p = mapEitherWithKey (\ k a -> (if p k a then Left else Right) a)
+
+filter :: TKey k => (a -> Bool) -> TMap k a -> TMap k a
+filter = filterWithKey . const
+
+filterWithKey :: TKey k => (k -> a -> Bool) -> TMap k a -> TMap k a
+filterWithKey p = mapMaybeWithKey (\ k a -> if p k a then Just a else Nothing)
+
+split :: TKey k => k -> TMap k a -> (TMap k a, TMap k a)
+split k m = case splitLookup k m of
+ (mL, _, mR) -> (mL, mR)
+
+splitLookup :: TKey k => k -> TMap k a -> (TMap k a, Maybe a, TMap k a)
+splitLookup k (TMap m) = case splitLookupM sizeK0 f (toRep k) m of
+ (mL, x, mR) -> (TMap mL, x, TMap mR)
+ where f (K0 x) = (Nothing, Just x, Nothing)
+
+isSubmapOf :: (TKey k, Eq a) => TMap k a -> TMap k a -> Bool
+isSubmapOf = isSubmapOfBy (==)
+
+isSubmapOfBy :: TKey k => (a -> b -> Bool) -> TMap k a -> TMap k b -> Bool
+isSubmapOfBy (<=) (TMap m1) (TMap m2) = isSubmapM (<<=) m1 m2 where
+ K0 a <<= K0 b = a <= b
+
+fromList, fromAscList :: TKey k => [(k, a)] -> TMap k a
+fromList = fromListWith const
+fromAscList = fromAscListWith const
+
+fromListWith, fromAscListWith :: TKey k => (a -> a -> a) -> [(k, a)] -> TMap k a
+fromListWith = fromListWithKey . const
+fromAscListWith = fromAscListWithKey . const
+
+fromListWithKey, fromAscListWithKey :: TKey k => (k -> a -> a -> a) -> [(k, a)] -> TMap k a
+fromListWithKey f xs = TMap (fromListM sizeK0 (\ k (K0 a) (K0 b) -> K0 (f (fromRep k) a b)) [(toRep k, K0 a) | (k, a) <- xs])
+fromAscListWithKey f xs = TMap (fromAscListM sizeK0 (\ k (K0 a) (K0 b) -> K0 (f (fromRep k) a b)) [(toRep k, K0 a) | (k, a) <- xs])
+
+fromDistinctAscList :: TKey k => [(k, a)] -> TMap k a
+fromDistinctAscList xs = TMap (fromDistAscListM sizeK0 [(toRep k, K0 a) | (k, a) <- xs])
+
+size :: TKey k => TMap k a -> Int
+size (TMap m) = sizeM sizeK0 m
+
+member :: TKey k => k -> TMap k a -> Bool
+member = isJust .: lookup
+
+notMember :: TKey k => k -> TMap k a -> Bool
+notMember = not .: member \ No newline at end of file
diff --git a/Data/TrieMap/Applicative.hs b/Data/TrieMap/Applicative.hs
new file mode 100644
index 0000000..3618bc3
--- /dev/null
+++ b/Data/TrieMap/Applicative.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}
+
+module Data.TrieMap.Applicative where
+
+import Control.Applicative
+import Control.Monad
+
+import Data.Monoid
+
+newtype Id a = Id {unId :: a}
+
+deriving instance Functor First
+deriving instance Functor Last
+deriving instance Monad First
+deriving instance Monad Last
+
+instance Applicative Id where
+ pure = Id
+ Id f <*> Id x = Id (f x)
+
+instance Functor Id where
+ fmap f (Id x) = Id (f x)
+
+instance MonadPlus First where
+ mzero = mempty
+ mplus = mappend
+
+instance MonadPlus Last where
+ mzero = mempty
+ mplus = mappend
+
+-- instance Monad First where
+-- return x = First (Just x)
+-- First Nothing >>= _ = First Nothing
+-- First (Just x) >>= k = k x
+--
+-- instance Monad Last
+
+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+(f .: g) x y = f (g x y)
+
+(<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c
+f <.> g = fmap f . g
+
+(<.:>) :: Functor f => (c -> d) -> (a -> b -> f c) -> a -> b -> f d
+(f <.:> g) x y = f <$> g x y \ No newline at end of file
diff --git a/Data/TrieMap/Class.hs b/Data/TrieMap/Class.hs
new file mode 100644
index 0000000..5301bf1
--- /dev/null
+++ b/Data/TrieMap/Class.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}
+
+module Data.TrieMap.Class (TMap(..), TKey(..), Rep, Ordered (..), TrieMap, TrieKey) where
+
+import Data.TrieMap.TrieKey
+import Data.TrieMap.OrdMap
+
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+-- import Generics.MultiRec.Base
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Sized
+
+import Prelude hiding (foldr)
+
+newtype TMap k a = TMap {getTMap :: TrieMap (Rep k) (K0 a) (Rep k)}
+
+type family Rep k
+
+class TrieKey (Rep k) (TrieMap (Rep k)) => TKey k where
+ toRep :: k -> Rep k
+ fromRep :: Rep k -> k
+
+instance TKey k => Functor (TMap k) where
+ fmap = fmapDefault
+
+instance TKey k => Foldable (TMap k) where
+ foldr f z (TMap m) = foldWithKeyM (\ _ (K0 a) -> f a) m z
+
+instance TKey k => Traversable (TMap k) where
+ traverse = trv
+-- traverse f (TMap m) = TMap <$> traverseWithKeyM (\ _ (K0 a) -> K0 <$> f a) m
+trv :: (Applicative f, TKey k) => (a -> f b) -> TMap k a -> f (TMap k b)
+trv f (TMap m) = TMap <$> traverseWithKeyM sizeK0 (\ _ (K0 a) -> K0 <$> f a) m \ No newline at end of file
diff --git a/Data/TrieMap/Class/Instances.hs b/Data/TrieMap/Class/Instances.hs
new file mode 100644
index 0000000..b329634
--- /dev/null
+++ b/Data/TrieMap/Class/Instances.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
+
+module Data.TrieMap.Class.Instances where
+
+import Data.TrieMap.Class
+-- import Data.TrieMap.RadixTrie()
+import Data.TrieMap.MultiRec.Instances
+import Data.TrieMap.IntMap()
+import Data.TrieMap.OrdMap(Ordered(..))
+import Data.TrieMap.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Instances
+-- import Data.TrieMap.UnionMap()
+-- import Data.TrieMap.UnitMap()
+
+import Data.Bits
+import Data.Char
+import Data.Complex
+import Data.Either
+import Data.Foldable
+import Data.Int
+import Data.List hiding (foldr)
+import Data.Word
+
+import Prelude hiding (foldr)
+{-
+instance TKey k => TKey [k] where
+ type Rep [k] = L I0 (Rep k)
+ toRep = map toRep
+ fromRep = map fromRep-}
+
+type instance Rep Int = Ordered Int
+instance TKey Int where
+ toRep = Ord
+ fromRep = unOrd
+
+type instance Rep Double = Ordered Double
+instance TKey Double where
+ toRep = Ord
+ fromRep = unOrd
+
+type instance Rep Char = Int
+instance TKey Char where
+ toRep = ord
+ fromRep = chr
+
+type instance Rep Word = Int
+instance TKey Word where
+ toRep = fromEnum
+ fromRep = toEnum
+
+type instance Rep Word8 = Int
+instance TKey Word8 where
+ toRep = fromEnum
+ fromRep = toEnum
+
+type instance Rep Word16 = Int
+instance TKey Word16 where
+ toRep = fromEnum
+ fromRep = toEnum
+
+type instance Rep Word32 = Int
+instance TKey Word32 where
+ toRep = fromEnum
+ fromRep = toEnum
+
+type instance Rep Int8 = Int
+instance TKey Int8 where
+ toRep = fromIntegral
+ fromRep = fromIntegral
+
+type instance Rep Int16 = Int
+instance TKey Int16 where
+ toRep = fromIntegral
+ fromRep = fromIntegral
+
+type instance Rep Int32 = Int
+instance TKey Int32 where
+ toRep = fromIntegral
+ fromRep = fromIntegral
+--
+-- type instance Rep (Complex a) = Rep (a, a)
+-- instance (RealFloat a, TKey a) => TKey (Complex a) where
+-- toRep (a :+ b) = toRep (a, b)
+-- fromRep = uncurry (:+) . fromRep
+
+type instance Rep Integer = Rep [Int32]
+instance TKey Integer where
+ toRep = toRep . unroll
+ fromRep = roll . fromRep
+
+unroll :: Integer -> [Int32]
+unroll = unfoldr step where
+ step 0 = Nothing
+ step i = Just (fromIntegral i, i `shiftR` 32)
+
+roll :: [Int32] -> Integer
+roll = foldr unstep 0 where
+ unstep b a = a `shiftL` 32 .|. fromIntegral b
+
+type instance Rep () = U0 ()
+instance TKey () where
+ toRep _ = U0
+ fromRep _ = ()
+
+type instance Rep (Either a b) = (K0 (Rep a) :+: I0) (Rep b)
+instance (TKey a, TKey b) => TKey (Either a b) where
+ toRep = either (L . K0 . toRep) (R . I0 . toRep)
+ fromRep = either' (Left . unK0 . fromRep) (Right . unI0 . fromRep)
+
+either' :: (f r -> a) -> (g r -> a) -> (f :+: g) r -> a
+either' f g x = case x of
+ L x -> f x
+ R x -> g x
+
+type instance Rep (a, b) = (K0 (Rep a) :*: I0) (Rep b)
+instance (TKey a, TKey b) => TKey (a, b) where
+ toRep (a, b) = K0 (toRep a) :*: I0 (toRep b)
+ fromRep (K0 a :*: I0 b) = (fromRep a, fromRep b)
+
+type instance Rep (a, b, c) = (K0 (Rep a) :*: K0 (Rep b) :*: I0) (Rep c)
+instance (TKey a, TKey b, TKey c) => TKey (a, b, c) where
+ toRep (a, b, c) = K0 (toRep a) :*: K0 (toRep b) :*: I0 (toRep c)
+ fromRep (K0 a :*: K0 b :*: I0 c) = (fromRep a, fromRep b, fromRep c)
+
+type instance Rep (a, b, c, d) = (K0 (Rep a) :*: K0 (Rep b) :*: K0 (Rep c) :*: I0) (Rep d)
+instance (TKey a, TKey b, TKey c, TKey d) => TKey (a, b, c, d) where
+ toRep (a, b, c, d) = K0 (toRep a) :*: K0 (toRep b) :*: K0 (toRep c) :*: I0 (toRep d)
+ fromRep (K0 a :*: K0 b :*: K0 c :*: I0 d) = (fromRep a, fromRep b, fromRep c, fromRep d)
+
+type instance Rep (a, b, c, d, e) = (K0 (Rep a) :*: K0 (Rep b) :*: K0 (Rep c) :*: K0 (Rep d) :*: I0) (Rep e)
+instance (TKey a, TKey b, TKey c, TKey d, TKey e) => TKey (a, b, c, d, e) where
+ toRep (a, b, c, d, e) = K0 (toRep a) :*: K0 (toRep b) :*: K0 (toRep c) :*: K0 (toRep d) :*: I0 (toRep e)
+ fromRep (K0 a :*: K0 b :*: K0 c :*: K0 d :*: I0 e) = (fromRep a, fromRep b, fromRep c, fromRep d, fromRep e)
+
+type instance Rep (Maybe a) = (U0 :+: I0) (Rep a)
+instance TKey a => TKey (Maybe a) where
+ toRep = maybe (L U0) (R . I0 . toRep)
+ fromRep = either' (const Nothing) (Just . fromRep . unI0)
+
+type instance Rep [a] = L I0 (Rep a)
+instance TKey a => TKey [a] where
+ toRep xs = List [I0 (toRep x) | x <- xs]
+ fromRep (List xs) = [fromRep x | I0 x <- xs]
+
+type instance Rep ((f :*: g) r) = (f :*: g) (Rep r)
+instance (TKey a, TrieKeyT f (TrieMapT f), TrieKeyT g (TrieMapT g), Functor f, Functor g) => TKey ((f :*: g) a) where
+ toRep = fmap toRep
+ fromRep = fmap fromRep
+
+type instance Rep ((f :+: g) r) = (f :+: g) (Rep r)
+instance (TKey a, TrieKeyT f (TrieMapT f), TrieKeyT g (TrieMapT g), Functor f, Functor g) => TKey ((f :+: g) a) where
+ toRep = fmap toRep
+ fromRep = fmap fromRep
+{-
+type instance Rep [r] = L I0 (Rep r)
+instance TKey r => TKey [r] where
+ toRep = List . map (I0 . toRep)
+ fromRep (List xs) = [fromRep x | I0 x <- xs]-}
+
+type instance Rep (L f r) = L f (Rep r)
+instance (TKey a, TrieKeyT f (TrieMapT f), Functor f) => TKey (L f a) where
+ toRep = fmap toRep
+ fromRep = fmap fromRep
+
+type instance Rep (U0 r) = U0 r
+instance TKey (U0 r) where
+ toRep _ = U0
+ fromRep _ = U0
+
+type instance Rep (K0 k r) = K0 (Rep k) r
+instance TKey k => TKey (K0 k r) where
+ toRep (K0 a) = K0 (toRep a)
+ fromRep (K0 a) = K0 (fromRep a)
+
+type instance Rep (I0 r) = I0 (Rep r)
+instance TKey r => TKey (I0 r) where
+ toRep = fmap toRep
+ fromRep = fmap fromRep \ No newline at end of file
diff --git a/Data/TrieMap/IntMap.hs b/Data/TrieMap/IntMap.hs
new file mode 100644
index 0000000..43bfbf4
--- /dev/null
+++ b/Data/TrieMap/IntMap.hs
@@ -0,0 +1,478 @@
+{-# LANGUAGE BangPatterns, Rank2Types, CPP, MagicHash, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}
+
+module Data.TrieMap.IntMap () where
+
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Applicative
+import Data.TrieMap.Sized
+
+import Control.Applicative (Applicative(..), (<$>))
+import Control.Arrow
+
+import Data.Bits
+import Data.Maybe
+import Data.Monoid
+import Data.Word
+
+#if __GLASGOW_HASKELL__ >= 503
+import GHC.Exts ( Word(..), Int(..), shiftRL# )
+#elif __GLASGOW_HASKELL__
+import Word
+import GlaExts ( Word(..), Int(..), shiftRL# )
+#else
+import Data.Word
+#endif
+
+import Prelude hiding (lookup, null, foldl, foldr)
+
+type Nat = Word
+
+data IntMap a ix = Nil
+ | Tip {-# UNPACK #-} !Size {-# UNPACK #-} !Key (a ix)
+ | Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a ix) !(IntMap a ix)
+type instance TrieMap Int = IntMap
+
+type Prefix = Int
+type Mask = Int
+type Key = Int
+type Size = Int
+
+instance TrieKey Int IntMap where
+ emptyM = Nil
+ nullM = null
+ sizeM _ = size
+ lookupM = lookup . natFromInt
+ lookupIxM _ = lookupIx . natFromInt
+ assocAtM _ = fromJust .: assocAt
+ updateAtM = updateAt
+ alterM = alter
+ traverseWithKeyM = traverseWithKey
+ foldWithKeyM = foldr
+ foldlWithKeyM = foldl
+ mapEitherM = mapEither
+ splitLookupM = splitLookup
+ unionM = unionWithKey
+ isectM = intersectionWithKey
+ diffM = differenceWithKey
+ extractMinM _ = First . minViewWithKey
+ extractMaxM _ = Last . maxViewWithKey
+ alterMinM = updateMinWithKey
+ alterMaxM = updateMaxWithKey
+ isSubmapM = isSubmapOfBy
+
+natFromInt :: Int -> Nat
+natFromInt = fromIntegral
+
+intFromNat :: Nat -> Int
+intFromNat = fromIntegral
+
+shiftRL :: Nat -> Key -> Nat
+#if __GLASGOW_HASKELL__
+{--------------------------------------------------------------------
+ GHC: use unboxing to get @shiftRL@ inlined.
+--------------------------------------------------------------------}
+shiftRL (W# x) (I# i)
+ = W# (shiftRL# x i)
+#else
+shiftRL x i = shiftR x i
+#endif
+
+
+size :: IntMap a ix -> Int
+size Nil = 0
+size (Tip s _ _) = s
+size (Bin s _ _ _ _) = s
+
+null :: IntMap a ix -> Bool
+null Nil = True
+null _ = False
+
+lookup :: Nat -> IntMap a ix -> Maybe (a ix)
+lookup k (Bin _ _ m l r) = lookup k (if zeroN k (natFromInt m) then l else r)
+lookup k (Tip _ kx x)
+ | k == natFromInt kx = Just x
+lookup _ _ = Nothing
+
+lookupIx :: Nat -> IntMap a ix -> Maybe (Int, a ix)
+lookupIx k t = case t of
+ Bin _ 0 m l r | m < 0 -> if zeroN k (natFromInt m) then lookupIx' (size r) k l else lookupIx' 0 k r
+ Bin{} -> lookupIx' 0 k t
+ Tip _ k x -> return (0, x)
+ Nil -> Nothing
+
+assocAt :: Int -> IntMap a ix -> Maybe (Int, Key, a ix)
+assocAt !i t = case t of
+ Bin _ 0 m l r | m < 0 -> let sr = size r in
+ if i < sr then assocAt' 0 i r else assocAt' sr (i - sr) l
+ Bin{} -> assocAt' 0 i t
+ Tip _ k x -> return (0, k, x)
+ _ -> Nothing
+
+assocAt' :: Int -> Int -> IntMap a ix -> Maybe (Int, Key, a ix)
+assocAt' !i0 !i (Bin _ _ _ l r)
+ | i < sl = assocAt' i0 i l
+ | otherwise = assocAt' (i0 + sl) (i - sl) r
+ where sl = size l
+assocAt' i0 _ (Tip _ k x) = return (i0, k, x)
+assocAt' _ _ _ = Nothing
+
+updateAt :: Sized a -> (Int -> Key -> a ix -> Maybe (a ix)) -> Int -> IntMap a ix -> IntMap a ix
+updateAt s f !i t = case t of
+ Bin _ 0 m l r | m < 0 -> let sr = size r in
+ if i < sr then updateAt' s 0 f i r else updateAt' s sr f (i - sr) l
+ Bin{} -> updateAt' s 0 f i t
+ Tip _ kx x -> singletonMaybe s kx (f 0 kx x)
+ Nil -> Nil
+
+updateAt' :: Sized a -> Int -> (Int -> Key -> a ix -> Maybe (a ix)) -> Int -> IntMap a ix -> IntMap a ix
+updateAt' s !i0 f !i t = case t of
+ Bin _ p m l r -> let sl = size l in
+ if i < sl then bin p m (updateAt' s i0 f i l) r
+ else bin p m l (updateAt' s (i0 + sl) f (i - sl) r)
+
+lookupIx' :: Int -> Nat -> IntMap a ix -> Maybe (Int, a ix)
+lookupIx' !i k t = case t of
+ Bin _ _ m l r
+ | zeroN k (natFromInt m) -> lookupIx' i k l
+ | otherwise -> lookupIx' (i + size l) k r
+ Tip _ kx x
+ | k == natFromInt kx -> Just (i, x)
+ _ -> Nothing
+
+singleton :: Sized a -> Key -> a ix -> IntMap a ix
+singleton s k a = Tip (s a) k a
+
+singletonMaybe :: Sized a -> Key -> Maybe (a ix) -> IntMap a ix
+singletonMaybe s k = maybe Nil (singleton s k)
+
+alter :: Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> Int -> IntMap a ix -> IntMap a ix
+alter s f k t = case t of
+ Bin sz p m l r
+ | nomatch k p m -> singletonMaybe s k (f Nothing)
+ | zero k m -> bin p m (alter s f k l) r
+ | otherwise -> bin p m l (alter s f k r)
+ Tip sz ky y
+ | k == ky -> singletonMaybe s k (f (Just y))
+ | Just x <- f Nothing
+ -> join k (Tip (s x) k x) ky t
+ | otherwise -> Tip sz ky y
+ Nil -> singletonMaybe s k (f Nothing)
+
+traverseWithKey :: Applicative f => Sized b -> (Key -> a ix -> f (b ix)) -> IntMap a ix -> f (IntMap b ix)
+traverseWithKey s f t = case t of
+ Nil -> pure Nil
+ Tip _ kx x -> singleton s kx <$> f kx x
+ Bin _ p m l r -> bin p m <$> traverseWithKey s f l <*> traverseWithKey s f r
+
+foldr :: (Key -> a ix -> b -> b) -> IntMap a ix -> b -> b
+foldr f t
+ = case t of
+ Bin _ 0 m l r | m < 0 -> foldr' f r . foldr' f l -- put negative numbers before.
+ Bin _ _ _ _ _ -> foldr' f t
+ Tip _ k x -> f k x
+ Nil -> id
+
+foldr' :: (Key -> a ix -> b -> b) -> IntMap a ix -> b -> b
+foldr' f t
+ = case t of
+ Bin _ _ _ l r -> foldr' f l . foldr' f r
+ Tip _ k x -> f k x
+ Nil -> id
+
+foldl, foldl' :: (Key -> b -> a ix -> b) -> IntMap a ix -> b -> b
+foldl f t
+ = case t of
+ Bin _ 0 m l r | m < 0 -> foldl' f l . foldl' f r -- put negative numbers before.
+ Bin _ _ _ _ _ -> foldl' f t
+ Tip _ k x -> flip (f k) x
+ Nil -> id
+foldl' f t
+ = case t of
+ Bin _ _ _ l r -> foldl' f r . foldl' f l
+ Tip _ k x -> flip (f k) x
+ Nil -> id
+
+mapEither :: Sized b -> Sized c -> EitherMap Key (a ix) (b ix) (c ix) ->
+ IntMap a ix -> (IntMap b ix, IntMap c ix)
+mapEither s1 s2 f (Bin _ p m l r) = case (mapEither s1 s2 f l, mapEither s1 s2 f r) of
+ ((lL, lR), (rL, rR)) -> (bin p m lL rL, bin p m lR rR)
+mapEither s1 s2 f (Tip _ kx x) = (singletonMaybe s1 kx *** singletonMaybe s2 kx) (f kx x)
+
+splitLookup :: Sized a -> SplitMap (a ix) x -> Key -> IntMap a ix -> (IntMap a ix ,Maybe x,IntMap a ix)
+splitLookup s f k t
+ = case t of
+ Bin _ _ m l r
+ | m < 0 -> (if k >= 0 -- handle negative numbers.
+ then let (lt,found,gt) = splitLookup' s f k l in (union r lt,found, gt)
+ else let (lt,found,gt) = splitLookup' s f k r in (lt,found, union gt l))
+ | otherwise -> splitLookup' s f k t
+ Tip _ ky y
+ | k>ky -> (t,Nothing,Nil)
+ | k<ky -> (Nil,Nothing,t)
+ | otherwise -> singletonMaybe s k `sides` f y
+ Nil -> (Nil,Nothing,Nil)
+
+splitLookup' :: Sized a -> SplitMap (a ix) x -> Key -> IntMap a ix -> (IntMap a ix ,Maybe x,IntMap a ix)
+splitLookup' s f k t
+ = case t of
+ Bin _ p m l r
+ | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)
+ | zero k m -> let (lt,found,gt) = splitLookup s f k l in (lt,found,union gt r)
+ | otherwise -> let (lt,found,gt) = splitLookup s f k r in (union l lt,found,gt)
+ Tip _ ky y
+ | k>ky -> (t,Nothing,Nil)
+ | k<ky -> (Nil,Nothing,t)
+ | otherwise -> singletonMaybe s k `sides` f y
+ Nil -> (Nil,Nothing,Nil)
+
+union :: IntMap a ix -> IntMap a ix -> IntMap a ix
+union t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
+ | shorter m1 m2 = union1
+ | shorter m2 m1 = union2
+ | p1 == p2 = bin p1 m1 (union l1 l2) (union r1 r2)
+ | otherwise = join p1 t1 p2 t2
+ where
+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
+ | zero p2 m1 = bin p1 m1 (union l1 t2) r1
+ | otherwise = bin p1 m1 l1 (union r1 t2)
+
+ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
+ | zero p1 m2 = bin p2 m2 (union t1 l2) r2
+ | otherwise = bin p2 m2 l2 (union t1 r2)
+
+unionWithKey :: Sized a -> UnionFunc Key (a ix) -> IntMap a ix -> IntMap a ix -> IntMap a ix
+unionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
+ | shorter m1 m2 = union1
+ | shorter m2 m1 = union2
+ | p1 == p2 = bin p1 m1 (unionWithKey s f l1 l2) (unionWithKey s f r1 r2)
+ | otherwise = join p1 t1 p2 t2
+ where
+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2
+ | zero p2 m1 = bin p1 m1 (unionWithKey s f l1 t2) r1
+ | otherwise = bin p1 m1 l1 (unionWithKey s f r1 t2)
+
+ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2
+ | zero p1 m2 = bin p2 m2 (unionWithKey s f t1 l2) r2
+ | otherwise = bin p2 m2 l2 (unionWithKey s f t1 r2)
+unionWithKey s f (Tip _ k x) t = alter s (maybe (Just x) (f k x)) k t
+unionWithKey s f t (Tip _ k x) = alter s (maybe (Just x) (flip (f k) x)) k t
+unionWithKey _ _ Nil t = t
+unionWithKey _ _ t Nil = t
+
+intersectionWithKey :: Sized c -> IsectFunc Key (a ix) (b ix) (c ix) -> IntMap a ix -> IntMap b ix -> IntMap c ix
+intersectionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
+ | shorter m1 m2 = intersection1
+ | shorter m2 m1 = intersection2
+ | p1 == p2 = bin p1 m1 (intersectionWithKey s f l1 l2) (intersectionWithKey s f r1 r2)
+ | otherwise = Nil
+ where
+ intersection1 | nomatch p2 p1 m1 = Nil
+ | zero p2 m1 = intersectionWithKey s f l1 t2
+ | otherwise = intersectionWithKey s f r1 t2
+
+ intersection2 | nomatch p1 p2 m2 = Nil
+ | zero p1 m2 = intersectionWithKey s f t1 l2
+ | otherwise = intersectionWithKey s f t1 r2
+
+intersectionWithKey s f (Tip _ k x) t2
+ = singletonMaybe s k (lookup (natFromInt k) t2 >>= f k x)
+intersectionWithKey s f t1 (Tip _ k y)
+ = singletonMaybe s k (lookup (natFromInt k) t1 >>= flip (f k) y)
+intersectionWithKey _ _ Nil _ = Nil
+intersectionWithKey _ _ _ Nil = Nil
+
+differenceWithKey :: Sized a -> (Key -> a ix -> b ix -> Maybe (a ix)) -> IntMap a ix -> IntMap b ix -> IntMap a ix
+differenceWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
+ | shorter m1 m2 = difference1
+ | shorter m2 m1 = difference2
+ | p1 == p2 = bin p1 m1 (differenceWithKey s f l1 l2) (differenceWithKey s f r1 r2)
+ | otherwise = t1
+ where
+ difference1 | nomatch p2 p1 m1 = t1
+ | zero p2 m1 = bin p1 m1 (differenceWithKey s f l1 t2) r1
+ | otherwise = bin p1 m1 l1 (differenceWithKey s f r1 t2)
+
+ difference2 | nomatch p1 p2 m2 = t1
+ | zero p1 m2 = differenceWithKey s f t1 l2
+ | otherwise = differenceWithKey s f t1 r2
+
+differenceWithKey s f t1@(Tip _ k x) t2
+ = maybe t1 (singletonMaybe s k . f k x) (lookup (natFromInt k) t2)
+differenceWithKey _ _ Nil _ = Nil
+differenceWithKey s f t (Tip _ k y) = alter s (>>= flip (f k) y) k t
+differenceWithKey _ _ t Nil = t
+
+isSubmapOfBy :: LEq (a ix) (b ix) -> LEq (IntMap a ix) (IntMap b ix)
+isSubmapOfBy (<=) t1@(Bin _ p1 m1 l1 r1) (Bin _ p2 m2 l2 r2)
+ | shorter m1 m2 = False
+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy (<=) t1 l2
+ else isSubmapOfBy (<=) t1 r2)
+ | otherwise = (p1==p2) && isSubmapOfBy (<=) l1 l2 && isSubmapOfBy (<=) r1 r2
+isSubmapOfBy _ (Bin _ _ _ _ _) _ = False
+isSubmapOfBy (<=) (Tip _ k x) t = maybe False (x <=) (lookup (natFromInt k) t)
+isSubmapOfBy _ Nil _ = True
+
+
+maxViewWithKey, minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)
+maxViewWithKey t
+ = case t of
+ Bin _ p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in Just (result, bin p m t' r)
+ Bin _ p m l r -> let (result, t') = maxViewUnsigned r in Just (result, bin p m l t')
+ Tip _ k y -> Just ((k,y), Nil)
+ Nil -> Nothing
+
+maxViewUnsigned, minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)
+maxViewUnsigned t
+ = case t of
+ Bin _ p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')
+ Tip _ k y -> ((k,y), Nil)
+ Nil -> error "maxViewUnsigned Nil"
+
+--
+-- minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)
+minViewWithKey t
+ = case t of
+ Bin _ p m l r | m < 0 -> let (result, t') = minViewUnsigned r in Just (result, bin p m l t')
+ Bin _ p m l r -> let (result, t') = minViewUnsigned l in Just (result, bin p m t' r)
+ Tip _ k y -> Just ((k,y),Nil)
+ Nil -> Nothing
+
+-- minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)
+minViewUnsigned t
+ = case t of
+ Bin _ p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)
+ Tip _ k y -> ((k,y),Nil)
+ Nil -> error "minViewUnsigned Nil"
+
+updateMinWithKey :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix
+updateMinWithKey s f t
+ = case t of
+ Bin _ p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned s f r in bin p m l t'
+ Bin _ p m l r -> let t' = updateMinWithKeyUnsigned s f l in bin p m t' r
+ Tip _ k y -> singletonMaybe s k (f k y)
+ Nil -> Nil
+
+updateMinWithKeyUnsigned :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix
+updateMinWithKeyUnsigned s f t
+ = case t of
+ Bin _ p m l r -> let t' = updateMinWithKeyUnsigned s f l in bin p m t' r
+ Tip _ k y -> singletonMaybe s k (f k y)
+ Nil -> Nil
+
+updateMaxWithKey :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix
+updateMaxWithKey s f t
+ = case t of
+ Bin _ p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned s f l in bin p m t' r
+ Bin _ p m l r -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t'
+ Tip _ k y -> singletonMaybe s k (f k y)
+ Nil -> Nil
+
+updateMaxWithKeyUnsigned :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix
+updateMaxWithKeyUnsigned s f t
+ = case t of
+ Bin _ p m l r -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t'
+ Tip _ k y -> singletonMaybe s k (f k y)
+ Nil -> Nil
+
+mask :: Key -> Mask -> Prefix
+mask i m
+ = maskW (natFromInt i) (natFromInt m)
+
+zero :: Key -> Mask -> Bool
+zero i m
+ = (natFromInt i) .&. (natFromInt m) == 0
+
+nomatch,match :: Key -> Prefix -> Mask -> Bool
+nomatch i p m
+ = (mask i m) /= p
+
+match i p m
+ = (mask i m) == p
+
+zeroN :: Nat -> Nat -> Bool
+zeroN i m = (i .&. m) == 0
+
+maskW :: Nat -> Nat -> Prefix
+maskW i m
+ = intFromNat (i .&. (complement (m-1) `xor` m))
+
+shorter :: Mask -> Mask -> Bool
+shorter m1 m2
+ = (natFromInt m1) > (natFromInt m2)
+
+branchMask :: Prefix -> Prefix -> Mask
+branchMask p1 p2
+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
+
+highestBitMask :: Nat -> Nat
+highestBitMask x0
+ = case (x0 .|. shiftRL x0 1) of
+ x1 -> case (x1 .|. shiftRL x1 2) of
+ x2 -> case (x2 .|. shiftRL x2 4) of
+ x3 -> case (x3 .|. shiftRL x3 8) of
+ x4 -> case (x4 .|. shiftRL x4 16) of
+ x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms
+ x6 -> (x6 `xor` (shiftRL x6 1))
+
+join :: Prefix -> IntMap a ix -> Prefix -> IntMap a ix -> IntMap a ix
+join p1 t1 p2 t2
+ | zero p1 m = bin p m t1 t2
+ | otherwise = bin p m t2 t1
+ where
+ m = branchMask p1 p2
+ p = mask p1 m
+
+bin :: Prefix -> Mask -> IntMap a ix -> IntMap a ix -> IntMap a ix
+bin _ _ l Nil = l
+bin _ _ Nil r = r
+bin p m l r = Bin (size l + size r) p m l r
+
+-- import Data.Monoid
+-- import Data.IntMap
+-- import qualified Data.IntMap as IMap
+-- import Data.Traversable
+--
+-- newtype IntTMap a ix = ITMap (IntMap (a ix))
+-- type instance TrieMap Int = IntTMap
+-- newtype MaybeF a ix = MF {unF :: Maybe (a ix)}
+--
+-- instance TrieKey Int IntTMap where
+-- emptyM = ITMap empty
+-- nullM (ITMap m) = IMap.null m
+-- alterM _ f k (ITMap m) = ITMap (IMap.alter f k m)
+-- lookupM k (ITMap m) = IMap.lookup k m
+-- traverseWithKeyM _ f (ITMap m) = (ITMap . IMap.fromDistinctAscList) <$>
+-- sequenceA (IMap.foldWithKey (\ k a xs -> (((,) k) <$> f k a):xs) [] m)
+-- foldWithKeyM f (ITMap m) z = IMap.foldWithKey f z m
+-- foldlWithKeyM f (ITMap m) z = foldl (\ z (k, a) -> f k z a) z (IMap.assocs m)
+-- mapEitherM _ _ f (ITMap m) = (ITMap (mapMaybe fst m'), ITMap (mapMaybe snd m')) where
+-- m' = mapWithKey f m
+-- splitLookupM _ f k (ITMap m) = ITMap `sides` case splitLookup k m of
+-- (mL, x, mR)
+-- | Nothing <- x -> (mL, Nothing, mR)
+-- | Just x <- x, (xL, x, xR) <- f x
+-- -> (mIns k mL xL, x, mIns k mR xR)
+-- where mIns k m = maybe m (\ x -> IMap.insert k x m)
+-- unionM _ f (ITMap m1) (ITMap m2) = ITMap (mapMaybe unF (unionWithKey f' m1' m2')) where
+-- f' k (MF a) (MF b) = MF (unionMaybe (f k) a b)
+-- m1' = fmap (MF . Just) m1
+-- m2' = fmap (MF . Just) m2
+-- isectM _ f (ITMap m1) (ITMap m2) = ITMap (mapMaybe unF (intersectionWithKey f' m1' m2')) where
+-- f' k (MF a) (MF b) = MF (isectMaybe (f k) a b)
+-- m1' = fmap (MF . Just) m1
+-- m2' = fmap (MF . Just) m2
+-- diffM _ f (ITMap m1) (ITMap m2) = ITMap (differenceWithKey f m1 m2)
+-- extractMinM _ (ITMap m) = fmap ITMap <$> First (minViewWithKey m)
+-- extractMaxM _ (ITMap m) = fmap ITMap <$> Last (maxViewWithKey m)
+-- alterMinM _ f (ITMap m) = ITMap $ case minViewWithKey m of
+-- Just ((k, v), m')
+-- -> maybe m' (\ v' -> updateMin (const v') m) (f k v)
+-- Nothing -> m
+-- alterMaxM _ f (ITMap m) = ITMap $ case maxViewWithKey m of
+-- Just ((k, v), m')
+-- -> maybe m' (\ v' -> updateMax (const v') m) (f k v)
+-- Nothing -> m
+-- isSubmapM (<=) (ITMap m1) (ITMap m2) = isSubmapOfBy (<=) m1 m2
+-- fromListM _ = ITMap .: fromListWithKey
+-- fromAscListM _ = ITMap .: fromAscListWithKey
+-- fromDistAscListM _ = ITMap . fromDistinctAscList \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec.hs b/Data/TrieMap/MultiRec.hs
new file mode 100644
index 0000000..e67bbfc
--- /dev/null
+++ b/Data/TrieMap/MultiRec.hs
@@ -0,0 +1,6 @@
+module Data.TrieMap.MultiRec (HTrieKey, HTrieKeyT, Family(..), HEq0(..), HOrd0(..), HOrd(..)) where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.FamMap (Family (..))
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Ord \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Class.hs b/Data/TrieMap/MultiRec/Class.hs
new file mode 100644
index 0000000..42600f8
--- /dev/null
+++ b/Data/TrieMap/MultiRec/Class.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE Rank2Types, FunctionalDependencies, FlexibleContexts, KindSignatures, TypeFamilies, MultiParamTypeClasses #-}
+
+module Data.TrieMap.MultiRec.Class where
+
+import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Ord
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Applicative
+
+import Control.Applicative
+import Data.Monoid
+import Generics.MultiRec.Eq
+
+type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> (* -> *) -> * -> *
+type family HTrieMap (phi :: * -> *) (r :: * -> *) :: (* -> *) -> * -> *
+
+class HOrd phi f => HTrieKeyT (phi :: * -> *) (f :: (* -> *) -> * -> *) m | phi f -> m, m -> phi f where
+ emptyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r a ix
+ nullT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r a ix -> Bool
+ sizeT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => HSized phi a -> m r a ix -> Int
+ lookupT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> f r ix -> m r a ix -> Maybe (a ix)
+ lookupIxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> f r ix -> m r a ix -> Maybe (Int, a ix)
+ assocAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> Int -> m r a ix -> (Int, f r ix, a ix)
+ updateAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> (Int -> f r ix -> a ix -> Maybe (a ix)) -> Int -> m r a ix -> m r a ix
+ alterT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> (Maybe (a ix) -> Maybe (a ix)) -> f r ix ->
+ m r a ix -> m r a ix
+ {-# SPECIALIZE traverseWithKeyT :: HTrieKey phi r =>
+ phi ix -> HSized phi b -> (f r ix -> a ix -> Id (b ix)) -> m r a ix -> Id (m r b ix) #-}
+ traverseWithKeyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r), Applicative t) =>
+ phi ix -> HSized phi b -> (f r ix -> a ix -> t (b ix)) -> m r a ix -> t (m r b ix)
+ foldWithKeyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> (f r ix -> a ix -> b -> b) -> m r a ix -> b -> b
+ foldlWithKeyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> (f r ix -> b -> a ix -> b) -> m r a ix -> b -> b
+ mapEitherT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix ->
+ HSized phi b -> HSized phi c -> EitherMap (f r ix) (a ix) (b ix) (c ix) -> m r a ix -> (m r b ix, m r c ix)
+ splitLookupT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> SplitMap (a ix) x -> f r ix ->
+ m r a ix -> (m r a ix, Maybe x, m r a ix)
+ unionT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> UnionFunc (f r ix) (a ix) ->
+ m r a ix -> m r a ix -> m r a ix
+ isectT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi c -> IsectFunc (f r ix) (a ix) (b ix) (c ix) -> m r a ix -> m r b ix -> m r c ix
+ diffT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> DiffFunc (f r ix) (a ix) (b ix) -> m r a ix -> m r b ix -> m r a ix
+ extractMinT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> ExtractFunc (f r ix) First (a ix) (m r a ix)
+ extractMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> ExtractFunc (f r ix) Last (a ix) (m r a ix)
+ alterMinT, alterMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> (f r ix -> a ix -> Maybe (a ix)) -> m r a ix -> m r a ix
+ isSubmapT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> LEq (a ix) (b ix) -> LEq (m r a ix) (m r b ix)
+ fromListT, fromAscListT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> (f r ix -> a ix -> a ix -> a ix) -> [(f r ix, a ix)] -> m r a ix
+ fromDistAscListT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi a -> [(f r ix, a ix)] -> m r a ix
+-- sizeT pf s m = foldWithKeyT pf (\ _ x n -> s pf x + n) m 0
+ fromListT pf s f = foldr (\ (k, a) -> alterT pf s (Just . maybe a (f k a)) k) (emptyT pf)
+ fromAscListT = fromListT
+ fromDistAscListT pf s = fromAscListT pf s (const const)
+ updateAtT pf s f i m = case assocAtT pf s i m of
+ (i', k, a) -> alterT pf s (const (f i' k a)) k m
+
+class HOrd0 phi r => HTrieKey (phi :: * -> *) (r :: * -> *) m | phi r -> m, m -> phi r where
+ emptyH :: m ~ HTrieMap phi r => phi ix -> m a ix
+ nullH :: m ~ HTrieMap phi r => phi ix -> m a ix -> Bool
+ sizeH :: (m ~ HTrieMap phi r) => HSized phi a -> m a ix -> Int
+ lookupH :: m ~ HTrieMap phi r => phi ix -> r ix -> m a ix -> Maybe (a ix)
+ alterH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (Maybe (a ix) -> Maybe (a ix)) -> r ix -> m a ix -> m a ix
+ lookupIxH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> r ix -> m a ix -> Maybe (Int, a ix)
+ assocAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Int -> m a ix -> (Int, r ix, a ix)
+ updateAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> (Int -> r ix -> a ix -> Maybe (a ix)) -> Int -> m a ix -> m a ix
+ {-# SPECIALIZE traverseWithKeyH :: phi ix -> (r ix -> a ix -> Id (b ix)) ->
+ m a ix -> Id (m b ix) #-}
+ traverseWithKeyH :: (m ~ HTrieMap phi r, Applicative f) =>
+ phi ix -> HSized phi b -> (r ix -> a ix -> f (b ix)) -> m a ix -> f (m b ix)
+ foldWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> a ix -> b -> b) -> m a ix -> b -> b
+ foldlWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> b -> a ix -> b) -> m a ix -> b -> b
+ mapEitherH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi b -> HSized phi c ->
+ EitherMap (r ix) (a ix) (b ix) (c ix) -> m a ix -> (m b ix, m c ix)
+ splitLookupH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> SplitMap (a ix) x -> r ix -> m a ix ->
+ (m a ix, Maybe x, m a ix)
+ unionH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> UnionFunc (r ix) (a ix) -> m a ix -> m a ix
+ -> m a ix
+ isectH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi c -> IsectFunc (r ix) (a ix) (b ix) (c ix) ->
+ m a ix -> m b ix -> m c ix
+ diffH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> DiffFunc (r ix) (a ix) (b ix) ->
+ m a ix -> m b ix -> m a ix
+ extractMinH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) First (a ix) (m a ix)
+ extractMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) Last (a ix) (m a ix)
+ alterMinH, alterMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a ix -> Maybe (a ix)) ->
+ m a ix -> m a ix
+ isSubmapH :: m ~ HTrieMap phi r =>
+ phi ix -> LEq (a ix) (b ix) -> LEq (m a ix) (m b ix)
+ fromListH, fromAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a ix -> a ix -> a ix) ->
+ [(r ix, a ix)] -> m a ix
+ fromDistAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> [(r ix, a ix)] -> m a ix
+-- sizeH pf s m = foldWithKeyH pf (\ _ x n -> s pf x + n) m 0
+ fromListH pf s f = foldr (\ (k, a) -> alterH pf s (Just . maybe a (f k a)) k) (emptyH pf)
+ fromAscListH = fromListH
+ fromDistAscListH pf s = fromAscListH pf s (const const)
+ updateAtH pf s f i m = case assocAtH pf s i m of
+ (i', k, a) -> alterH pf s (const (f i' k a)) k m
+
+mapWithKeyT :: (HTrieKeyT phi f (HTrieMapT phi f), HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi b -> (f r ix -> a ix -> b ix) -> HTrieMapT phi f r a ix -> HTrieMapT phi f r b ix
+mapWithKeyT pf s f m = unId (traverseWithKeyT pf s (Id .: f) m)
+
+mapWithKeyH :: (HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi b -> (r ix -> a ix -> b ix) -> HTrieMap phi r a ix -> HTrieMap phi r b ix
+mapWithKeyH pf s f m = unId (traverseWithKeyH pf s (Id .: f) m)
+
+guardNullT :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> m r a ix -> Maybe (m r a ix)
+guardNullT pf m
+ | nullT pf m = Nothing
+ | otherwise = Just m \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/ConstMap.hs b/Data/TrieMap/MultiRec/ConstMap.hs
new file mode 100644
index 0000000..3671ec2
--- /dev/null
+++ b/Data/TrieMap/MultiRec/ConstMap.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
+
+module Data.TrieMap.MultiRec.ConstMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+import Data.Maybe
+import Data.Foldable
+import Generics.MultiRec
+
+newtype KMap (phi :: * -> *) m (r :: * -> *) (a :: * -> *) ix = KMap (m a ix)
+type instance HTrieMapT phi (K k) = KMap phi (TrieMap k)
+type instance HTrieMap phi (K k r) = HTrieMapT phi (K k) r
+
+instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where
+ emptyT = emptyH
+ nullT = nullH
+ sizeT = sizeH
+ lookupT = lookupH
+ lookupIxT = lookupIxH
+ assocAtT = assocAtH
+ updateAtT = updateAtH
+ alterT = alterH
+ traverseWithKeyT = traverseWithKeyH
+ foldWithKeyT = foldWithKeyH
+ foldlWithKeyT = foldlWithKeyH
+ mapEitherT = mapEitherH
+ splitLookupT = splitLookupH
+ unionT = unionH
+ isectT = isectH
+ diffT = diffH
+ extractMinT = extractMinH
+ extractMaxT = extractMaxH
+ alterMinT = alterMinH
+ alterMaxT = alterMaxH
+ isSubmapT = isSubmapH
+ fromListT = fromListH
+ fromAscListT = fromAscListH
+ fromDistAscListT = fromDistAscListH
+
+instance TrieKey k m => HTrieKey phi (K k r) (KMap phi m r) where
+ emptyH _ = KMap emptyM
+ nullH _ (KMap m) = nullM m
+ sizeH s (KMap m) = sizeM (s) m
+ lookupH _ (K k) (KMap m) = lookupM k m
+ lookupIxH _ s (K k) (KMap m) = lookupIxM s k m
+ assocAtH _ s i (KMap m) = case assocAtM s i m of
+ (i, k, a) -> (i, K k, a)
+ updateAtH _ s f i (KMap m) = KMap (updateAtM s (\ i -> f i . K) i m)
+ alterH pf s f (K k) (KMap m) = KMap (alterM (s) f k m)
+ traverseWithKeyH pf s f (KMap m) = KMap <$> traverseWithKeyM (s) (f . K) m
+ foldWithKeyH _ f (KMap m) = foldWithKeyM (f . K) m
+ foldlWithKeyH _ f (KMap m) = foldlWithKeyM (f . K) m
+ mapEitherH pf s1 s2 f (KMap m) = (KMap *** KMap) (mapEitherM (s1) (s2) (f . K) m)
+ splitLookupH pf s f (K k) (KMap m) = KMap `sides` splitLookupM (s) f k m
+ unionH pf s f (KMap m1) (KMap m2) = KMap (unionM (s) (f . K) m1 m2)
+ isectH pf s f (KMap m1) (KMap m2) = KMap (isectM (s) (f . K) m1 m2)
+ diffH pf s f (KMap m1) (KMap m2) = KMap (diffM (s) (f . K) m1 m2)
+ extractMinH pf s (KMap m) = do
+ ((k, a), m') <- extractMinM (s) m
+ return ((K k, a), KMap m')
+ extractMaxH pf s (KMap m) = do
+ ((k, a), m') <- extractMaxM (s) m
+ return ((K k, a), KMap m')
+ alterMinH pf s f (KMap m) = KMap (alterMinM (s) (f . K) m)
+ alterMaxH pf s f (KMap m) = KMap (alterMaxM (s) (f . K) m)
+ isSubmapH _ (<=) (KMap m1) (KMap m2) = isSubmapM (<=) m1 m2
+ fromListH pf s f xs = KMap (fromListM (s) (f . K) [(k, a) | (K k, a) <- xs])
+ fromAscListH pf s f xs = KMap (fromAscListM (s) (f . K) [(k, a) | (K k, a) <- xs])
+ fromDistAscListH pf s xs = KMap (fromDistAscListM (s) [(k, a) | (K k, a) <- xs]) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Eq.hs b/Data/TrieMap/MultiRec/Eq.hs
new file mode 100644
index 0000000..bde9463
--- /dev/null
+++ b/Data/TrieMap/MultiRec/Eq.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances #-}
+
+module Data.TrieMap.MultiRec.Eq where
+
+import Generics.MultiRec
+import Generics.MultiRec.Eq
+
+class HEq0 phi r where
+ heqH :: phi ix -> r ix -> r ix -> Bool
+
+heqT :: (HEq phi f, HEq0 phi r) => phi ix -> f r ix -> f r ix -> Bool
+heqT = heq heqH
+
+instance Eq k => HEq0 phi (K k r) where
+ heqH _ (K x) (K y) = x == y
+
+instance (El phi xi, HEq0 phi r) => HEq0 phi (I xi r) where
+ heqH pf (I x) (I y) = heqH (proofOn pf) x y where
+ proofOn :: El phi xi => phi ix -> phi xi
+ proofOn _ = proof
+
+instance HEq0 phi (U r) where
+ heqH _ _ _ = True
+
+instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :*: g) r) where
+ heqH pf (x1 :*: y1) (x2 :*: y2) = heqT pf x1 x2 && heqT pf y1 y2
+
+instance (HEq phi f, HEq phi g, HEq0 phi r) => HEq0 phi ((f :+: g) r) where
+ heqH pf (L x) (L y) = heqT pf x y
+ heqH pf (R x) (R y) = heqT pf x y
+ heqH _ _ _ = False
+
+instance (HEq phi f, HEq0 phi r) => HEq0 phi ((f :>: ix) r) where
+ heqH pf (Tag x) (Tag y) = heqT pf x y
+
+instance HEq phi f => HEq0 phi (HFix f) where
+ heqH pf (HIn x) (HIn y) = heqT pf x y \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/FamMap.hs b/Data/TrieMap/MultiRec/FamMap.hs
new file mode 100644
index 0000000..3628057
--- /dev/null
+++ b/Data/TrieMap/MultiRec/FamMap.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, Rank2Types, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+
+module Data.TrieMap.MultiRec.FamMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Ord
+import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.Sized
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+
+import Data.Maybe
+import Data.Foldable
+import Data.Sequence ((|>))
+import qualified Data.Sequence as Seq
+
+import Generics.MultiRec
+
+newtype Family phi ix = F ix
+newtype FamMap (phi :: * -> *) m (a :: * -> *) ix = FamMap (m (Family phi) a ix)
+type instance HTrieMap phi (Family phi) = FamMap phi (HTrieMapT phi (PF phi))
+
+instance (Fam phi, HEq phi (PF phi), HFunctor phi (PF phi)) => HEq0 phi (Family phi) where
+ heqH pf (F x) (F y) = heqT pf (from' pf x) (from' pf y)
+
+instance (Fam phi, HOrd phi (PF phi), HFunctor phi (PF phi)) => HOrd0 phi (Family phi) where
+ compareH0 pf (F x) (F y) = hcompare pf (from' pf x) (from' pf y)
+
+instance (El phi ix, Fam phi, HEq phi (PF phi), HFunctor phi (PF phi)) => Eq (Family phi ix) where
+ x == y = heqH (prove x) x y
+
+instance (El phi ix, Fam phi, HOrd phi (PF phi), HFunctor phi (PF phi)) => Ord (Family phi ix) where
+ x `compare` y = compareH0 (prove x) x y
+
+prove :: El phi ix => Family phi ix -> phi ix
+prove _ = proof
+
+from' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> ix -> PF phi (Family phi) ix
+from' pf = hmap (const (F . unI0)) pf . from pf
+
+to' :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> PF phi (Family phi) ix -> ix
+to' pf = to pf . hmap (\ _ (F x) -> I0 x) pf
+
+push :: (Fam phi, HFunctor phi (PF phi)) => phi ix -> (Family phi ix -> a) -> PF phi (Family phi) ix -> a
+push pf f = f . F . to' pf
+
+instance (Fam phi, HFunctor phi (PF phi), HTrieKeyT phi (PF phi) m) => HTrieKey phi (Family phi) (FamMap phi m) where
+ emptyH pf = FamMap (emptyT pf)
+ nullH pf (FamMap m) = nullT pf m
+ sizeH s (FamMap m) = sizeT s m
+ lookupH pf (F k) (FamMap m) = lookupT pf (from' pf k) m
+ lookupIxH pf s (F k) (FamMap m) = lookupIxT pf s (from' pf k) m
+ assocAtH pf s i (FamMap m) = case assocAtT pf s i m of
+ (i, k, a) -> (i, F (to' pf k), a)
+ updateAtH pf s f i (FamMap m) = FamMap (updateAtT pf s (\ i -> f i . F . to' pf) i m)
+ alterH pf s f (F k) (FamMap m) = FamMap (alterT pf s f (from' pf k) m)
+ traverseWithKeyH pf s f (FamMap m) =
+ FamMap <$> traverseWithKeyT pf s (push pf f) m
+ foldWithKeyH pf f (FamMap m) = foldWithKeyT pf (push pf f) m
+ foldlWithKeyH pf f (FamMap m) = foldlWithKeyT pf (push pf f) m
+ mapEitherH pf s1 s2 f (FamMap m) = (FamMap *** FamMap) (mapEitherT pf s1 s2 (push pf f) m)
+ splitLookupH pf s f (F k) (FamMap m) = FamMap `sides` splitLookupT pf s f (from' pf k) m
+ unionH pf s f (FamMap m1) (FamMap m2) = FamMap (unionT pf s (push pf f) m1 m2)
+ isectH pf s f (FamMap m1) (FamMap m2) = FamMap (isectT pf s (push pf f) m1 m2)
+ diffH pf s f (FamMap m1) (FamMap m2) = FamMap (diffT pf s (push pf f) m1 m2)
+ extractMinH pf s (FamMap m) = do
+ ((k, a), m') <- extractMinT pf s m
+ return ((F (to' pf k), a), FamMap m')
+ extractMaxH pf s (FamMap m) = do
+ ((k, a), m') <- extractMaxT pf s m
+ return ((F (to' pf k), a), FamMap m')
+ alterMinH pf s f (FamMap m) = FamMap (alterMinT pf s (push pf f) m)
+ alterMaxH pf s f (FamMap m) = FamMap (alterMaxT pf s (push pf f) m)
+ isSubmapH pf (<=) (FamMap m1) (FamMap m2) = isSubmapT pf (<=) m1 m2
+ fromListH pf s f xs = FamMap (fromListT pf s (push pf f) [(from' pf k, a) | (F k, a) <- xs])
+ fromAscListH pf s f xs = FamMap (fromAscListT pf s (push pf f) [(from' pf k, a) | (F k, a) <- xs])
+ fromDistAscListH pf s xs = FamMap (fromDistAscListT pf s [(from' pf k, a) | (F k, a) <- xs])
+
+-- type family UniqueFam ix :: * -> *
+newtype FMap (phi :: * -> *) m xi a ix = FMap (m (I ix a) xi)
+type instance TrieMap (Family phi ix) = FMap phi (HTrieMap phi (Family phi)) ix
+
+sizeI :: Sized a -> HSized phi (I ix a)
+sizeI s (I a) = s a
+
+instance (El phi ix, Fam phi, HFunctor phi (PF phi), HTrieKey phi (Family phi) m, m ~ HTrieMap phi (Family phi),
+ HOrd phi (PF phi)) => TrieKey (Family phi ix) (FMap phi m ix) where
+ emptyM = FMap (emptyH proof)
+ nullM (FMap m) = nullH proof m
+ sizeM s (FMap m) = sizeH (sizeI s) m
+ lookupM k (FMap m) = unI <$> lookupH proof k m
+ lookupIxM s k (FMap m) = fmap unI <$> lookupIxH proof (sizeI s) k m
+ assocAtM s i (FMap m) = case assocAtH proof (sizeI s) i m of
+ (i, k, I a) -> (i, k, a)
+ updateAtM s f i (FMap m) = FMap (updateAtH proof (sizeI s) (\ i' k (I a) -> I <$> f i' k a) i m)
+ alterM s f k (FMap m) = FMap (alterH proof (sizeI s) (fmap I . f . fmap unI) k m)
+ traverseWithKeyM s f (FMap m) = FMap <$> traverseWithKeyH proof (sizeI s) (\ k (I a) -> I <$> f k a) m
+ foldWithKeyM f (FMap m) = foldWithKeyH proof (\ k (I a) -> f k a) m
+ foldlWithKeyM f (FMap m) = foldlWithKeyH proof (\ k z (I a) -> f k z a) m
+ mapEitherM s1 s2 f (FMap m) =
+ (FMap *** FMap) (mapEitherH proof (sizeI s1) (sizeI s2) (\ k (I a) -> (fmap I *** fmap I) (f k a)) m)
+ splitLookupM s f k (FMap m) = FMap `sides` splitLookupH proof (sizeI s) (sides (I <$>) . f . unI) k m
+ unionM s f (FMap m1) (FMap m2) = FMap (unionH proof (sizeI s) f' m1 m2) where
+ f' k (I x) (I y) = I <$> f k x y
+ isectM s f (FMap m1) (FMap m2) = FMap (isectH proof (sizeI s) f' m1 m2) where
+ f' k (I x) (I y) = I <$> f k x y
+ diffM s f (FMap m1) (FMap m2) = FMap (diffH proof (sizeI s) f' m1 m2) where
+ f' k (I x) (I y) = I <$> f k x y
+ extractMinM s (FMap m) = do
+ ((k, I a), m') <- extractMinH proof (sizeI s) m
+ return ((k, a), FMap m')
+ extractMaxM s (FMap m) = do
+ ((k, I a), m') <- extractMaxH proof (sizeI s) m
+ return ((k, a), FMap m')
+ alterMinM s f (FMap m) = FMap (alterMinH proof (sizeI s) (\ k (I a) -> I <$> f k a) m)
+ alterMaxM s f (FMap m) = FMap (alterMaxH proof (sizeI s) (\ k (I a) -> I <$> f k a) m)
+ isSubmapM (<=) (FMap m1) (FMap m2) = isSubmapH proof (<<=) m1 m2 where
+ I a <<= I b = a <= b
+ fromListM s f xs = FMap (fromListH proof (sizeI s) (\ k (I a) (I b) -> I (f k a b)) [(k, I a) | (k, a) <- xs])
+ fromAscListM s f xs = FMap (fromAscListH proof (sizeI s) (\ k (I a) (I b) -> I (f k a b)) [(k, I a) | (k, a) <- xs])
+ fromDistAscListM s xs = FMap (fromDistAscListH proof (sizeI s) [(k, I a) | (k, a) <- xs]) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/IMap.hs b/Data/TrieMap/MultiRec/IMap.hs
new file mode 100644
index 0000000..b8de76c
--- /dev/null
+++ b/Data/TrieMap/MultiRec/IMap.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE Rank2Types, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-}
+
+module Data.TrieMap.MultiRec.IMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+
+import Generics.MultiRec
+
+newtype IMap phi xi r a ix = IMap (HTrieMap phi r (I ix a) xi)
+type instance HTrieMapT phi (I xi) = IMap phi xi
+type instance HTrieMap phi (I xi r) = HTrieMapT phi (I xi) r
+
+combineI :: (I xi r ix -> a ix -> b ix -> Maybe (c ix)) -> r xi -> I ix a xi -> I ix b xi -> Maybe (I ix c xi)
+combineI f k (I a) (I b) = I <$> f (I k) a b
+
+mapI :: Functor f => (I xi r ix -> a ix -> f (b ix)) -> r xi -> I ix a xi -> f (I ix b xi)
+mapI f k (I a) = I <$> f (I k) a
+
+sizeI :: HSized phi r -> HSized phi (I xi r)
+sizeI s (I x) = s x
+
+instance El phi xi => HTrieKeyT phi (I xi) (IMap phi xi) where
+ emptyT _ = IMap (emptyH proof)
+ nullT _ (IMap m) = nullH proof m
+ sizeT s (IMap m) = sizeH (sizeI s) m
+ lookupT _ (I k) (IMap m) = unI <$> lookupH proof k m
+ lookupIxT _ s (I k) (IMap m) = fmap unI <$> lookupIxH proof (sizeI s) k m
+ assocAtT _ s i (IMap m) = case assocAtH proof (sizeI s) i m of
+ (i, k, I a) -> (i, I k, a)
+ updateAtT _ s f i (IMap m) = IMap (updateAtH proof (sizeI s) (\ i' k (I a) -> I <$> f i' (I k) a) i m)
+ alterT _ s f (I k) (IMap m) = IMap (alterH proof (sizeI s) f' k m) where
+ f' = fmap I . f . fmap unI
+ traverseWithKeyT _ s f (IMap m) = IMap <$> traverseWithKeyH proof (sizeI s) (mapI f) m
+ foldWithKeyT _ f (IMap m) = foldWithKeyH proof (\ k (I a) -> f (I k) a) m
+ foldlWithKeyT _ f (IMap m) = foldlWithKeyH proof (\ k z (I a) -> f (I k) z a) m
+ mapEitherT _ s1 s2 f (IMap m) = (IMap *** IMap) (mapEitherH proof (sizeI s1) (sizeI s2) f' m) where
+ f' k (I a) = (fmap I *** fmap I) (f (I k) a)
+ splitLookupT pf s f (I k) (IMap m) = IMap `sides` splitLookupH proof (sizeI s) f' k m
+ where f' = sides (I <$>) . f . unI
+ unionT pf s f (IMap m1) (IMap m2) = IMap (unionH proof (sizeI s) (combineI f) m1 m2)
+ isectT pf s f (IMap m1) (IMap m2) = IMap (isectH proof (sizeI s) (combineI f) m1 m2)
+ diffT pf s f (IMap m1) (IMap m2) = IMap (diffH proof (sizeI s) (combineI f) m1 m2)
+ extractMinT pf s (IMap m) = do
+ ((k, I a), m') <- extractMinH proof (sizeI s) m
+ return ((I k, a), IMap m')
+ extractMaxT pf s (IMap m) = do
+ ((k, I a), m') <- extractMaxH proof (sizeI s) m
+ return ((I k, a), IMap m')
+ alterMinT pf s f (IMap m) = IMap (alterMinH proof (sizeI s) (mapI f) m)
+ alterMaxT pf s f (IMap m) = IMap (alterMaxH proof (sizeI s) (mapI f) m)
+ isSubmapT pf (<=) (IMap m1) (IMap m2) = isSubmapH proof (<<=) m1 m2 where
+ I a <<= I b = a <= b
+ fromListT _ s f xs = IMap (fromListH proof (sizeI s) (\ k (I a) (I b) -> I (f (I k) a b)) [(k, I a) | (I k, a) <- xs])
+ fromAscListT _ s f xs = IMap (fromAscListH proof (sizeI s) (\ k (I a) (I b) -> I (f (I k) a b)) [(k, I a) | (I k, a) <- xs])
+ fromDistAscListT _ s xs = IMap (fromDistAscListH proof (sizeI s) [(k, I a) | (I k, a) <- xs])
+
+instance (El phi xi, HTrieKey phi r (HTrieMap phi r)) => HTrieKey phi (I xi r) (IMap phi xi r) where
+ emptyH = emptyT
+ nullH = nullT
+ sizeH = sizeT
+ lookupH = lookupT
+ lookupIxH = lookupIxT
+ assocAtH = assocAtT
+ updateAtH = updateAtT
+ alterH = alterT
+ traverseWithKeyH = traverseWithKeyT
+ foldWithKeyH = foldWithKeyT
+ foldlWithKeyH = foldlWithKeyT
+ mapEitherH = mapEitherT
+ splitLookupH = splitLookupT
+ unionH = unionT
+ isectH = isectT
+ diffH = diffT
+ alterMinH = alterMinT
+ alterMaxH = alterMaxT
+ extractMinH = extractMinT
+ extractMaxH = extractMaxT
+ isSubmapH = isSubmapT
+ fromListH = fromListT
+ fromAscListH = fromAscListT
+ fromDistAscListH = fromDistAscListT \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Instances.hs b/Data/TrieMap/MultiRec/Instances.hs
new file mode 100644
index 0000000..91f46c6
--- /dev/null
+++ b/Data/TrieMap/MultiRec/Instances.hs
@@ -0,0 +1,9 @@
+module Data.TrieMap.MultiRec.Instances where
+
+import Data.TrieMap.MultiRec.ProdMap
+import Data.TrieMap.MultiRec.IMap
+import Data.TrieMap.MultiRec.UnionMap
+import Data.TrieMap.MultiRec.TagMap
+import Data.TrieMap.MultiRec.ConstMap
+import Data.TrieMap.MultiRec.UnitMap
+import Data.TrieMap.MultiRec.FamMap \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Ord.hs b/Data/TrieMap/MultiRec/Ord.hs
new file mode 100644
index 0000000..bf18ff8
--- /dev/null
+++ b/Data/TrieMap/MultiRec/Ord.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE FlexibleInstances, TypeOperators, MultiParamTypeClasses, Rank2Types #-}
+
+module Data.TrieMap.MultiRec.Ord where
+
+import Data.TrieMap.MultiRec.Eq
+
+import Generics.MultiRec
+
+import Data.Monoid
+
+type Comparator a = a -> a -> Ordering
+
+class HEq phi f => HOrd phi f where
+ compareH :: (forall ix . phi ix -> Comparator (r ix)) -> phi ix -> Comparator (f r ix)
+
+hcompare :: (HOrd phi f, HOrd0 phi r) => phi ix -> Comparator (f r ix)
+hcompare = compareH compareH0
+
+class HEq0 phi r => HOrd0 phi r where
+ compareH0 :: phi ix -> Comparator (r ix)
+
+instance Ord k => HOrd phi (K k) where
+ compareH _ = compareH0
+
+instance Ord k => HOrd0 phi (K k r) where
+ compareH0 _ (K a) (K b) = compare a b
+
+instance El phi xi => HOrd phi (I xi) where
+ compareH cmp _ (I a) (I b) = cmp proof a b
+
+instance (El phi xi, HOrd0 phi r) => HOrd0 phi (I xi r) where
+ compareH0 = hcompare
+
+instance HOrd phi U where
+ compareH _ = compareH0
+
+instance HOrd0 phi (U r) where
+ compareH0 _ _ _ = EQ
+
+instance (HOrd phi f, HOrd phi g) => HOrd phi (f :*: g) where
+ compareH cmp pf (x1 :*: y1) (x2 :*: y2) = compareH cmp pf x1 x2 `mappend` compareH cmp pf y1 y2
+
+instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :*: g) r) where
+ compareH0 = hcompare
+
+instance (HOrd phi f, HOrd phi g) => HOrd phi (f :+: g) where
+ compareH cmp pf x y = case (x, y) of
+ (L x, L y) -> compareH cmp pf x y
+ (R x, R y) -> compareH cmp pf x y
+ (L _, R _) -> LT
+ (R _, L _) -> GT
+
+instance (HOrd phi f, HOrd phi g, HOrd0 phi r) => HOrd0 phi ((f :+: g) r) where
+ compareH0 = hcompare
+
+instance HOrd phi f => HOrd phi (f :>: ix) where
+ compareH cmp pf (Tag a) (Tag b) = compareH cmp pf a b
+
+instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi ((f :>: ix) r) where
+ compareH0 pf (Tag a) (Tag b) = hcompare pf a b
+
+instance HOrd phi f => HOrd0 phi (HFix f) where
+ compareH0 pf (HIn a) (HIn b) = hcompare pf a b \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/ProdMap.hs b/Data/TrieMap/MultiRec/ProdMap.hs
new file mode 100644
index 0000000..b416db4
--- /dev/null
+++ b/Data/TrieMap/MultiRec/ProdMap.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}
+
+module Data.TrieMap.MultiRec.ProdMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+
+import Data.Maybe
+import Data.Foldable
+import Data.Sequence ((|>))
+import qualified Data.Sequence as Seq
+
+import Generics.MultiRec
+
+newtype ProdMap (phi :: * -> *) m1 (m2 :: (* -> *) -> (* -> *) -> * -> *) (r :: * -> *) (a :: * -> *) ix = PMap (m1 r (m2 r a) ix)
+type instance HTrieMapT phi (f :*: g) = ProdMap phi (HTrieMapT phi f) (HTrieMapT phi g)
+type instance HTrieMap phi ((f :*: g) r) = HTrieMapT phi (f :*: g) r
+
+-- instance (HTrieKey phi (f r), HTrieKey phi (g r)) => HTrieKey phi ((f :*: g) r) where
+-- emptyH pf ~(a :*: b) = PMap (emptyH pf a)
+-- nullH pf ~(a :*: b) (PMap m) = nullH pf a m
+-- lookupH pf (a :*: b) (PMap m) = lookupH pf a m >>= lookupH pf b
+-- alterH pf f (a :*: b) (PMap m) = PMap (alterH pf (guardNull . g) a m) where
+-- g = alterH pf f b . fromMaybe (emptyH pf b)
+-- guardNull m
+-- | nullH pf b m = Nothing
+-- | otherwise = Just m
+-- traverseWithKeyH pf f (PMap m) =
+-- PMap <$> traverseWithKeyH pf (\ a -> traverseWithKeyH pf (\ b -> f (a :*: b))) m
+-- foldWithKeyH pf f (PMap m) =
+-- foldWithKeyH pf (\ a -> foldWithKeyH pf (\ b -> f (a :*: b))) m
+
+instance (HTrieKeyT phi f m1, m1 ~ HTrieMapT phi f, HTrieKeyT phi g m2, m2 ~ HTrieMapT phi g) =>
+ HTrieKeyT phi (f :*: g) (ProdMap phi m1 m2) where
+ emptyT = PMap . emptyT
+ nullT pf (PMap m) = nullT pf m
+ sizeT s (PMap m) = sizeT (sizeT s) m
+ lookupT pf (a :*: b) (PMap m) = lookupT pf a m >>= lookupT pf b
+ lookupIxT pf s (a :*: b) (PMap m) = do
+ (iA, m') <- lookupIxT pf (sizeT s) a m
+ (iB, v) <- lookupIxT pf s b m'
+ return (iA + iB, v)
+ assocAtT pf s i (PMap m) = case assocAtT pf (sizeT s) i m of
+ (iA, a, m') -> case assocAtT pf s (i - iA) m' of
+ (iB, b, v) -> (iA + iB, a :*: b, v)
+ updateAtT pf s f i (PMap m) = PMap (updateAtT pf (sizeT s) g i m) where
+ g iA a = guardNullT pf . updateAtT pf s (\ iB b -> f (iA + iB) (a :*: b)) (i - iA)
+ alterT pf s f (a :*: b) (PMap m) = PMap (alterT pf (sizeT s) (guardNullT pf . g) a m) where
+ g = alterT pf s f b . fromMaybe (emptyT pf)
+ traverseWithKeyT pf s f (PMap m) =
+ PMap <$> traverseWithKeyT pf (sizeT s) (\ a -> traverseWithKeyT pf s (\ b -> f (a :*: b))) m
+ foldWithKeyT pf f (PMap m) =
+ foldWithKeyT pf (\ a -> foldWithKeyT pf (\ b -> f (a :*: b))) m
+ foldlWithKeyT pf f (PMap m) =
+ foldlWithKeyT pf (\ a -> flip (foldlWithKeyT pf (\ b -> f (a :*: b)))) m
+ mapEitherT pf s1 s2 f (PMap m) = (PMap *** PMap) (mapEitherT pf (sizeT s1) (sizeT s2) g m) where
+ g a = (guardNullT pf *** guardNullT pf) . mapEitherT pf s1 s2 (\ b -> f (a :*: b))
+ splitLookupT pf s f (a :*: b) (PMap m) = PMap `sides` splitLookupT pf (sizeT s) g a m where
+ g = sides (guardNullT pf) . splitLookupT pf s f b
+ unionT pf s f (PMap m1) (PMap m2) = PMap (unionT pf (sizeT s) g m1 m2) where
+ g a = guardNullT pf .: unionT pf s (\ b -> f (a :*: b))
+ isectT pf s f (PMap m1) (PMap m2) = PMap (isectT pf (sizeT s) g m1 m2) where
+ g a = guardNullT pf .: isectT pf s (\ b -> f (a :*: b))
+ diffT pf s f (PMap m1) (PMap m2) = PMap (diffT pf (sizeT s) g m1 m2) where
+ g a = guardNullT pf .: diffT pf s (\ b -> f (a :*: b))
+ extractMinT pf s (PMap m) = do
+ ((a, m1), m') <- extractMinT pf (sizeT s) m
+ ((b, v), m1') <- extractMinT pf s m1
+ return ((a :*: b, v), PMap (maybe m' (\ m1' -> alterMinT pf (sizeT s) (\ _ _ -> Just m1') m) (guardNullT pf m1')))
+ extractMaxT pf s (PMap m) = do
+ ((a, m1), m') <- extractMaxT pf (sizeT s) m
+ ((b, v), m1') <- extractMaxT pf s m1
+ return ((a :*: b, v), PMap (maybe m' (\ m1' -> alterMaxT pf (sizeT s) (\ _ _ -> Just m1') m) (guardNullT pf m1')))
+ alterMinT pf s f (PMap m) = PMap (alterMinT pf (sizeT s) g m) where
+ g a = guardNullT pf . alterMinT pf s (\ b -> f (a :*: b))
+ alterMaxT pf s f (PMap m) = PMap (alterMaxT pf (sizeT s) g m) where
+ g a = guardNullT pf . alterMaxT pf s (\ b -> f (a :*: b))
+ isSubmapT pf (<=) (PMap m1) (PMap m2) = isSubmapT pf (isSubmapT pf (<=)) m1 m2
+ fromListT pf s f xs = PMap (mapWithKeyT pf (sizeT s) (\ a -> fromListT pf s (\ b -> f (a :*: b)) . unK0)
+ (fromListT pf (const 1) (\ _ (K0 xs) (K0 ys) -> K0 (xs ++ ys))
+ [(a, K0 ts) | (a, ts) <- breakFst pf xs]))
+ fromAscListT pf s f xs = PMap (fromDistAscListT pf (sizeT s)
+ [(a, fromAscListT pf s (\ b -> f (a :*: b)) ts) | (a, ts) <- breakFst pf xs])
+ fromDistAscListT pf s xs = PMap (fromDistAscListT pf (sizeT s)
+ [(a, fromDistAscListT pf s ts) | (a, ts) <- breakFst pf xs])
+
+breakFst :: (HEq phi f, HEq0 phi r) => phi ix -> [((f :*: g) r ix, a ix)] -> [(f r ix, [(g r ix, a ix)])]
+breakFst pf [] = []
+breakFst pf ((a :*: b, x):xs) = breakFst' a (Seq.singleton (b, x)) xs where
+ breakFst' a0 ts ((a :*: b, x):xs)
+ | heqT pf a0 a = breakFst' a0 (ts |> (b, x)) xs
+ | otherwise = (a0, toList ts):breakFst' a (Seq.singleton (b,x)) xs
+ breakFst' a ts [] = [(a, toList ts)]
+
+instance (HTrieKeyT phi f m1, m1 ~ HTrieMapT phi f, HTrieKeyT phi g m2, m2 ~ HTrieMapT phi g,
+ HTrieKey phi r (HTrieMap phi r)) => HTrieKey phi ((f :*: g) r) (ProdMap phi m1 m2 r) where
+ emptyH = emptyT
+ nullH = nullT
+ sizeH = sizeT
+ lookupH = lookupT
+ lookupIxH = lookupIxT
+ assocAtH = assocAtT
+ updateAtH = updateAtT
+ alterH = alterT
+ traverseWithKeyH = traverseWithKeyT
+ foldWithKeyH = foldWithKeyT
+ foldlWithKeyH = foldlWithKeyT
+ mapEitherH = mapEitherT
+ splitLookupH = splitLookupT
+ unionH = unionT
+ isectH = isectT
+ diffH = diffT
+ alterMinH = alterMinT
+ alterMaxH = alterMaxT
+ extractMinH = extractMinT
+ extractMaxH = extractMaxT
+ isSubmapH = isSubmapT
+ fromListH = fromListT
+ fromAscListH = fromAscListT
+ fromDistAscListH = fromDistAscListT
diff --git a/Data/TrieMap/MultiRec/Sized.hs b/Data/TrieMap/MultiRec/Sized.hs
new file mode 100644
index 0000000..9850046
--- /dev/null
+++ b/Data/TrieMap/MultiRec/Sized.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE Rank2Types, KindSignatures #-}
+
+module Data.TrieMap.MultiRec.Sized where
+
+-- import Data.TrieMap.Sized
+--
+-- class HSized phi r where
+-- hGetSize :: phi ix -> r ix -> Int
+--
+-- newtype ElF phi r ix = ElF (r ix)
+--
+-- instance (HSized phi r, El phi ix) => Sized (ElF phi r) where
+-- getSize (ElF x) = hGetSize proof x
+
+type HSized (phi :: * -> *) r = forall ix . r ix -> Int
+
+newtype Elem a = Elem {getElem :: a}
+
+sizeElem :: HSized phi Elem
+sizeElem _ = 1 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/TagMap.hs b/Data/TrieMap/MultiRec/TagMap.hs
new file mode 100644
index 0000000..f206b39
--- /dev/null
+++ b/Data/TrieMap/MultiRec/TagMap.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE Rank2Types, TypeOperators, KindSignatures, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, GADTs, MultiParamTypeClasses #-}
+
+module Data.TrieMap.MultiRec.TagMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+import Data.Maybe
+import Data.Monoid
+import Data.Foldable
+import Generics.MultiRec
+
+data TagF a ix :: * -> * where
+ TagF :: a ix -> TagF a ix ix
+
+unTagF :: TagF a ix xi -> a xi
+unTagF (TagF x) = x
+
+newtype TagMap (phi :: * -> *) m ix (r :: * -> *) a xi = TagMap (m r (TagF a ix) xi)
+type instance HTrieMapT phi (f :>: ix) = TagMap phi (HTrieMapT phi f) ix
+type instance HTrieMap phi ((f :>: ix) r) = HTrieMapT phi (f :>: ix) r
+
+combineTag :: IsectFunc ((f :>: ix) r xi) (a xi) (b xi) (c xi) ->
+ IsectFunc (f r xi) (TagF a ix xi) (TagF b ix xi) (TagF c ix xi)
+combineTag f k (TagF a) (TagF b) = TagF <$> f (Tag k) a b
+
+mapTag :: Functor t => ((f :>: ix) r xi -> a xi -> t (b xi)) -> f r xi -> TagF a ix xi -> t (TagF b ix xi)
+mapTag f k (TagF a) = TagF <$> f (Tag k) a
+
+sizeTag :: HSized phi a -> HSized phi (TagF a ix)
+sizeTag s (TagF x) = s x
+
+instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f) => HTrieKeyT phi (f :>: ix) (TagMap phi m ix) where
+ emptyT = TagMap . emptyT
+ nullT pf (TagMap m) = nullT pf m
+ sizeT s (TagMap m) = sizeT (sizeTag s) m
+ lookupT pf (Tag k) (TagMap m) = unTagF <$> lookupT pf k m
+ lookupIxT pf s (Tag k) (TagMap m) = fmap unTagF <$> lookupIxT pf (sizeTag s) k m
+ assocAtT pf s i (TagMap m) = unTagger (assocAtT pf (sizeTag s) i m)
+ where unTagger :: (Int, f r ix, TagF a xi ix) -> (Int, (f :>: xi) r ix, a ix)
+ unTagger (i', k, TagF a) = (i', Tag k, a)
+ updateAtT pf s f i (TagMap m) = TagMap (updateAtT pf (sizeTag s) (f' f) i m) where
+ f' :: (Int -> (f :>: xi) r ix -> a ix -> Maybe (a ix)) -> Int -> f r ix -> TagF a xi ix -> Maybe (TagF a xi ix)
+ f' f i k (TagF a) = TagF <$> f i (Tag k) a
+ alterT pf s f (Tag k) (TagMap m) = TagMap (alterT pf (sizeTag s) (fmap TagF . f . fmap unTagF) k m)
+ traverseWithKeyT pf s f (TagMap m) = TagMap <$> traverseWithKeyT pf (sizeTag s) (mapTag f) m where
+ f' :: Applicative t => ((f :>: ix) r xi -> a xi -> t (b xi)) -> f r xi -> TagF a ix xi -> t (TagF b ix xi)
+ f' f k (TagF a) = TagF <$> f (Tag k) a
+ foldWithKeyT pf f (TagMap m) = foldWithKeyT pf (f' f) m where
+ f' :: ((f :>: ix) r xi -> a xi -> b -> b) -> f r xi -> TagF a ix xi -> b -> b
+ f' f k (TagF a) = f (Tag k) a
+ foldlWithKeyT pf f (TagMap m) = foldlWithKeyT pf (f' f) m where
+ f' :: ((f :>: ix) r xi -> b -> a xi -> b) -> f r xi -> b -> TagF a ix xi -> b
+ f' f k z (TagF a) = f (Tag k) z a
+ mapEitherT pf s1 s2 f (TagMap m) = (TagMap *** TagMap) (mapEitherT pf (sizeTag s1) (sizeTag s2) (f' f) m) where
+ f' :: EitherMap ((f :>: ix) r xi) (a xi) (b xi) (c xi) -> EitherMap (f r xi) (TagF a ix xi) (TagF b ix xi) (TagF c ix xi)
+ f' f k (TagF a) = (fmap TagF *** fmap TagF) (f (Tag k) a)
+ splitLookupT pf s f (Tag k) (TagMap m) = TagMap `sides` splitLookupT pf (sizeTag s) (f' f) k m where
+ f' :: SplitMap (a ix) x -> SplitMap (TagF a xi ix) x
+ f' f (TagF a) = fmap TagF `sides` f a
+ unionT pf s f (TagMap m1) (TagMap m2) = TagMap (unionT pf (sizeTag s) (combineTag f) m1 m2)
+ isectT pf s f (TagMap m1) (TagMap m2) = TagMap (isectT pf (sizeTag s) (combineTag f) m1 m2)
+ diffT pf s f (TagMap m1) (TagMap m2) = TagMap (diffT pf (sizeTag s) (combineTag f) m1 m2)
+ extractMinT pf s (TagMap m) = do
+ ((k, TagF a), m') <- extractMin' pf ((sizeTag :: HSized phi a -> HSized phi (TagF a ix)) s) m
+ return ((Tag k, a), TagMap m')
+ where extractMin' :: (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi (TagF a xi) -> m r (TagF a xi) ix ->
+ First ((f r ix, TagF a xi ix), m r (TagF a xi) ix)
+ extractMin' = extractMinT
+ extractMaxT pf s (TagMap m) = do
+ ((k, TagF a), m') <- extractMax' pf ((sizeTag :: HSized phi a -> HSized phi (TagF a ix)) s) m
+ return ((Tag k, a), TagMap m')
+ where extractMax' :: (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ phi ix -> HSized phi (TagF a xi) -> m r (TagF a xi) ix ->
+ Last ((f r ix, TagF a xi ix), m r (TagF a xi) ix)
+ extractMax' = extractMaxT
+ alterMinT pf s f (TagMap m) = TagMap (alterMinT pf (sizeTag s) (mapTag f) m)
+ alterMaxT pf s f (TagMap m) = TagMap (alterMaxT pf (sizeTag s) (mapTag f) m)
+ isSubmapT pf (<=) (TagMap m1) (TagMap m2) = isSubmapT pf (le (<=)) m1 m2 where
+ le :: LEq (a ix) (b ix) -> LEq (TagF a xi ix) (TagF b xi ix)
+ le (<=) (TagF a) (TagF b) = a <= b
+ fromListT pf s f xs = TagMap (fromListT pf (sizeTag s) (f' f) [(k, TagF a) | (Tag k, a) <- xs]) where
+ f' :: ((f :>: ix) r xi -> a xi -> a xi -> a xi) -> f r xi -> TagF a ix xi -> TagF a ix xi -> TagF a ix xi
+ f' f k (TagF a) (TagF b) = TagF (f (Tag k) a b)
+ fromAscListT pf s f xs = TagMap (fromAscListT pf (sizeTag s) (f' f) [(k, TagF a) | (Tag k, a) <- xs]) where
+ f' :: ((f :>: ix) r xi -> a xi -> a xi -> a xi) -> f r xi -> TagF a ix xi -> TagF a ix xi -> TagF a ix xi
+ f' f k (TagF a) (TagF b) = TagF (f (Tag k) a b)
+ fromDistAscListT pf s xs = TagMap (fromDistAscListT pf (sizeTag s) (map f xs)) where
+ f :: ((f :>: ix) r xi, a xi) -> (f r xi, TagF a ix xi)
+ f (Tag k, a) = (k, TagF a)
+
+instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+ HTrieKey phi ((f :>: ix) r) (TagMap phi m ix r) where
+ emptyH = emptyT
+ nullH = nullT
+ sizeH = sizeT
+ lookupH = lookupT
+ lookupIxH = lookupIxT
+ assocAtH = assocAtT
+ updateAtH = updateAtT
+ alterH = alterT
+ traverseWithKeyH = traverseWithKeyT
+ foldWithKeyH = foldWithKeyT
+ foldlWithKeyH = foldlWithKeyT
+ mapEitherH = mapEitherT
+ splitLookupH = splitLookupT
+ unionH = unionT
+ isectH = isectT
+ diffH = diffT
+ alterMinH = alterMinT
+ alterMaxH = alterMaxT
+ extractMinH = extractMinT
+ extractMaxH = extractMaxT
+ isSubmapH = isSubmapT
+ fromListH = fromListT
+ fromAscListH = fromAscListT
+ fromDistAscListH = fromDistAscListT \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/UnionMap.hs b/Data/TrieMap/MultiRec/UnionMap.hs
new file mode 100644
index 0000000..e976db3
--- /dev/null
+++ b/Data/TrieMap/MultiRec/UnionMap.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, MultiParamTypeClasses, TypeOperators #-}
+
+module Data.TrieMap.MultiRec.UnionMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+import Data.Maybe
+import Data.Foldable
+import Generics.MultiRec
+
+import Prelude hiding (foldr)
+
+data UnionMap (phi :: * -> *) m1 m2 (r :: * -> *) (a :: * -> *) ix = m1 r a ix :&: m2 r a ix
+type instance HTrieMapT phi (f :+: g) = UnionMap phi (HTrieMapT phi f) (HTrieMapT phi g)--HTrieMap phi (f r) :*: HTrieMap phi (g r)
+type instance HTrieMap phi ((f :+: g) r) = HTrieMapT phi (f :+: g) r
+
+instance (HTrieKeyT phi f m1, HTrieKeyT phi g m2) => HTrieKeyT phi (f :+: g) (UnionMap phi m1 m2) where
+ emptyT = liftM2 (:&:) emptyT emptyT
+ nullT pf (m1 :&: m2) = nullT pf m1 && nullT pf m2
+ sizeT s (m1 :&: m2) = sizeT s m1 + sizeT s m2
+ lookupT pf k (m1 :&: m2)
+ | L k <- k = lookupT pf k m1
+ | R k <- k = lookupT pf k m2
+ lookupIxT pf s k (m1 :&: m2)
+ | L k <- k = lookupIxT pf s k m1
+ | R k <- k = first (sizeT s m1 +) <$> lookupIxT pf s k m2
+ assocAtT pf s i (m1 :&: m2)
+ | i < s1, (i', k, a) <- assocAtT pf s i m1
+ = (i', L k, a)
+ | (i', k, a) <- assocAtT pf s (i - s1) m2
+ = (i' + s1, R k, a)
+ where s1 = sizeT s m1
+ updateAtT pf s f i (m1 :&: m2)
+ | i < s1 = updateAtT pf s (\ i' -> f i' . L) i m1 :&: m2
+ | otherwise = m1 :&: updateAtT pf s (\ i' -> f (s1 + i') . R) (i - s1) m2
+ where s1 = sizeT s m1
+ alterT pf s f k (m1 :&: m2)
+ | L k <- k = alterT pf s f k m1 :&: m2
+ | R k <- k = m1 :&: alterT pf s f k m2
+ traverseWithKeyT pf s f (m1 :&: m2)
+ = (:&:) <$> traverseWithKeyT pf s (f . L) m1 <*> traverseWithKeyT pf s (f . R) m2
+ foldWithKeyT pf f (m1 :&: m2)
+ = foldWithKeyT pf (f . L) m1 . foldWithKeyT pf (f . R) m2
+ foldlWithKeyT pf f (m1 :&: m2)
+ = foldlWithKeyT pf (f . R) m2 . foldlWithKeyT pf (f . L) m1
+ mapEitherT pf s1 s2 f (m1 :&: m2) = case (mapEitherT pf s1 s2 (f . L) m1, mapEitherT pf s1 s2 (f . R) m2) of
+ ((m1L, m1R), (m2L, m2R)) -> (m1L :&: m2L, m1R :&: m2R)
+ splitLookupT pf s f k0 (m1 :&: m2)
+ | L k <- k0, (m1L, x, m1R) <- splitLookupT pf s f k m1
+ = (m1L :&: emptyT pf, x, m1R :&: m2)
+ | R k <- k0, (m2L, x, m2R) <- splitLookupT pf s f k m2
+ = (m1 :&: m2L, x, emptyT pf :&: m2R)
+ unionT pf s f (m11 :&: m12) (m21 :&: m22)
+ = unionT pf s (f . L) m11 m21 :&: unionT pf s (f . R) m12 m22
+ isectT pf s f (m11 :&: m12) (m21 :&: m22)
+ = isectT pf s (f . L) m11 m21 :&: isectT pf s (f . R) m12 m22
+ diffT pf s f (m11 :&: m12) (m21 :&: m22)
+ = diffT pf s (f . L) m11 m21 :&: diffT pf s (f . R) m12 m22
+ extractMinT pf s (m1 :&: m2) = (do
+ ((k, v), m1') <- extractMinT pf s m1
+ return ((L k, v), m1' :&: m2)) `mplus`
+ (do ((k, v), m2') <- extractMinT pf s m2
+ return ((R k, v), m1 :&: m2'))
+ extractMaxT pf s (m1 :&: m2) = (do
+ ((k, v), m1') <- extractMaxT pf s m1
+ return ((L k, v), m1' :&: m2)) `mplus`
+ (do ((k, v), m2') <- extractMaxT pf s m2
+ return ((R k, v), m1 :&: m2'))
+ alterMinT pf s f (m1 :&: m2)
+ | nullT pf m1 = m1 :&: alterMinT pf s (f . R) m2
+ | otherwise = alterMinT pf s (f . L) m1 :&: m2
+ alterMaxT pf s f (m1 :&: m2)
+ | nullT pf m2 = alterMaxT pf s (f . L) m1 :&: m2
+ | otherwise = m1 :&: alterMaxT pf s (f . R) m2
+ isSubmapT pf (<=) (m11 :&: m12) (m21 :&: m22)
+ = isSubmapT pf (<=) m11 m21 && isSubmapT pf (<=) m12 m22
+ fromListT pf s f xs = case breakEither xs of
+ (ys, zs) -> fromListT pf s (f . L) ys :&: fromListT pf s (f . R) zs
+ fromAscListT pf s f xs = case breakEither xs of
+ (ys, zs) -> fromAscListT pf s (f . L) ys :&: fromAscListT pf s (f . R) zs
+ fromDistAscListT pf s xs = case breakEither xs of
+ (ys, zs) -> fromDistAscListT pf s ys :&: fromDistAscListT pf s zs
+
+breakEither :: [((f :+: g) r ix, a)] -> ([(f r ix, a)], [(g r ix, a)])
+breakEither = foldr breakEither' ([], []) where
+ breakEither' (L k, a) (xs, ys) = ((k, a):xs, ys)
+ breakEither' (R k, a) (xs, ys) = (xs, (k, a):ys)
+
+instance (HTrieKeyT phi f m1, m1 ~ HTrieMapT phi f, HTrieKeyT phi g m2, m2 ~ HTrieMapT phi g,
+ HTrieKey phi r (HTrieMap phi r)) => HTrieKey phi ((f :+: g) r) (UnionMap phi m1 m2 r) where
+ emptyH = emptyT
+ nullH = nullT
+ sizeH = sizeT
+ lookupH = lookupT
+ lookupIxH = lookupIxT
+ assocAtH = assocAtT
+ updateAtH = updateAtT
+ alterH = alterT
+ traverseWithKeyH = traverseWithKeyT
+ foldWithKeyH = foldWithKeyT
+ foldlWithKeyH = foldlWithKeyT
+ mapEitherH = mapEitherT
+ splitLookupH = splitLookupT
+ unionH = unionT
+ isectH = isectT
+ diffH = diffT
+ alterMinH = alterMinT
+ alterMaxH = alterMaxT
+ extractMinH = extractMinT
+ extractMaxH = extractMaxT
+ isSubmapH = isSubmapT
+ fromListH = fromListT
+ fromAscListH = fromAscListT
+ fromDistAscListH = fromDistAscListT \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/UnitMap.hs b/Data/TrieMap/MultiRec/UnitMap.hs
new file mode 100644
index 0000000..e4caa41
--- /dev/null
+++ b/Data/TrieMap/MultiRec/UnitMap.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}
+
+module Data.TrieMap.MultiRec.UnitMap where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+import Data.Maybe
+import Data.Monoid
+import Data.Foldable
+import Data.Traversable
+import Generics.MultiRec
+
+import Prelude hiding (foldr, foldl)
+
+newtype UMap (phi :: * -> *) (r :: * -> *) a ix = UMap (Maybe (a ix))
+type instance HTrieMapT phi U = UMap phi
+type instance HTrieMap phi (U r) = UMap phi r
+
+instance HTrieKeyT phi U (UMap phi) where
+ emptyT = emptyH
+ nullT = nullH
+ sizeT = sizeH
+ lookupT = lookupH
+ lookupIxT = lookupIxH
+ assocAtT = assocAtH
+ updateAtT = updateAtH
+ alterT = alterH
+ traverseWithKeyT = traverseWithKeyH
+ foldWithKeyT = foldWithKeyH
+ foldlWithKeyT = foldlWithKeyH
+ mapEitherT = mapEitherH
+ splitLookupT = splitLookupH
+ unionT = unionH
+ isectT = isectH
+ diffT = diffH
+ extractMinT = extractMinH
+ extractMaxT = extractMaxH
+ alterMinT = alterMinH
+ alterMaxT = alterMaxH
+ isSubmapT = isSubmapH
+ fromListT = fromListH
+ fromAscListT = fromAscListH
+ fromDistAscListT = fromDistAscListH
+
+instance HTrieKey phi (U r) (UMap phi r) where
+ emptyH _ = UMap Nothing
+ nullH _ (UMap m) = isNothing m
+ sizeH s (UMap m) = maybe 0 s m
+ lookupH _ _ (UMap m) = m
+ lookupIxH _ _ _ (UMap m) = fmap ((,) 0) m
+ assocAtH _ _ _ (UMap (Just a)) = (0, U, a)
+ updateAtH _ _ f _ (UMap m) = UMap (m >>= f 0 U)
+ alterH _ _ f _ (UMap m) = UMap (f m)
+ traverseWithKeyH _ _ f (UMap m) = UMap <$> traverse (f U) m
+ foldWithKeyH _ f (UMap m) z = foldr (f U) z m
+ foldlWithKeyH _ f (UMap m) z = foldl (f U) z m
+ mapEitherH _ _ _ f (UMap m) = (UMap *** UMap) (maybe (Nothing, Nothing) (f U) m)
+ splitLookupH _ _ f _ (UMap m) = UMap `sides` maybe (Nothing, Nothing, Nothing) f m
+ unionH _ _ f (UMap m1) (UMap m2) = UMap (unionMaybe (f U) m1 m2)
+ isectH _ _ f (UMap m1) (UMap m2) = UMap (isectMaybe (f U) m1 m2)
+ diffH _ _ f (UMap m1) (UMap m2) = UMap (diffMaybe (f U) m1 m2)
+ extractMinH _ _ (UMap m) = do v <- First m
+ return ((U, v), UMap Nothing)
+ extractMaxH _ _ (UMap m) = do v <- Last m
+ return ((U, v), UMap Nothing)
+ alterMinH _ _ f (UMap m) = UMap (m >>= f U)
+ alterMaxH = alterMinH
+ isSubmapH _ _ (UMap Nothing) _ = True
+ isSubmapH _ (<=) (UMap m1) (UMap m2) = subMaybe (<=) m1 m2
+ fromListH _ _ f xs = UMap (foldr (\ (_, a) -> Just . maybe a (f U a)) Nothing xs)
+ fromAscListH = fromListH
+ fromDistAscListH _ _ xs = UMap (fmap snd (listToMaybe xs)) \ No newline at end of file
diff --git a/Data/TrieMap/OrdMap.hs b/Data/TrieMap/OrdMap.hs
new file mode 100644
index 0000000..1c884b6
--- /dev/null
+++ b/Data/TrieMap/OrdMap.hs
@@ -0,0 +1,393 @@
+{-# LANGUAGE Rank2Types, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}
+
+module Data.TrieMap.OrdMap (Ordered (..)) where
+
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Sized
+import Data.TrieMap.Applicative
+
+import Control.Applicative (Applicative(..), (<$>))
+import Control.Arrow
+import Control.Monad hiding (join)
+
+import Data.Monoid
+import Data.Maybe
+-- import Data.Map
+-- import qualified Data.Map as Map
+import Data.Traversable
+
+import Prelude hiding (lookup)
+
+newtype Ordered a = Ord {unOrd :: a} deriving (Eq, Ord)
+data OrdMap k a ix = Tip
+ | Bin {-# UNPACK #-} !Int k (a ix) !(OrdMap k a ix) !(OrdMap k a ix)
+
+type instance TrieMap (Ordered k) = OrdMap k
+
+instance Ord k => TrieKey (Ordered k) (OrdMap k) where
+ emptyM = Tip
+ nullM Tip = True
+ nullM _ = False
+ sizeM _ = size
+ lookupM (Ord k) = lookup k
+ lookupIxM _ (Ord k) = lookupIx 0 k
+ assocAtM _ i m = fromJust (do (i', k, a) <- assocAt 0 i m
+ return (i', Ord k, a))
+ updateAtM s f = updateAt s (\ i -> f i . Ord)
+ alterM s f (Ord k) = alter s f k
+ traverseWithKeyM s f = traverseWithKey s (f . Ord)
+ foldWithKeyM f = foldrWithKey (f . Ord)
+ foldlWithKeyM f = foldlWithKey (f . Ord)
+ mapEitherM s1 s2 f = mapEither s1 s2 (f . Ord)
+ extractMinM s Tip = mzero
+ extractMinM s m = return (first (first Ord) $ deleteFindMin s m)
+ extractMaxM s Tip = mzero
+ extractMaxM s m = return (first (first Ord) $ deleteFindMax s m)
+ alterMinM s f = updateMin s (f . Ord)
+ alterMaxM s f = updateMax s (f . Ord)
+ splitLookupM s f (Ord k) = splitLookup s f k
+ isSubmapM = isSubmap
+ fromAscListM s f xs = fromAscList s (f . Ord) [(k, a) | (Ord k, a) <- xs]
+ fromDistAscListM s xs = fromDistinctAscList s [(k, a) | (Ord k, a) <- xs]
+ unionM s f m1 m2 = case (m1, m2) of
+ (Tip, _) -> m2
+ (_, Tip) -> m1
+ _ -> hedgeUnionWithKey s (f . Ord) (const LT) (const GT) m1 m2
+ isectM s f = isect s (f . Ord)
+ diffM s f m1 m2 = case (m1, m2) of
+ (Tip, _) -> Tip
+ (_, Tip) -> m1
+ _ -> hedgeDiffWithKey s (f . Ord) (const LT) (const GT) m1 m2
+
+lookup :: Ord k => k -> OrdMap k a ix -> Maybe (a ix)
+lookup k Tip = Nothing
+lookup k (Bin _ k' v l r) = case compare k k' of
+ LT -> lookup k l
+ EQ -> Just v
+ GT -> lookup k r
+
+lookupIx :: Ord k => Int -> k -> OrdMap k a ix -> Maybe (Int, a ix)
+lookupIx i _ _ | i `seq` False = undefined
+lookupIx _ _ Tip = Nothing
+lookupIx i k (Bin sz k' v l r) = case compare k k' of
+ LT -> lookupIx i k l
+ EQ -> Just (size l, v)
+ GT -> lookupIx (i + sz - size r) k r
+
+assocAt :: Int -> Int -> OrdMap k a ix -> Maybe (Int, k, a ix)
+assocAt i0 i _ | i0 `seq` i `seq` False = Nothing
+assocAt _ _ Tip = Nothing
+assocAt i0 i (Bin sz k a l r)
+ | i < sL = assocAt i0 i l
+ | i < sK = Just (i0 + sL, k, a)
+ | otherwise = assocAt (i0 + sK) (i - sK) r
+ where sL = size l
+ sK = sz - size r
+
+updateAt :: Sized a -> (Int -> k -> a ix -> Maybe (a ix)) -> Int -> OrdMap k a ix -> OrdMap k a ix
+updateAt _ _ i _ | i `seq` False = undefined
+updateAt _ _ _ Tip = Tip
+updateAt s f i (Bin sz k a l r)
+ | i < sL = balance s k a (updateAt s f i l) r
+ | i < sK = case f sK k a of
+ Nothing -> glue s l r
+ Just a' -> bin s k a' l r
+ | otherwise = balance s k a l (updateAt s (f . (+ sK)) (i - sK) r)
+ where sL = size l
+ sK = sz - size r
+
+alter :: Ord k => Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> k -> OrdMap k a ix -> OrdMap k a ix
+alter s f k Tip = case f Nothing of
+ Nothing -> Tip
+ Just x -> singleton s k x
+alter s f k (Bin _ kx x l r) = case compare k kx of
+ LT -> balance s kx x (alter s f k l) r
+ EQ -> case f (Just x) of
+ Nothing -> glue s l r
+ Just x' -> balance s k x' l r
+ GT -> balance s kx x l (alter s f k r)
+
+singleton :: Sized a -> k -> a ix -> OrdMap k a ix
+singleton s k a = Bin (s a) k a Tip Tip
+
+traverseWithKey :: Applicative f => Sized b -> (k -> a ix -> f (b ix)) -> OrdMap k a ix -> f (OrdMap k b ix)
+traverseWithKey s f Tip = pure Tip
+traverseWithKey s f (Bin _ k a l r) = balance s k <$> f k a <*> traverseWithKey s f l <*> traverseWithKey s f r
+
+foldrWithKey :: (k -> a ix -> b -> b) -> OrdMap k a ix -> b -> b
+foldrWithKey f Tip = id
+foldrWithKey f (Bin _ k a l r) = foldrWithKey f l . f k a . foldrWithKey f r
+
+foldlWithKey :: (k -> b -> a ix -> b) -> OrdMap k a ix -> b -> b
+foldlWithKey f Tip = id
+foldlWithKey f (Bin _ k a l r) = foldlWithKey f r . flip (f k) a . foldlWithKey f l
+
+mapEither :: Ord k => Sized b -> Sized c -> EitherMap k (a ix) (b ix) (c ix) ->
+ OrdMap k a ix -> (OrdMap k b ix, OrdMap k c ix)
+mapEither s1 s2 f m = case m of
+ Tip -> (Tip, Tip)
+ Bin _ k a l r -> case (f k a, mapEither s1 s2 f l, mapEither s1 s2 f r) of
+ ((aL, aR), (lL, lR), (rL, rR)) ->
+ (joinMaybe s1 k aL lL rL, joinMaybe s2 k aR lR rR)
+
+updateMin :: Ord k => Sized a -> (k -> a ix -> Maybe (a ix)) -> OrdMap k a ix -> OrdMap k a ix
+updateMin s f m = case m of
+ Tip -> Tip
+ Bin _ k a Tip r -> case f k a of
+ Nothing -> r
+ Just a' -> insertMin s k a' r
+ Bin _ k a l r -> balance s k a (updateMin s f l) r
+
+updateMax :: Ord k => Sized a -> (k -> a ix -> Maybe (a ix)) -> OrdMap k a ix -> OrdMap k a ix
+updateMax s f m = case m of
+ Tip -> Tip
+ Bin _ k a l Tip -> case f k a of
+ Nothing -> l
+ Just a' -> insertMax s k a' l
+ Bin _ k a l r -> balance s k a l (updateMax s f r)
+
+splitLookup :: Ord k => Sized a -> SplitMap (a ix) x -> k -> OrdMap k a ix -> (OrdMap k a ix, Maybe x, OrdMap k a ix)
+splitLookup s f k m = case m of
+ Tip -> (Tip, Nothing, Tip)
+ Bin _ kx x l r -> case compare k kx of
+ LT -> case splitLookup s f k l of
+ (lL, ans, lR) -> (lL, ans, join s kx x lR r)
+ EQ -> case f x of
+ (xL, ans, xR) -> (maybe l (\ xL -> insertMax s kx xL l) xL, ans,
+ maybe r (\ xR -> insertMin s kx xR r) xR)
+ GT -> case splitLookup s f k r of
+ (rL, ans, rR) -> (join s kx x l rL, ans, rR)
+
+isSubmap :: Ord k => LEq (a ix) (b ix) -> LEq (OrdMap k a ix) (OrdMap k b ix)
+isSubmap (<=) Tip _ = True
+isSubmap (<=) _ Tip = False
+isSubmap (<=) (Bin _ kx x l r) t = case found of
+ Nothing -> False
+ Just y -> x <= y && isSubmap (<=) l lt && isSubmap (<=) r gt
+ where (lt, found, gt) = splitLookup (const 1) (\ x -> (Nothing, Just x, Nothing)) kx t
+
+fromAscList :: Eq k => Sized a -> (k -> a ix -> a ix -> a ix) -> [(k, a ix)] -> OrdMap k a ix
+fromAscList s f xs = fromDistinctAscList s (combineEq xs) where
+ combineEq (x:xs) = combineEq' x xs
+ combineEq [] = []
+
+ combineEq' z [] = [z]
+ combineEq' z@(kz, zz) (x@(kx, xx):xs)
+ | kz == kx = combineEq' (kx, f kx xx zz) xs
+ | otherwise = (kz,zz):combineEq' x xs
+
+fromDistinctAscList :: Sized a -> [(k, a ix)] -> OrdMap k a ix
+fromDistinctAscList s xs = build const (length xs) xs
+ where
+ -- 1) use continutations so that we use heap space instead of stack space.
+ -- 2) special case for n==5 to build bushier trees.
+ build c 0 xs' = c Tip xs'
+ build c 5 xs' = case xs' of
+ ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)
+ -> c (bin s k4 x4 (bin s k2 x2 (singleton s k1 x1) (singleton s k3 x3)) (singleton s k5 x5)) xx
+ _ -> error "fromDistinctAscList build"
+ build c n xs' = seq nr $ build (buildR nr c) nl xs'
+ where
+ nl = n `div` 2
+ nr = n - nl - 1
+
+ buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
+ buildR _ _ _ [] = error "fromDistinctAscList buildR []"
+ buildB l k x c r zs = c (bin s k x l r) zs
+
+hedgeUnionWithKey :: Ord k
+ => Sized a -> (k -> a ix -> a ix -> Maybe (a ix))
+ -> (k -> Ordering) -> (k -> Ordering)
+ -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+hedgeUnionWithKey _ _ _ _ t1 Tip
+ = t1
+hedgeUnionWithKey s _ cmplo cmphi Tip (Bin _ kx x l r)
+ = join s kx x (filterGt s cmplo l) (filterLt s cmphi r)
+hedgeUnionWithKey s f cmplo cmphi (Bin _ kx x l r) t2
+ = joinMaybe s kx newx (hedgeUnionWithKey s f cmplo cmpkx l lt)
+ (hedgeUnionWithKey s f cmpkx cmphi r gt)
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t2
+ (found,gt) = trimLookupLo kx cmphi t2
+ newx = case found of
+ Nothing -> Just x
+ Just (_,y) -> f kx x y
+
+filterGt :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix
+filterGt _ _ Tip = Tip
+filterGt s cmp (Bin _ kx x l r)
+ = case cmp kx of
+ LT -> join s kx x (filterGt s cmp l) r
+ GT -> filterGt s cmp r
+ EQ -> r
+
+filterLt :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix
+filterLt _ _ Tip = Tip
+filterLt s cmp (Bin _ kx x l r)
+ = case cmp kx of
+ LT -> filterLt s cmp l
+ GT -> join s kx x l (filterLt s cmp r)
+ EQ -> l
+
+trim :: (k -> Ordering) -> (k -> Ordering) -> OrdMap k a ix -> OrdMap k a ix
+trim _ _ Tip = Tip
+trim cmplo cmphi t@(Bin _ kx _ l r)
+ = case cmplo kx of
+ LT -> case cmphi kx of
+ GT -> t
+ _ -> trim cmplo cmphi l
+ _ -> trim cmplo cmphi r
+
+trimLookupLo :: Ord k => k -> (k -> Ordering) -> OrdMap k a ix -> (Maybe (k,a ix), OrdMap k a ix)
+trimLookupLo _ _ Tip = (Nothing,Tip)
+trimLookupLo lo cmphi t@(Bin _ kx x l r)
+ = case compare lo kx of
+ LT -> case cmphi kx of
+ GT -> (((,) lo) <$> lookup lo t, t)
+ _ -> trimLookupLo lo cmphi l
+ GT -> trimLookupLo lo cmphi r
+ EQ -> (Just (kx,x),trim (compare lo) cmphi r)
+
+isect :: Ord k => Sized c -> IsectFunc k (a ix) (b ix) (c ix) -> OrdMap k a ix -> OrdMap k b ix -> OrdMap k c ix
+isect s f Tip _ = Tip
+isect s f _ Tip = Tip
+isect s f t1@(Bin _ k1 x1 l1 r1) t2@(Bin _ k2 x2 l2 r2) =
+ let (lt, found, gt) = splitLookup (const 1) (\ x -> (Nothing, Just x, Nothing)) k2 t1
+ tl = isect s f lt l2
+ tr = isect s f gt r2
+ in joinMaybe s k2 (found >>= \ x1' -> f k2 x1' x2) tl tr
+
+
+hedgeDiffWithKey :: Ord k
+ => Sized a -> (k -> a ix -> b ix -> Maybe (a ix))
+ -> (k -> Ordering) -> (k -> Ordering)
+ -> OrdMap k a ix -> OrdMap k b ix -> OrdMap k a ix
+hedgeDiffWithKey _ _ _ _ Tip _
+ = Tip
+hedgeDiffWithKey s _ cmplo cmphi (Bin _ kx x l r) Tip
+ = join s kx x (filterGt s cmplo l) (filterLt s cmphi r)
+hedgeDiffWithKey s f cmplo cmphi t (Bin _ kx x l r)
+ = case found of
+ Nothing -> merge s tl tr
+ Just (ky,y) ->
+ case f ky y x of
+ Nothing -> merge s tl tr
+ Just z -> join s ky z tl tr
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t
+ (found,gt) = trimLookupLo kx cmphi t
+ tl = hedgeDiffWithKey s f cmplo cmpkx lt l
+ tr = hedgeDiffWithKey s f cmpkx cmphi gt r
+
+joinMaybe :: Ord k => Sized a -> k -> Maybe (a ix) -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+joinMaybe s kx = maybe (merge s) (join s kx)
+
+join :: Ord k => Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+join s kx x Tip r = insertMin s kx x r
+join s kx x l Tip = insertMax s kx x l
+join s kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
+ | delta*sizeL <= sizeR = balance s kz z (join s kx x l lz) rz
+ | delta*sizeR <= sizeL = balance s ky y ly (join s kx x ry r)
+ | otherwise = bin s kx x l r
+
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix
+insertMax s kx x t
+ = case t of
+ Tip -> singleton s kx x
+ Bin _ ky y l r
+ -> balance s ky y l (insertMax s kx x r)
+
+insertMin s kx x t
+ = case t of
+ Tip -> singleton s kx x
+ Bin _ ky y l r
+ -> balance s ky y (insertMin s kx x l) r
+
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Sized a -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+merge _ Tip r = r
+merge _ l Tip = l
+merge s l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
+ | delta*sizeL <= sizeR = balance s ky y (merge s l ly) ry
+ | delta*sizeR <= sizeL = balance s kx x lx (merge s rx r)
+ | otherwise = glue s l r
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Sized a -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+glue _ Tip r = r
+glue _ l Tip = l
+glue s l r
+ | size l > size r = let ((km,m),l') = deleteFindMax s l in balance s km m l' r
+ | otherwise = let ((km,m),r') = deleteFindMin s r in balance s km m l r'
+
+deleteFindMin :: Sized a -> OrdMap k a ix -> ((k, a ix), OrdMap k a ix)
+deleteFindMin s t
+ = case t of
+ Bin _ k x Tip r -> ((k,x),r)
+ Bin _ k x l r -> let (km,l') = deleteFindMin s l in (km,balance s k x l' r)
+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
+
+deleteFindMax :: Sized a -> OrdMap k a ix -> ((k, a ix), OrdMap k a ix)
+deleteFindMax s t
+ = case t of
+ Bin _ k x l Tip -> ((k,x),l)
+ Bin _ k x l r -> let (km,r') = deleteFindMax s r in (km,balance s k x l r')
+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
+
+delta,ratio :: Int
+delta = 5
+ratio = 2
+
+size :: OrdMap k a ix -> Int
+size Tip = 0
+size (Bin s _ _ _ _) = s
+
+balance :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+balance s k x l r
+ | sizeL + sizeR <= 1 = Bin sizeX k x l r
+ | sizeR >= delta*sizeL = rotateL s k x l r
+ | sizeL >= delta*sizeR = rotateR s k x l r
+ | otherwise = Bin sizeX k x l r
+ where
+ sizeL = size l
+ sizeR = size r
+ sizeX = sizeL + sizeR + s x
+
+-- rotate
+rotateL :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+rotateL s k x l r@(Bin _ _ _ ly ry)
+ | size ly < ratio*size ry = singleL s k x l r
+ | otherwise = doubleL s k x l r
+rotateL _ _ _ _ Tip = error "rotateL Tip"
+
+rotateR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+rotateR s k x l@(Bin _ _ _ ly ry) r
+ | size ry < ratio*size ly = singleR s k x l r
+ | otherwise = doubleR s k x l r
+rotateR _ _ _ Tip _ = error "rotateR Tip"
+
+-- basic rotations
+singleL, singleR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+singleL s k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin s k2 x2 (bin s k1 x1 t1 t2) t3
+singleL _ _ _ _ Tip = error "singleL Tip"
+singleR s k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin s k2 x2 t1 (bin s k1 x1 t2 t3)
+singleR _ _ _ Tip _ = error "singleR Tip"
+
+doubleL, doubleR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+doubleL s k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin s k3 x3 (bin s k1 x1 t1 t2) (bin s k2 x2 t3 t4)
+doubleL _ _ _ _ _ = error "doubleL"
+doubleR s k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin s k3 x3 (bin s k2 x2 t1 t2) (bin s k1 x1 t3 t4)
+doubleR _ _ _ _ _ = error "doubleR"
+
+bin :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+bin s k x l r
+ = Bin (size l + size r + s x) k x l r \ No newline at end of file
diff --git a/Data/TrieMap/Regular.hs b/Data/TrieMap/Regular.hs
new file mode 100644
index 0000000..0089e53
--- /dev/null
+++ b/Data/TrieMap/Regular.hs
@@ -0,0 +1,6 @@
+module Data.TrieMap.Regular (TrieMapT, TrieKeyT, module Data.TrieMap.Regular.Base, EqT(..), Comparator, OrdT (..){-, K0 (..), I0 (..), U(..), (:*:)(..), (:+:)(..), L(..), Fix(..)-}) where
+
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Ord
+import Data.TrieMap.Regular.Eq \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Base.hs b/Data/TrieMap/Regular/Base.hs
new file mode 100644
index 0000000..01e81fa
--- /dev/null
+++ b/Data/TrieMap/Regular/Base.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE FlexibleContexts, TypeFamilies, TypeOperators #-}
+
+module Data.TrieMap.Regular.Base where
+
+newtype K0 a r = K0 {unK0 :: a}
+newtype I0 r = I0 {unI0 :: r}
+data U0 r = U0
+data (f :*: g) r = f r :*: g r
+data (f :+: g) r = L (f r) | R (g r)
+newtype L f r = List [f r]
+newtype Reg r = Reg {unReg :: r}
+
+newtype Fix f = In {out :: f (Fix f)}
+
+type family PF a :: * -> *
+
+class Regular a where
+ from :: a -> PF a a
+ to :: PF a a -> a
+
+type instance PF (K0 a r) = K0 a
+type instance PF (I0 r) = I0
+type instance PF (U0 r) = U0
+type instance PF ((f :*: g) r) = PF (f r) :*: PF (g r)
+type instance PF ((f :+: g) r) = PF (f r) :+: PF (g r)
+type instance PF (Fix f) = f
+type instance PF [a] = L (PF a)
+type instance PF (L f a) = L (PF (f a))
+-- type instance PF Bool = K Bool
+-- type instance PF Int = K Int
+-- type instance PF Char = K Char
+-- type instance PF
+
+instance Functor (K0 a) where
+ fmap _ (K0 a) = K0 a
+
+instance Functor I0 where
+ fmap f (I0 a) = I0 (f a)
+
+instance Functor U0 where
+ fmap _ U0 = U0
+
+instance Functor f => Functor (L f) where
+ fmap f (List xs) = List (map (fmap f) xs)
+
+instance (Functor f, Functor g) => Functor (f :*: g) where
+ fmap f (x :*: y) = fmap f x :*: fmap f y
+
+instance (Functor f, Functor g) => Functor (f :+: g) where
+ fmap f (L x) = L (fmap f x)
+ fmap f (R x) = R (fmap f x)
+
+from' :: (Functor (PF a), Regular a) => Reg a -> PF a (Reg a)
+from' (Reg a) = fmap Reg (from a)
+
+to' :: (Functor (PF a), Regular a) => PF a (Reg a) -> Reg a
+to' = Reg . to . fmap unReg
+
+infixr 7 :*:
+infixr 6 :+: \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Class.hs b/Data/TrieMap/Regular/Class.hs
new file mode 100644
index 0000000..63af849
--- /dev/null
+++ b/Data/TrieMap/Regular/Class.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE Rank2Types, FlexibleContexts, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies #-}
+
+module Data.TrieMap.Regular.Class where
+
+import Data.TrieMap.Sized
+import Data.TrieMap.Applicative
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Regular.Eq
+import Data.TrieMap.Regular.Ord
+
+import Data.Monoid
+
+import Control.Applicative
+
+type family TrieMapT (f :: * -> *) :: * -> (* -> *) -> * -> *
+
+class OrdT f => TrieKeyT (f :: * -> *) (m :: * -> (* -> *) -> * -> *) | m -> f, f -> m where
+ emptyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a ix
+ nullT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a ix -> Bool
+ sizeT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a ix -> Int
+ lookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => f k -> m k a ix -> Maybe (a ix)
+ lookupIxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> f k -> m k a ix -> Maybe (Int, a ix)
+ assocAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> Int -> m k a ix -> (Int, f k, a ix)
+ updateAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Int -> f k -> a ix -> Maybe (a ix)) -> Int -> m k a ix -> m k a ix
+ alterT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> f k -> m k a ix -> m k a ix
+ traverseWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k), Applicative t) =>
+ Sized b -> (f k -> a ix -> t (b ix)) -> m k a ix -> t (m k b ix)
+ foldWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>
+ (f k -> a ix -> b -> b) -> m k a ix -> b -> b
+ foldlWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>
+ (f k -> b -> a ix -> b) -> m k a ix -> b -> b
+ mapEitherT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>
+ Sized b -> Sized c -> EitherMap (f k) (a ix) (b ix) (c ix) -> m k a ix -> (m k b ix, m k c ix)
+ splitLookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> SplitMap (a ix) x -> f k ->
+ m k a ix -> (m k a ix, Maybe x, m k a ix)
+ unionT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> UnionFunc (f k) (a ix) ->
+ m k a ix -> m k a ix -> m k a ix
+ isectT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized c -> IsectFunc (f k) (a ix) (b ix) (c ix) ->
+ m k a ix -> m k b ix -> m k c ix
+ diffT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> DiffFunc (f k) (a ix) (b ix) ->
+ m k a ix -> m k b ix -> m k a ix
+ extractMinT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a ix -> First ((f k, a ix), m k a ix)
+ extractMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a ix -> Last ((f k, a ix), m k a ix)
+ alterMinT, alterMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a ix -> Maybe (a ix)) ->
+ m k a ix -> m k a ix
+ isSubmapT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => LEq (a ix) (b ix) -> LEq (m k a ix) (m k b ix)
+ fromListT, fromAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a ix -> a ix -> a ix) ->
+ [(f k, a ix)] -> m k a ix
+ fromDistAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> [(f k, a ix)] -> m k a ix
+ fromListT s f = foldr (\ (k, a) -> alterT s (Just . maybe a (f k a)) k) emptyT
+ fromAscListT = fromListT
+ fromDistAscListT s = fromAscListT s (const const)
+ updateAtT s f i m = case assocAtT s i m of
+ (i, k, a) -> alterT s (const (f i k a)) k m
+
+guardNullT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a ix -> Maybe (TrieMapT f k a ix)
+guardNullT m
+ | nullT m = Nothing
+ | otherwise = Just m
+
+assocsT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a ix -> [(f k, a ix)]
+assocsT m = foldWithKeyT (\ k a -> ((k, a):)) m []
+
+singletonT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> f k -> a ix -> TrieMapT f k a ix
+singletonT s k a = alterT s (const (Just a)) k emptyT
+
+mapWithKeyT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized b -> (f k -> a ix -> b ix) -> TrieMapT f k a ix -> TrieMapT f k b ix
+mapWithKeyT s f m = unId (traverseWithKeyT s (Id .: f) m)
diff --git a/Data/TrieMap/Regular/ConstMap.hs b/Data/TrieMap/Regular/ConstMap.hs
new file mode 100644
index 0000000..e675467
--- /dev/null
+++ b/Data/TrieMap/Regular/ConstMap.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-}
+
+module Data.TrieMap.Regular.ConstMap where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+-- import Data.Monoid
+
+newtype KMap m k (a :: * -> *) ix = KMap (m a ix)
+type instance TrieMapT (K0 a) = KMap (TrieMap a)
+type instance TrieMap (K0 a r) = TrieMapT (K0 a) r
+
+instance (TrieKey k m, m ~ TrieMap k) => TrieKey (K0 k r) (KMap m r) where
+ emptyM = KMap emptyM
+ nullM (KMap m) = nullM m
+ sizeM s (KMap m) = sizeM s m
+ lookupM (K0 k) (KMap m) = lookupM k m
+ lookupIxM s (K0 k) (KMap m) = lookupIxM s k m
+ assocAtM s i (KMap m) = case assocAtM s i m of
+ (i', k, a) -> (i', K0 k, a)
+ updateAtM s f i (KMap m) = KMap (updateAtM s (\ i -> f i . K0) i m)
+ alterM s f (K0 k) (KMap m) = KMap (alterM s f k m)
+ traverseWithKeyM s f (KMap m) = KMap <$> traverseWithKeyM s (f . K0) m
+ foldWithKeyM f (KMap m) = foldWithKeyM (f . K0) m
+ foldlWithKeyM f (KMap m) = foldlWithKeyM (f . K0) m
+ mapEitherM s1 s2 f (KMap m) = (KMap *** KMap) (mapEitherM s1 s2 (f . K0) m)
+ splitLookupM s f (K0 k) (KMap m) = KMap `sides` splitLookupM s f k m
+ unionM s f (KMap m1) (KMap m2) = KMap (unionM s (f . K0) m1 m2)
+ isectM s f (KMap m1) (KMap m2) = KMap (isectM s (f . K0) m1 m2)
+ diffM s f (KMap m1) (KMap m2) = KMap (diffM s (f . K0) m1 m2)
+ extractMinM s (KMap m) = (first K0 *** KMap) `liftM` extractMinM s m
+ extractMaxM s (KMap m) = (first K0 *** KMap) `liftM` extractMaxM s m
+ alterMinM s f (KMap m) = KMap (alterMinM s (f . K0) m)
+ alterMaxM s f (KMap m) = KMap (alterMaxM s (f . K0) m)
+ isSubmapM (<=) (KMap m1) (KMap m2) = isSubmapM (<=) m1 m2
+ fromListM s f xs = KMap (fromListM s (f . K0) [(k, a) | (K0 k, a) <- xs])
+ fromAscListM s f xs = KMap (fromAscListM s (f . K0) [(k, a) | (K0 k, a) <- xs])
+ fromDistAscListM s xs = KMap (fromDistAscListM s [(k, a) | (K0 k, a) <- xs])
+
+instance (TrieKey k m, m ~ TrieMap k) => TrieKeyT (K0 k) (KMap m) where
+ emptyT = emptyM
+ nullT = nullM
+ sizeT = sizeM
+ lookupT = lookupM
+ lookupIxT = lookupIxM
+ assocAtT = assocAtM
+ updateAtT = updateAtM
+ alterT = alterM
+ traverseWithKeyT = traverseWithKeyM
+ foldWithKeyT = foldWithKeyM
+ foldlWithKeyT = foldlWithKeyM
+ mapEitherT = mapEitherM
+ splitLookupT = splitLookupM
+ unionT = unionM
+ isectT = isectM
+ diffT = diffM
+ extractMinT = extractMinM
+ extractMaxT = extractMaxM
+ alterMinT = alterMinM
+ alterMaxT = alterMaxM
+ isSubmapT = isSubmapM
+ fromListT = fromListM
+ fromAscListT = fromAscListM
+ fromDistAscListT = fromDistAscListM \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Eq.hs b/Data/TrieMap/Regular/Eq.hs
new file mode 100644
index 0000000..83411ab
--- /dev/null
+++ b/Data/TrieMap/Regular/Eq.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators #-}
+
+module Data.TrieMap.Regular.Eq where
+
+import Data.TrieMap.Regular.Base
+
+class EqT f where
+ eqT0 :: (a -> a -> Bool) -> f a -> f a -> Bool
+
+eqT :: (EqT f, Eq a) => f a -> f a -> Bool
+eqT = eqT0 (==)
+
+instance Eq a => EqT (K0 a) where
+ eqT0 _ (K0 a) (K0 b) = a == b
+
+instance EqT I0 where
+ eqT0 (==) (I0 a) (I0 b) = a == b
+
+instance EqT [] where
+ eqT0 (==) = eqT' where
+ eqT' (a:as) (b:bs) = a == b && eqT' as bs
+ eqT' [] [] = True
+
+eqT' _ _ = False
+
+instance (EqT f, EqT g) => EqT (f :*: g) where
+ eqT0 (==) (x1 :*: y1) (x2 :*: y2) = eqT0 (==) x1 x2 && eqT0 (==) y1 y2
+
+instance (EqT f, EqT g) => EqT (f :+: g) where
+ eqT0 (==) a b = case (a, b) of
+ (L a, L b) -> eqT0 (==) a b
+ (R a, R b) -> eqT0 (==) a b
+ _ -> False
+
+instance EqT U0 where
+ eqT0 _ _ _ = True
+
+instance EqT f => EqT (L f) where
+ eqT0 (==) (List xs) (List ys) = eqT' xs ys where
+ eqT0' = eqT0 (==)
+ eqT' (a:as) (b:bs) = eqT0' a b && eqT' as bs
+ eqT' [] [] = True
+ eqT' _ _ = False
+
+instance (Regular a, Functor (PF a), EqT (PF a)) => Eq (Reg a) where
+ a == b = eqT (from' a) (from' b)
+
+instance (EqT f, Eq r) => Eq (L f r) where
+ (==) = eqT
+
+instance (EqT f, EqT g, Eq r) => Eq ((f :*: g) r) where
+ (==) = eqT
+
+instance (EqT f, EqT g, Eq r) => Eq ((f :+: g) r) where
+ (==) = eqT
+
+instance Eq a => Eq (K0 a r) where
+ K0 a == K0 b = a == b
+
+instance Eq r => Eq (I0 r) where
+ I0 a == I0 b = a == b
+
+instance Eq (U0 r) where
+ _ == _ = True \ No newline at end of file
diff --git a/Data/TrieMap/Regular/IdMap.hs b/Data/TrieMap/Regular/IdMap.hs
new file mode 100644
index 0000000..7c78574
--- /dev/null
+++ b/Data/TrieMap/Regular/IdMap.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE FlexibleContexts, TypeFamilies, MultiParamTypeClasses #-}
+
+module Data.TrieMap.Regular.IdMap where
+
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Class
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+newtype IMap k a ix = IMap (TrieMap k a ix)
+type instance TrieMapT I0 = IMap
+type instance TrieMap (I0 k) = IMap k
+
+instance TrieKeyT I0 IMap where
+ emptyT = IMap emptyM
+ nullT (IMap m) = nullM m
+ sizeT s (IMap m) = sizeM s m
+ lookupT (I0 k) (IMap m) = lookupM k m
+ lookupIxT s (I0 k) (IMap m) = lookupIxM s k m
+ assocAtT s i (IMap m) = case assocAtM s i m of
+ (i', k, a) -> (i', I0 k, a)
+ updateAtT s f i (IMap m) = IMap (updateAtM s (\ i -> f i . I0) i m)
+ alterT s f (I0 k) (IMap m) = IMap (alterM s f k m)
+ traverseWithKeyT s f (IMap m) = IMap <$> traverseWithKeyM s (f . I0) m
+ foldWithKeyT f (IMap m) = foldWithKeyM (f . I0) m
+ foldlWithKeyT f (IMap m) = foldlWithKeyM (f . I0) m
+ mapEitherT s1 s2 f (IMap m) = (IMap *** IMap) (mapEitherM s1 s2 (f . I0) m)
+ splitLookupT s f (I0 k) (IMap m) = IMap `sides` splitLookupM s f k m
+ unionT s f (IMap m1) (IMap m2) = IMap (unionM s (f . I0) m1 m2)
+ isectT s f (IMap m1) (IMap m2) = IMap (isectM s (f . I0) m1 m2)
+ diffT s f (IMap m1) (IMap m2) = IMap (diffM s (f . I0) m1 m2)
+ extractMinT s (IMap m) = (first I0 *** IMap) `liftM` extractMinM s m
+ extractMaxT s (IMap m) = (first I0 *** IMap) `liftM` extractMaxM s m
+ alterMinT s f (IMap m) = IMap (alterMinM s (f . I0) m)
+ alterMaxT s f (IMap m) = IMap (alterMaxM s (f . I0) m)
+ isSubmapT (<=) (IMap m1) (IMap m2) = isSubmapM (<=) m1 m2
+ fromListT s f xs = IMap (fromListM s (f . I0) [(k, a) | (I0 k, a) <- xs])
+ fromAscListT s f xs = IMap (fromAscListM s (f . I0) [(k, a) | (I0 k, a) <- xs])
+ fromDistAscListT s xs = IMap (fromDistAscListM s [(k, a) | (I0 k, a) <- xs])
+
+instance TrieKey k (TrieMap k) => TrieKey (I0 k) (IMap k) where
+ emptyM = emptyT
+ nullM = nullT
+ sizeM = sizeT
+ lookupM = lookupT
+ lookupIxM = lookupIxT
+ assocAtM = assocAtT
+ updateAtM = updateAtT
+ alterM = alterT
+ traverseWithKeyM = traverseWithKeyT
+ foldWithKeyM = foldWithKeyT
+ foldlWithKeyM = foldlWithKeyT
+ mapEitherM = mapEitherT
+ splitLookupM = splitLookupT
+ unionM = unionT
+ isectM = isectT
+ diffM = diffT
+ extractMinM = extractMinT
+ extractMaxM = extractMaxT
+ alterMinM = alterMinT
+ alterMaxM = alterMaxT
+ isSubmapM = isSubmapT
+ fromListM = fromListT
+ fromAscListM = fromAscListT
+ fromDistAscListM = fromDistAscListT \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Instances.hs b/Data/TrieMap/Regular/Instances.hs
new file mode 100644
index 0000000..43f0365
--- /dev/null
+++ b/Data/TrieMap/Regular/Instances.hs
@@ -0,0 +1,9 @@
+module Data.TrieMap.Regular.Instances where
+
+import Data.TrieMap.Regular.UnitMap
+import Data.TrieMap.Regular.ConstMap
+import Data.TrieMap.Regular.ProdMap
+import Data.TrieMap.Regular.UnionMap
+import Data.TrieMap.Regular.RadixTrie
+import Data.TrieMap.Regular.IdMap
+import Data.TrieMap.Regular.RegMap \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Ord.hs b/Data/TrieMap/Regular/Ord.hs
new file mode 100644
index 0000000..677a005
--- /dev/null
+++ b/Data/TrieMap/Regular/Ord.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeOperators #-}
+
+module Data.TrieMap.Regular.Ord where
+
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Eq
+
+import Data.Monoid
+
+type Comparator a = a -> a -> Ordering
+
+class EqT f => OrdT f where
+ compareT0 :: Comparator a -> Comparator (f a)
+
+compareT :: (OrdT f, Ord a) => Comparator (f a)
+compareT = compareT0 compare
+
+instance Ord a => OrdT (K0 a) where
+ compareT0 _ (K0 a) (K0 b) = compare a b
+
+instance Ord a => Ord (K0 a r) where
+ compare (K0 a) (K0 b) = compare a b
+
+instance OrdT I0 where
+ compareT0 cmp (I0 a) (I0 b) = cmp a b
+
+instance Ord r => Ord (I0 r) where
+ compare = compareT
+
+instance (OrdT f, OrdT g) => OrdT (f :*: g) where
+ compareT0 cmp (x1 :*: y1) (x2 :*: y2) = compareT0 cmp x1 x2 `mappend` compareT0 cmp y1 y2
+
+instance (OrdT f, OrdT g, Ord r) => Ord ((f :*: g) r) where
+ compare = compareT
+
+instance (OrdT f, OrdT g) => OrdT (f :+: g) where
+ compareT0 cmp x y = case (x, y) of
+ (L x, L y) -> compareT0 cmp x y
+ (R x, R y) -> compareT0 cmp x y
+ (L _, R _) -> LT
+ (R _, L _) -> GT
+
+instance (OrdT f, OrdT g, Ord r) => Ord ((f :+: g) r) where
+ compare = compareT
+
+instance OrdT U0 where
+ compareT0 _ = compare
+
+instance Ord (U0 r) where
+ compare _ _ = EQ
+
+instance OrdT f => OrdT (L f) where
+ compareT0 cmp (List xs) (List ys) = compareT0' xs ys where
+ cmpT' = compareT0 cmp
+ compareT0' (x:xs) (y:ys) = cmpT' x y `mappend` compareT0' xs ys
+ compareT0' [] [] = EQ
+ compareT0' [] _ = LT
+ compareT0' _ [] = GT
+
+instance (OrdT f, Ord r) => Ord (L f r) where
+ compare = compareT
+
+instance OrdT [] where
+ compareT0 cmp = cmpT' where
+ cmpT' (x:xs) (y:ys) = cmp x y `mappend` cmpT' xs ys
+ cmpT' [] [] = EQ
+ cmpT' [] _ = LT
+ cmpT' _ [] = GT
+
+instance (Regular a, Functor (PF a), OrdT (PF a)) => Ord (Reg a) where
+ compare a b = compareT (from' a) (from' b) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/ProdMap.hs b/Data/TrieMap/Regular/ProdMap.hs
new file mode 100644
index 0000000..332afb8
--- /dev/null
+++ b/Data/TrieMap/Regular/ProdMap.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts, TypeOperators, UndecidableInstances #-}
+
+module Data.TrieMap.Regular.ProdMap() where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Applicative
+
+import Control.Applicative
+import Control.Arrow
+
+import Data.Maybe
+
+newtype PMap m1 (m2 :: * -> (* -> *) -> * -> *) k (a :: * -> *) ix = PMap (m1 k (m2 k a) ix)
+type instance TrieMapT (f :*: g) = PMap (TrieMapT f) (TrieMapT g)
+type instance TrieMap ((f :*: g) r) = TrieMapT (f :*: g) r
+
+instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :*: g) (PMap m1 m2) where
+ emptyT = PMap emptyT
+ nullT (PMap m) = nullT m
+ sizeT s (PMap m) = sizeT (sizeT s) m
+ lookupT (a :*: b) (PMap m) = lookupT a m >>= lookupT b
+ lookupIxT s (a :*: b) (PMap m) = do
+ (iA, m') <- lookupIxT (sizeT s) a m
+ (iB, v) <- lookupIxT s b m'
+ return (iA + iB, v)
+ assocAtT s i (PMap m) = case assocAtT (sizeT s) i m of
+ (iA, a, m') -> case assocAtT s (i - iA) m' of
+ (iB, b, v) -> (iA + iB, a :*: b, v)
+ updateAtT s f i (PMap m) = PMap (updateAtT (sizeT s) g i m) where
+ g iA a = guardNullT . updateAtT s (\ iB b -> f (iA + iB) (a :*: b)) (i - iA)
+ alterT s f (a :*: b) (PMap m) = PMap (alterT (sizeT s) g a m) where
+ g = guardNullT . alterT s f b . fromMaybe emptyT
+ traverseWithKeyT s f (PMap m) = PMap <$> traverseWithKeyT (sizeT s) g m where
+ g a = traverseWithKeyT s (\ b -> f (a :*: b))
+ foldWithKeyT f (PMap m) = foldWithKeyT g m where
+ g a = foldWithKeyT (\ b -> f (a :*: b))
+ foldlWithKeyT f (PMap m) = foldlWithKeyT g m where
+ g a z m = foldlWithKeyT (\ b -> f (a :*: b)) m z
+ mapEitherT s1 s2 f (PMap m) = (PMap *** PMap) (mapEitherT (sizeT s1) (sizeT s2) g m) where
+ g a = (guardNullT *** guardNullT) . mapEitherT s1 s2 (\ b -> f (a :*: b))
+ splitLookupT s f (a :*: b) (PMap m) = PMap `sides` splitLookupT (sizeT s) g a m where
+ g = sides guardNullT . splitLookupT s f b
+ unionT s f (PMap m1) (PMap m2) = PMap (unionT (sizeT s) (\ a -> guardNullT .: unionT s (\ b -> f (a :*: b))) m1 m2)
+ isectT s f (PMap m1) (PMap m2) = PMap (isectT (sizeT s) (\ a -> guardNullT .: isectT s (\ b -> f (a :*: b))) m1 m2)
+ diffT s f (PMap m1) (PMap m2) = PMap (diffT (sizeT s) (\ a -> guardNullT .: diffT s (\ b -> f (a :*: b))) m1 m2)
+ extractMinT s (PMap m) = do
+ ((a, m1), m') <- extractMinT (sizeT s) m
+ ((b, v), m1') <- extractMinT s m1
+ return ((a :*: b, v), PMap (maybe m' (\ _ -> alterMinT (sizeT s) (\ _ _ -> Just m1') m) (guardNullT m1')))
+ extractMaxT s (PMap m) = do
+ ((a, m1), m') <- extractMaxT (sizeT s) m
+ ((b, v), m1') <- extractMaxT s m1
+ return ((a :*: b, v), PMap (maybe m' (\ _ -> alterMaxT (sizeT s) (\ _ _ -> Just m1') m) (guardNullT m1')))
+ alterMinT s f (PMap m) = PMap (alterMinT (sizeT s) (\ a -> guardNullT . alterMinT s (\ b -> f (a :*: b))) m)
+ alterMaxT s f (PMap m) = PMap (alterMaxT (sizeT s) (\ a -> guardNullT . alterMaxT s (\ b -> f (a :*: b))) m)
+ isSubmapT (<=) (PMap m1) (PMap m2) = isSubmapT (isSubmapT (<=)) m1 m2
+
+instance (TrieKeyT f m1, TrieKeyT g m2, TrieKey k (TrieMap k)) => TrieKey ((f :*: g) k) (PMap m1 m2 k) where
+ emptyM = emptyT
+ nullM = nullT
+ sizeM = sizeT
+ lookupM = lookupT
+ lookupIxM = lookupIxT
+ assocAtM = assocAtT
+ updateAtM = updateAtT
+ alterM = alterT
+ traverseWithKeyM = traverseWithKeyT
+ foldWithKeyM = foldWithKeyT
+ foldlWithKeyM = foldlWithKeyT
+ mapEitherM = mapEitherT
+ splitLookupM = splitLookupT
+ unionM = unionT
+ isectM = isectT
+ diffM = diffT
+ extractMinM = extractMinT
+ extractMaxM = extractMaxT
+ alterMinM = alterMinT
+ alterMaxM = alterMaxT
+ isSubmapM = isSubmapT
+ fromListM = fromListT
+ fromAscListM = fromAscListT
+ fromDistAscListM = fromDistAscListT \ No newline at end of file
diff --git a/Data/TrieMap/Regular/RadixTrie.hs b/Data/TrieMap/Regular/RadixTrie.hs
new file mode 100644
index 0000000..5a39bbe
--- /dev/null
+++ b/Data/TrieMap/Regular/RadixTrie.hs
@@ -0,0 +1,322 @@
+{-# LANGUAGE Rank2Types, PatternGuards, FlexibleContexts, TypeFamilies, UndecidableInstances, MultiParamTypeClasses #-}
+
+module Data.TrieMap.Regular.RadixTrie where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Ord
+import Data.TrieMap.Regular.Eq
+import Data.TrieMap.Sized
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Applicative
+
+import Control.Arrow
+import Control.Applicative
+import Control.Monad
+
+import Data.Maybe
+import Data.Monoid
+import Data.Foldable
+import Data.Traversable
+
+import Prelude hiding (foldr, foldl)
+
+data Edge f (m :: * -> (* -> *) -> * -> *) k (a :: * -> *) ix = Edge {-# UNPACK #-} !Int [f k] (Maybe (a ix)) (m k (Edge f m k a) ix)
+type Edge' f k a ix = Edge f (TrieMapT f) k a ix
+type MEdge f k m a ix = Maybe (Edge f m k a ix)
+type MEdge' f k a ix = Maybe (Edge' f k a ix)
+newtype RadixTrie f k a ix = Radix (MEdge' f k a ix)
+-- newtype K0 a b = K0 a
+
+type instance TrieMapT (L f) = RadixTrie f
+type instance TrieMap (L f r) = RadixTrie f r
+-- type instance TrieMap [k] = RadixTrie k (TrieMap k)
+
+edgeSize :: Sized (Edge f m k a)
+edgeSize (Edge s _ _ _) = s
+
+edge :: (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a ix) -> m k (Edge f m k a) ix -> Edge f m k a ix
+edge s ks v ts = Edge (maybe 0 s v + sizeT edgeSize ts) ks v ts
+
+instance (OrdT f, TrieKeyT f m, m ~ TrieMapT f) => TrieKeyT (L f) (RadixTrie f) where
+ emptyT = Radix Nothing
+ nullT (Radix m) = isNothing m
+ sizeT _ (Radix m) = maybe 0 edgeSize m
+ lookupT (List ks) (Radix m) = m >>= lookupE ks
+ lookupIxT s (List ks) (Radix m) = m >>= lookupIxE s 0 ks
+ assocAtT s i (Radix m) = fromJust (do (i', ks, v) <- m >>= assocAtE s i
+ return (i', List ks, v))
+ updateAtT s f i (Radix m) = Radix (m >>= updateAtE s (\ i' -> f i' . List) i)
+ alterT s f (List ks) (Radix m) = Radix (maybe (singletonME s ks (f Nothing)) (alterE s f ks) m)
+ traverseWithKeyT s f (Radix m) = Radix <$> traverse (traverseE s (f . List)) m
+ foldWithKeyT f (Radix m) z = foldr (foldE (f . List)) z m
+ foldlWithKeyT f (Radix m) z = foldr (foldlE (f . List)) z m
+ mapEitherT s1 s2 f (Radix m) = (Radix *** Radix) (maybe (Nothing, Nothing) (mapEitherE s1 s2 (f . List)) m)
+ splitLookupT s f (List ks) (Radix m) = Radix `sides` maybe (Nothing, Nothing, Nothing) (splitLookupE s f ks) m
+ unionT s f (Radix m1) (Radix m2) = Radix (unionMaybe (unionE s (f . List)) m1 m2)
+ isectT s f (Radix m1) (Radix m2) = Radix (isectMaybe (isectE s (f . List)) m1 m2)
+ diffT s f (Radix m1) (Radix m2) = Radix (diffMaybe (diffE s (f . List)) m1 m2)
+ extractMinT s (Radix m) = First m >>= liftM (first List *** Radix) . extractMinE s
+ extractMaxT s (Radix m) = Last m >>= liftM (first List *** Radix) . extractMaxE s
+ alterMinT s f (Radix m) = Radix (m >>= alterMinE s (f . List))
+ alterMaxT s f (Radix m) = Radix (m >>= alterMaxE s (f . List))
+ isSubmapT (<=) (Radix m1) (Radix m2) = subMaybe (isSubEdge (<=)) m1 m2
+ fromListT s f xs = Radix (fromListE s (f . List) [(ks, a) | (List ks, a) <- xs])
+ fromAscListT s f xs = Radix (fromAscListE s (f . List) [(ks, a) | (List ks, a) <- xs])
+
+instance (OrdT f, TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieKey (L f k) (RadixTrie f k) where
+ emptyM = emptyT
+ nullM = nullT
+ sizeM = sizeT
+ lookupM = lookupT
+ lookupIxM = lookupIxT
+ assocAtM = assocAtT
+ updateAtM = updateAtT
+ alterM = alterT
+ traverseWithKeyM = traverseWithKeyT
+ foldWithKeyM = foldWithKeyT
+ foldlWithKeyM = foldlWithKeyT
+ mapEitherM = mapEitherT
+ splitLookupM = splitLookupT
+ unionM = unionT
+ isectM = isectT
+ diffM = diffT
+ extractMinM = extractMinT
+ extractMaxM = extractMaxT
+ alterMinM = alterMinT
+ alterMaxM = alterMaxT
+ isSubmapM = isSubmapT
+ fromListM = fromListT
+ fromAscListM = fromAscListT
+ fromDistAscListM = fromDistAscListT
+
+-- instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where
+-- emptyM = Radix Nothing
+-- nullM (Radix m) = isNothing m
+-- lookupM ks (Radix m) = m >>= lookupE ks
+-- alterM f ks (Radix m) = Radix (maybe (singletonME ks (f Nothing)) (alterE f ks) m)
+-- traverseWithKeyM f (Radix m) = Radix <$> traverse (traverseE f) m
+-- foldWithKeyM f (Radix m) z = foldr (foldE f) z m
+-- mapEitherM f (Radix m) = (Radix *** Radix) (maybe (Nothing, Nothing) (mapEitherE f) m)
+-- splitLookupM f ks (Radix m) = Radix `sides` maybe (Nothing, Nothing, Nothing) (splitLookupE f ks) m
+-- unionM f (Radix m1) (Radix m2) = Radix (unionMaybe (unionE f) m1 m2)
+-- isectM f (Radix m1) (Radix m2) = Radix (isectMaybe (isectE f) m1 m2)
+-- diffM f (Radix m1) (Radix m2) = Radix (diffMaybe (diffE f) m1 m2)
+-- extractMinM (Radix m) = First m >>= fmap (fmap Radix) . extractMinE
+-- extractMaxM (Radix m) = Last m >>= fmap (fmap Radix) . extractMaxE
+-- alterMinM f (Radix m) = Radix (m >>= alterMinE f)
+-- alterMaxM f (Radix m) = Radix (m >>= alterMaxE f)
+-- isSubmapM (<=) (Radix m1) (Radix m2) = subMaybe (isSubEdge (<=)) m1 m2
+-- fromListM = Radix .: fromListE
+-- fromAscListM = Radix .: fromAscListE
+
+compact :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Edge' f k a ix -> MEdge' f k a ix
+compact e@(Edge s ks Nothing ts) = case assocsT ts of
+ [] -> Nothing
+ [~(k, e'@(Edge s' ls v ts'))]
+ -> e' `seq` compact (Edge s' (ks ++ k:ls) v ts')
+ _ -> Just e
+compact e = Just e
+
+cons :: f k -> Edge' f k a ix -> Edge' f k a ix
+l `cons` Edge s ls v ts = Edge s (l:ls) v ts
+
+cat :: [f k] -> Edge' f k a ix -> Edge' f k a ix
+ks `cat` Edge s ls v ts = Edge s (ks ++ ls) v ts
+
+singletonME :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a ix) -> MEdge' f k a ix
+singletonME s ks = fmap (\ v -> Edge (s v) ks (Just v) emptyT)
+
+lookupE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => [f k] -> Edge' f k a ix -> Maybe (a ix)
+lookupE ks (Edge _ ls v ts) = match ks ls where
+ match (k:ks) (l:ls)
+ | k `eqT` l = match ks ls
+ match (k:ks) [] = do e' <- lookupT k ts
+ lookupE ks e'
+ match [] [] = v
+ match _ _ = Nothing
+
+alterE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> [f k] -> Edge' f k a ix -> MEdge' f k a ix
+alterE s f ks0 e@(Edge sz ls0 v0 ts0) = match 0 ks0 ls0 where
+ match i _ _ | i `seq` False = undefined
+ match i (k:ks) (l:ls)
+ | k `eqT` l = match (i+1) ks ls
+ | Just v <- f Nothing
+ = Just (Edge (sz + s v) (take i ls0) Nothing
+ (fromListT edgeSize (const const) [(k, Edge (s v) ks (Just v) emptyT),
+ (l, Edge sz ls v0 ts0)]))
+ match _ (k:ks) [] = compact $ edge s ls0 v0 $ alterT edgeSize g k ts0 where
+ g = maybe (singletonME s ks (f Nothing)) (alterE s f ks)
+ match _ [] (l:ls)
+ | Just v <- f Nothing
+ = Just (Edge (sz + s v) ks0 (Just v) (singletonT edgeSize l (Edge sz ls v0 ts0)))
+ match _ [] [] = compact (edge s ls0 (f v0) ts0)
+ match _ _ _ = Just e
+
+traverseE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Applicative t) =>
+ Sized b -> ([f k] -> a ix -> t (b ix)) -> Edge' f k a ix -> t (Edge' f k b ix)
+traverseE s f (Edge _ ks v ts) =
+ edge s ks <$> traverse (f ks) v <*> traverseWithKeyT edgeSize (\ l -> traverseE s (\ ls -> f (ks ++ l:ls))) ts
+
+foldE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> a ix -> b -> b) -> Edge' f k a ix -> b -> b
+foldE f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyT (\ l -> foldE (\ ls -> f (ks ++ l:ls))) ts z) v
+
+foldlE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> b -> a ix -> b) -> Edge' f k a ix -> b -> b
+foldlE f (Edge _ ks v ts) z = foldlWithKeyT (\ l z m -> foldlE (\ ls -> f (ks ++ l:ls)) m z) ts (foldl (f ks) z v)
+
+mapEitherE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized b -> Sized c ->
+ EitherMap (EitherMap [f k] (a ix) (b ix) (c ix)) (Edge' f k a ix) (Edge' f k b ix) (Edge' f k c ix)
+mapEitherE s1 s2 f (Edge _ ks v ts) = case (maybe (Nothing, Nothing) (f ks) v, mapEitherT edgeSize edgeSize
+ (\ l -> mapEitherE s1 s2 (\ ls -> f (ks ++ l:ls))) ts) of
+ ((vL, vR), (tsL, tsR)) -> (compact (edge s1 ks vL tsL), compact (edge s2 ks vR tsR))
+
+splitLookupE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> SplitMap (a ix) x -> [f k] -> SplitMap (Edge' f k a ix) x
+splitLookupE s f ks e@(Edge _ ls v ts) = match ks ls where
+ match (k:ks) (l:ls) = case compareT k l of
+ LT -> (Nothing, Nothing, Just e)
+ EQ -> match ks ls
+ GT -> (Just e, Nothing, Nothing)
+ match [] [] = case v of
+ Nothing -> (Nothing, Nothing, Just e)
+ Just v -> compact `sides` case f v of
+ (vL, x, vR) -> (edge s ls vL emptyT, x, edge s ls vR ts)
+ match [] (l:ls) = (Just e, Nothing, Nothing)
+ match (k:ks) [] = compact `sides` case splitLookupT edgeSize g k ts of
+ (tsL, x, tsR) -> (edge s ls v tsL, x, edge s ls Nothing tsR)
+ where g = splitLookupE s f ks
+
+unionE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> UnionFunc (UnionFunc [f k] (a ix)) (Edge' f k a ix)
+unionE s f (Edge szK ks0 vK tsK) (Edge szL ls0 vL tsL) = match 0 ks0 ls0 where
+ match i _ _ | i `seq` False = undefined
+ match i (k:ks) (l:ls)
+ | k `eqT` l = match (i+1) ks ls
+ | otherwise = Just (Edge (szK + szL) (take i ks0) Nothing
+ (fromListT edgeSize (const const) [(k, Edge szK ks vK tsK), (l, Edge szL ls vL tsL)]))
+ match _ (k:ks) [] = compact (edge s ls0 vL $ alterT edgeSize g k tsL) where
+ g Nothing = Just (Edge szK ks vK tsK)
+ g (Just e) = unionE s (\ ks' -> f (ls0 ++ k:ks')) (Edge szK ks vK tsK) e
+ match _ [] (l:ls) = compact (edge s ks0 vK $ alterT edgeSize g l tsK) where
+ g Nothing = Just (Edge szL ls vL tsL)
+ g (Just e) = unionE s (\ ls' -> f (ks0 ++ l:ls')) e (Edge szL ls vL tsL)
+ match _ [] [] = compact (edge s ks0 (unionMaybe (f ks0) vK vL) (unionT edgeSize g tsK tsL)) where
+ g x = unionE s (\ xs -> f (ks0 ++ x:xs))
+
+extractMinE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> Edge' f k a ix -> First (([f k], a ix), MEdge' f k a ix)
+extractMinE s (Edge _ ks v ts) = (do
+ v <- First v
+ return ((ks, v), compact (edge s ks Nothing ts))) `mplus`
+ (do ((x, e'), ts') <- extractMinT edgeSize ts
+ ((xs, v), e'') <- extractMinE s e'
+ return ((ks ++ x:xs, v), compact (edge s ks Nothing (maybe ts' (\ e'' -> alterMinT edgeSize (\ _ _ -> Just e'') ts) e''))))
+
+extractMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> Edge' f k a ix -> Last (([f k], a ix), MEdge' f k a ix)
+extractMaxE s (Edge _ ks v ts) = (do
+ v <- Last v
+ return ((ks, v), Nothing)) `mplus`
+ (do ((x, e'), ts') <- extractMaxT edgeSize ts
+ ((xs, v), e'') <- extractMaxE s e'
+ return ((ks ++ x:xs, v), compact (edge s ks Nothing (maybe ts' (\ e'' -> alterMaxT edgeSize (\ _ _ -> Just e'') ts) e''))))
+
+alterMinE, alterMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a ->
+ ([f k] -> a ix -> Maybe (a ix)) -> Edge' f k a ix -> MEdge' f k a ix
+alterMinE s f (Edge _ ks (Just v) ts) = compact (edge s ks (f ks v) ts)
+alterMinE s f (Edge _ ks Nothing ts) = compact (edge s ks Nothing (alterMinT edgeSize (\ x -> alterMinE s (\ xs -> f (ks ++ x:xs))) ts))
+
+alterMaxE s f (Edge _ ks v ts)
+ | nullT ts = do v' <- v >>= f ks
+ return (Edge (s v') ks (Just v') ts)
+ | otherwise = compact (edge s ks v (alterMaxT edgeSize (\ x -> alterMaxE s (\ xs -> f (ks ++ x:xs))) ts))
+
+isectE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized c ->
+ IsectFunc (IsectFunc [f k] (a ix) (b ix) (c ix)) (Edge' f k a ix) (Edge' f k b ix) (Edge' f k c ix)
+isectE s f (Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where
+ match (k:ks) (l:ls)
+ | k `eqT` l = match ks ls
+ match (k:ks) [] = do e' <- lookupT k tsL
+ liftM (cat ls . cons k) (isectE s (\ ks' -> f (ls ++ k:ks')) (Edge szK ks vK tsK) e')
+ match [] (l:ls) = do e' <- lookupT l tsK
+ liftM (cat ks . cons l) (isectE s (\ ls' -> f (ks ++ l:ls')) e' (Edge szL ls vL tsL))
+ match [] [] = compact (edge s ks (isectMaybe (f ks) vK vL) (isectT edgeSize g tsK tsL)) where
+ g x = isectE s (\ xs -> f (ks ++ x:xs))
+
+diffE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a ->
+ DiffFunc (DiffFunc [f k] (a ix) (b ix)) (Edge' f k a ix) (Edge' f k b ix)
+diffE s f e@(Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where
+ match (k:ks) (l:ls)
+ | k `eqT` l = match ks ls
+ match (k:ks) []
+ | Just e' <- lookupT k tsL
+ = fmap (cat ls . cons k) (diffE s (\ ks' -> f (ls ++ k:ks')) (Edge szK ks vK tsK) e')
+ match [] (l:ls) = compact (edge s ks vK (alterT edgeSize (>>= g) l tsK)) where
+ g e' = diffE s (\ ls' -> f (ks ++ l:ls')) e' (Edge szL ls vL tsL)
+ match [] [] = compact (edge s ks (diffMaybe (f ks) vK vL) (diffT edgeSize g tsK tsL)) where
+ g x = diffE s (\ xs -> f (ks ++ x:xs))
+
+isSubEdge :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => LEq (a ix) (b ix) -> LEq (Edge' f k a ix) (Edge' f k b ix)
+isSubEdge (<=) (Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where
+ match (k:ks) (l:ls)
+ | k `eqT` l = match ks ls
+ match (k:ks) []
+ | Just e' <- lookupT k tsL
+ = isSubEdge (<=) (Edge szK ks vK tsK) e'
+ match [] []
+ = subMaybe (<=) vK vL && isSubmapT (isSubEdge (<=)) tsK tsL
+ match _ _ = False
+
+filterer :: (k -> k -> Bool) -> (a -> a -> a) -> [([k], a)] -> (Maybe a, [(k, [([k], a)])])
+filterer (==) f = filterer' where
+ filterer' (([], a):xs) = first (Just . maybe a (f a)) (filterer' xs)
+ filterer' ((k:ks, a):xs) = second (cons k ks a) (filterer' xs)
+ cons k ks a [] = [(k, [(ks, a)])]
+ cons k ks a ys0@((k', xs):ys)
+ | k == k' = (k', (ks,a):xs):ys
+ | otherwise = (k, [(ks, a)]):ys0
+
+fromListE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> ([f k] -> a ix -> a ix -> a ix) -> [([f k], a ix)] -> MEdge' f k a ix
+fromListE _ _ [] = Nothing
+fromListE s f xs = case filterer eqT (f []) xs of
+ (Nothing, [(k, xs)]) -> cons k <$> fromListE s (f . (k:)) xs
+ (v, xss) -> Just (edge s [] v (mapWithKeyT edgeSize (\ k (K0 xs) -> fromJust (fromListE s (f . (k:)) xs))
+ (fromListT (const 1) (\ _ (K0 xs) (K0 ys) -> K0 (xs ++ ys)) [(k, K0 xs) | (k, xs) <- xss])))
+
+fromAscListE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> ([f k] -> a ix -> a ix -> a ix) -> [([f k], a ix)] -> MEdge' f k a ix
+fromAscListE _ _ [] = Nothing
+fromAscListE s f xs = case filterer eqT (f []) xs of
+ (Nothing, [(k, xs)]) -> cons k <$> fromAscListE s (f . (k:)) xs
+ (v, xss) -> Just (edge s [] v (fromDistAscListT edgeSize [(k, fromJust (fromAscListE s (f . (k:)) xs)) | (k, xs) <- xss]))
+
+lookupIxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> Int -> [f k] -> Edge' f k a ix -> Maybe (Int, a ix)
+lookupIxE _ i _ _ | i `seq` False = undefined
+lookupIxE s i ks (Edge _ ls v ts) = match ks ls where
+ match (k:ks) (l:ls)
+ | k `eqT` l = match ks ls
+ match (k:ks) [] = do
+ (iT, e') <- lookupIxT edgeSize k ts
+ lookupIxE s (i + maybe 0 s v + iT) ks e'
+ match [] [] = (,) i <$> v
+ match _ _ = Nothing
+
+assocAtE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> Int -> Edge' f k a ix -> Maybe (Int, [f k], a ix)
+assocAtE s i (Edge _ ks Nothing ts) = case assocAtT edgeSize i ts of
+ (iT, l, e') -> do (i', ls, v) <- assocAtE s (i - iT) e'
+ return (iT + i', ks ++ l:ls, v)
+assocAtE s i (Edge _ ks (Just v) ts)
+ | i < sv = return (0, ks, v)
+ | (iT, l, e') <- assocAtT edgeSize (i - sv) ts
+ = do (i', ls, v') <- assocAtE s ((i - sv) - iT) e'
+ return (i' + iT + sv, ks ++ l:ls, v')
+ where sv = s v
+
+updateAtE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> (Int -> [f k] -> a ix -> Maybe (a ix)) -> Int -> Edge' f k a ix -> MEdge' f k a ix
+updateAtE s f i (Edge sz ks Nothing ts) = compact (edge s ks Nothing (updateAtT edgeSize g i ts)) where
+ g iT l = updateAtE s (\ i' ls -> f (iT + i') (ks ++ l:ls)) (i - iT)
+updateAtE s f i (Edge sz ks (Just v) ts)
+ | i < sv = compact (edge s ks (f 0 ks v) ts)
+ | otherwise = compact (edge s ks (Just v) (updateAtT edgeSize g (i - sv) ts))
+ where sv = s v
+ g iT l = updateAtE s (\ i' ls -> f (sv + iT + i') (ks ++ l:ls)) (i - sv - iT) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/RegMap.hs b/Data/TrieMap/Regular/RegMap.hs
new file mode 100644
index 0000000..589432f
--- /dev/null
+++ b/Data/TrieMap/Regular/RegMap.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}
+
+module Data.TrieMap.Regular.RegMap where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+newtype RegMap k m (a :: * -> *) ix = RegMap (m (Reg k) a ix)
+
+instance (Regular k, Functor (PF k), TrieKeyT (PF k) m, m ~ TrieMapT (PF k)) => TrieKey (Reg k) (RegMap k m) where
+ emptyM = RegMap emptyT
+ nullM (RegMap m) = nullT m
+ sizeM s (RegMap m) = sizeT s m
+ lookupM k (RegMap m) = lookupT (from' k) m
+ lookupIxM s k (RegMap m) = lookupIxT s (from' k) m
+ assocAtM s i (RegMap m) = case assocAtT s i m of
+ (i', k, a) -> (i', to' k, a)
+ updateAtM s f i (RegMap m) = RegMap (updateAtT s (\ i' -> f i' . to') i m)
+ alterM s f k (RegMap m) = RegMap (alterT s f (from' k) m)
+ traverseWithKeyM s f (RegMap m) = RegMap <$> traverseWithKeyT s (f . to') m
+ foldWithKeyM f (RegMap m) = foldWithKeyT (f . to') m
+ foldlWithKeyM f (RegMap m) = foldlWithKeyT (f . to') m
+ mapEitherM s1 s2 f (RegMap m) = (RegMap *** RegMap) (mapEitherT s1 s2 (f . to') m)
+ splitLookupM s f k (RegMap m) = RegMap `sides` splitLookupT s f (from' k) m
+ unionM s f (RegMap m1) (RegMap m2) = RegMap (unionT s (f . to') m1 m2)
+ isectM s f (RegMap m1) (RegMap m2) = RegMap (isectT s (f . to') m1 m2)
+ diffM s f (RegMap m1) (RegMap m2) = RegMap (diffT s (f . to') m1 m2)
+ extractMinM s (RegMap m) = (first to' *** RegMap) `liftM` extractMinT s m
+ extractMaxM s (RegMap m) = (first to' *** RegMap) `liftM` extractMaxT s m
+ alterMinM s f (RegMap m) = RegMap (alterMinT s (f . to') m)
+ alterMaxM s f (RegMap m) = RegMap (alterMaxT s (f . to') m)
+ isSubmapM (<=) (RegMap m1) (RegMap m2) = isSubmapT (<=) m1 m2
+ fromListM s f xs = RegMap (fromListT s (f . to') [(from' k, a) | (k, a) <- xs])
+ fromAscListM s f xs = RegMap (fromAscListT s (f . to') [(from' k, a) | (k, a) <- xs])
+ fromDistAscListM s xs = RegMap (fromDistAscListT s [(from' k, a) | (k, a) <- xs]) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Sized.hs b/Data/TrieMap/Regular/Sized.hs
new file mode 100644
index 0000000..443755c
--- /dev/null
+++ b/Data/TrieMap/Regular/Sized.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE Rank2Types #-}
+
+module Data.TrieMap.Regular.Sized where
+
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Sized
+
+sizeK0 :: Sized (K0 a)
+sizeK0 _ = 1 \ No newline at end of file
diff --git a/Data/TrieMap/Regular/UnionMap.hs b/Data/TrieMap/Regular/UnionMap.hs
new file mode 100644
index 0000000..631ede7
--- /dev/null
+++ b/Data/TrieMap/Regular/UnionMap.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
+
+module Data.TrieMap.Regular.UnionMap() where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+
+import Data.Either
+
+-- import Generics.MultiRec.Base
+data UnionMap m1 m2 k (a :: * -> *) ix = m1 k a ix :&: m2 k a ix
+
+type instance TrieMapT (f :+: g) = UnionMap (TrieMapT f) (TrieMapT g)
+type instance TrieMap ((f :+: g) r) = TrieMapT (f :+: g) r
+
+instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :+: g) (UnionMap m1 m2) where
+ emptyT = emptyT :&: emptyT
+ nullT (m1 :&: m2) = nullT m1 && nullT m2
+ sizeT s (m1 :&: m2) = sizeT s m1 + sizeT s m2
+ lookupT k (m1 :&: m2) = case k of
+ L k -> lookupT k m1
+ R k -> lookupT k m2
+ lookupIxT s k (m1 :&: m2) = case k of
+ L k -> lookupIxT s k m1
+ R k -> first (+ sizeT s m1) <$> lookupIxT s k m2
+ assocAtT s i (m1 :&: m2)
+ | i < s1 = case assocAtT s i m1 of
+ (i', k, a) -> (i', L k, a)
+ | otherwise = case assocAtT s (i - s1) m2 of
+ (i', k, a) -> (i' + s1, R k, a)
+ where s1 = sizeT s m1
+ updateAtT s f i (m1 :&: m2)
+ | i < s1 = updateAtT s (\ i' -> f i' . L) i m1 :&: m2
+ | otherwise = m1 :&: updateAtT s (\ i' -> f (i' + s1) . R) (i - s1) m2
+ where s1 = sizeT s m1
+ alterT s f k (m1 :&: m2) = case k of
+ L k -> alterT s f k m1 :&: m2
+ R k -> m1 :&: alterT s f k m2
+ traverseWithKeyT s f (m1 :&: m2) = (:&:) <$> traverseWithKeyT s (f . L) m1 <*> traverseWithKeyT s (f . R) m2
+ foldWithKeyT f (m1 :&: m2) = foldWithKeyT (f . L) m1 . foldWithKeyT (f . R) m2
+ foldlWithKeyT f (m1 :&: m2) = foldlWithKeyT (f . R) m2 . foldlWithKeyT (f . L) m1
+ mapEitherT s1 s2 f (m1 :&: m2) = case (mapEitherT s1 s2 (f . L) m1, mapEitherT s1 s2 (f . R) m2) of
+ ((m1L, m1R), (m2L, m2R)) -> (m1L :&: m2L, m1R :&: m2R)
+ splitLookupT s f k (m1 :&: m2) = case k of
+ L k -> case splitLookupT s f k m1 of
+ (m1L, ans, m1R) -> (m1L :&: emptyT, ans, m1R :&: m2)
+ R k -> case splitLookupT s f k m2 of
+ (m2L, ans, m2R) -> (m1 :&: m2L, ans, emptyT :&: m2R)
+ unionT s f (m11 :&: m12) (m21 :&: m22) = unionT s (f . L) m11 m21 :&: unionT s (f . R) m12 m22
+ isectT s f (m11 :&: m12) (m21 :&: m22) = isectT s (f . L) m11 m21 :&: isectT s (f . R) m12 m22
+ diffT s f (m11 :&: m12) (m21 :&: m22) = diffT s (f . L) m11 m21 :&: diffT s (f . R) m12 m22
+ extractMinT s (m1 :&: m2) = (do
+ ((k, a), m1') <- extractMinT s m1
+ return ((L k, a), m1' :&: m2)) `mplus`
+ (do ((k, a), m2') <- extractMinT s m2
+ return ((R k, a), m1 :&: m2'))
+ extractMaxT s (m1 :&: m2) = (do
+ ((k, a), m1') <- extractMaxT s m1
+ return ((L k, a), m1' :&: m2)) `mplus`
+ (do ((k, a), m2') <- extractMaxT s m2
+ return ((R k, a), m1 :&: m2'))
+ alterMinT s f (m1 :&: m2)
+ | nullT m1 = m1 :&: alterMinT s (f . R) m2
+ | otherwise = alterMinT s (f . L) m1 :&: m2
+ alterMaxT s f (m1 :&: m2)
+ | nullT m2 = alterMaxT s (f . L) m1 :&: m2
+ | otherwise = m1 :&: alterMaxT s (f . R) m2
+ isSubmapT (<=) (m11 :&: m12) (m21 :&: m22) = isSubmapT (<=) m11 m21 && isSubmapT (<=) m12 m22
+ fromListT s f xs = case partEithers xs of
+ (ys, zs) -> fromListT s (f . L) ys :&: fromListT s (f . R) zs
+ fromAscListT s f xs = case partEithers xs of
+ (ys, zs) -> fromAscListT s (f . L) ys :&: fromAscListT s (f . R) zs
+ fromDistAscListT s xs = case partEithers xs of
+ (ys, zs) -> fromDistAscListT s ys :&: fromDistAscListT s zs
+
+partEithers :: [((f :+: g) r, a)] -> ([(f r, a)], [(g r, a)])
+partEithers = foldr part ([], []) where
+ part (L k, a) (xs, ys) = ((k, a):xs, ys)
+ part (R k, a) (xs, ys) = (xs, (k, a):ys)
+
+instance (TrieKeyT f m1, TrieKeyT g m2, TrieKey k (TrieMap k)) => TrieKey ((f :+: g) k) (UnionMap m1 m2 k) where
+ emptyM = emptyT
+ nullM = nullT
+ lookupM = lookupT
+ lookupIxM = lookupIxT
+ assocAtM = assocAtT
+ updateAtM = updateAtT
+ alterM = alterT
+ traverseWithKeyM = traverseWithKeyT
+ foldWithKeyM = foldWithKeyT
+ foldlWithKeyM = foldlWithKeyT
+ mapEitherM = mapEitherT
+ splitLookupM = splitLookupT
+ unionM = unionT
+ isectM = isectT
+ diffM = diffT
+ extractMinM = extractMinT
+ extractMaxM = extractMaxT
+ alterMinM = alterMinT
+ alterMaxM = alterMaxT
+ isSubmapM = isSubmapT
+ fromListM = fromListT
+ fromAscListM = fromAscListT
+ fromDistAscListM = fromDistAscListT \ No newline at end of file
diff --git a/Data/TrieMap/Regular/UnitMap.hs b/Data/TrieMap/Regular/UnitMap.hs
new file mode 100644
index 0000000..e5a62eb
--- /dev/null
+++ b/Data/TrieMap/Regular/UnitMap.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
+
+module Data.TrieMap.Regular.UnitMap() where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+
+import Data.Foldable
+import Data.Maybe
+import Data.Monoid
+import Data.Traversable
+
+import Prelude hiding (foldr, foldl)
+
+newtype M k a ix = M (Maybe (a ix))
+type instance TrieMapT U0 = M
+type instance TrieMap (U0 r) = M r
+
+instance TrieKey (U0 r) (M r) where
+ emptyM = M Nothing
+ nullM (M a) = isNothing a
+ sizeM s (M a) = maybe 0 s a
+ lookupM _ (M a) = a
+ lookupIxM s _ (M a) = fmap ((,) 0) a
+ assocAtM s i (M (Just v)) = (0, U0, v)
+ updateAtM s f i (M v) = M (v >>= f 0 U0)
+ alterM _ f _ (M a) = M (f a)
+ traverseWithKeyM _ f (M a) = M <$> traverse (f U0) a
+ foldWithKeyM f (M a) z = foldr (f U0) z a
+ foldlWithKeyM f (M a) z = foldl (f U0) z a
+ mapEitherM _ _ f (M Nothing) = (M Nothing, M Nothing)
+ mapEitherM _ _ f (M (Just a)) = (M *** M) (f U0 a)
+ splitLookupM _ f _ (M a) = M `sides` maybe (Nothing, Nothing, Nothing) f a
+ unionM _ f (M a) (M b) = M (unionMaybe (f U0) a b)
+ isectM _ f (M a) (M b) = M (isectMaybe (f U0) a b)
+ diffM _ f (M a) (M b) = M (diffMaybe (f U0) a b)
+ extractMinM _ (M a) = do a <- First a
+ return ((U0, a), M Nothing)
+ extractMaxM _ (M a) = do a <- Last a
+ return ((U0, a), M Nothing)
+ alterMinM _ f (M a) = M (a >>= f U0)
+ alterMaxM = alterMinM
+ isSubmapM (<=) (M a) (M b) = subMaybe (<=) a b
+ fromListM _ f = M . foldr (\ (_, a) -> Just . maybe a (f U0 a)) Nothing
+ fromDistAscListM _ = M . fmap snd . listToMaybe
+
+instance TrieKeyT U0 M where
+ emptyT = emptyM
+ nullT = nullM
+ sizeT = sizeM
+ lookupT = lookupM
+ lookupIxT = lookupIxM
+ assocAtT = assocAtM
+ updateAtT = updateAtM
+ alterT = alterM
+ traverseWithKeyT = traverseWithKeyM
+ foldWithKeyT = foldWithKeyM
+ foldlWithKeyT = foldlWithKeyM
+ mapEitherT = mapEitherM
+ splitLookupT = splitLookupM
+ unionT = unionM
+ isectT = isectM
+ diffT = diffM
+ extractMinT = extractMinM
+ extractMaxT = extractMaxM
+ alterMinT = alterMinM
+ alterMaxT = alterMaxM
+ isSubmapT = isSubmapM
+ fromListT = fromListM
+ fromAscListT = fromAscListM
+ fromDistAscListT = fromDistAscListM \ No newline at end of file
diff --git a/Data/TrieMap/Sized.hs b/Data/TrieMap/Sized.hs
new file mode 100644
index 0000000..153ec6d
--- /dev/null
+++ b/Data/TrieMap/Sized.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE Rank2Types #-}
+
+module Data.TrieMap.Sized where
+
+-- class Sized f where
+-- getSize :: f a -> Int
+--
+-- newtype Elem a = Elem {getElem :: a}
+--
+-- instance Sized Elem where
+-- getSize _ = 1
+
+type Sized f = forall ix . f ix -> Int
+
+newtype Elem a = Elem {getElem :: a}
+
+elemSize :: Sized Elem
+elemSize _ = 1 \ No newline at end of file
diff --git a/Data/TrieMap/TrieKey.hs b/Data/TrieMap/TrieKey.hs
new file mode 100644
index 0000000..b5af1a6
--- /dev/null
+++ b/Data/TrieMap/TrieKey.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE Rank2Types, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, KindSignatures #-}
+
+module Data.TrieMap.TrieKey where
+
+import Data.TrieMap.Applicative
+import Data.TrieMap.Sized
+
+import Control.Applicative
+
+import Data.Monoid
+
+type family TrieMap k :: (* -> *) -> * -> *
+-- data Fixer f
+
+type EitherMap k a b c = k -> a -> (Maybe b, Maybe c)
+type SplitMap a x = a -> (Maybe a, Maybe x, Maybe a)
+type UnionFunc k a = k -> a -> a -> Maybe a
+type IsectFunc k a b c = k -> a -> b -> Maybe c
+type DiffFunc k a b = k -> a -> b -> Maybe a
+type ExtractFunc k f a m = m -> f ((k, a), m)
+type LEq a b = a -> b -> Bool
+-- type Sized f = forall ix . f ix -> Int
+
+-- toFixer :: a -> Fixer a
+-- toFixer _ = undefined
+
+class Ord k => TrieKey k m | k -> m, m -> k where
+ emptyM :: TrieMap k ~ m => m a ix
+ nullM :: TrieMap k ~ m => m a ix -> Bool
+ sizeM :: (TrieMap k ~ m) => Sized a -> m a ix -> Int
+ lookupM :: TrieMap k ~ m => k -> m a ix -> Maybe (a ix)
+ lookupIxM :: TrieMap k ~ m => Sized a -> k -> m a ix -> Maybe (Int, a ix)
+ assocAtM :: TrieMap k ~ m => Sized a -> Int -> m a ix -> (Int, k, a ix)
+ updateAtM :: TrieMap k ~ m => Sized a -> (Int -> k -> a ix -> Maybe (a ix)) -> Int -> m a ix -> m a ix
+ alterM :: (TrieMap k ~ m) => Sized a -> (Maybe (a ix) -> Maybe (a ix)) -> k -> m a ix -> m a ix
+ {-# SPECIALIZE traverseWithKeyM :: (k -> a ix -> Id (b ix)) -> m a ix -> Id (m b ix) #-}
+ traverseWithKeyM :: (TrieMap k ~ m, Applicative f) => (forall ix . b ix -> Int) ->
+ (k -> a ix -> f (b ix)) -> m a ix -> f (m b ix)
+ foldWithKeyM :: TrieMap k ~ m => (k -> a ix -> b -> b) -> m a ix -> b -> b
+ foldlWithKeyM :: TrieMap k ~ m => (k -> b -> a ix -> b) -> m a ix -> b -> b
+ mapEitherM :: (TrieMap k ~ m) => Sized b -> Sized c -> EitherMap k (a ix) (b ix) (c ix) -> m a ix -> (m b ix, m c ix)
+ splitLookupM :: (TrieMap k ~ m) => Sized a -> SplitMap (a ix) x -> k -> m a ix -> (m a ix, Maybe x, m a ix)
+ unionM :: (TrieMap k ~ m) => Sized a -> UnionFunc k (a ix) -> m a ix -> m a ix -> m a ix
+ isectM :: (TrieMap k ~ m) => Sized c -> IsectFunc k (a ix) (b ix) (c ix) -> m a ix -> m b ix -> m c ix
+ diffM :: (TrieMap k ~ m) => Sized a -> DiffFunc k (a ix) (b ix) -> m a ix -> m b ix -> m a ix
+ extractMinM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k First (a ix) (m a ix)
+ extractMaxM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k Last (a ix) (m a ix)
+ alterMinM, alterMaxM :: (TrieMap k ~ m) => Sized a -> (k -> a ix -> Maybe (a ix)) -> m a ix -> m a ix
+ isSubmapM :: TrieMap k ~ m => LEq (a ix) (b ix) -> LEq (m a ix) (m b ix)
+ fromListM, fromAscListM :: (TrieMap k ~ m) => Sized a -> (k -> a ix -> a ix -> a ix) -> [(k, a ix)] -> m a ix
+ fromDistAscListM :: (TrieMap k ~ m) => Sized a -> [(k, a ix)] -> m a ix
+
+ sizeM s m = foldWithKeyM (\ _ a n -> s a + n) m 0
+ fromListM s f = foldr (uncurry (insertWithKeyM s f)) emptyM
+ fromAscListM = fromListM
+ fromDistAscListM s = fromAscListM s (const const)
+ updateAtM s f i m = case assocAtM s i m of
+ (i', k, a) -> alterM s (const (f i' k a)) k m
+
+guardNullM :: (TrieKey k m, m ~ TrieMap k) => m a ix -> Maybe (m a ix)
+guardNullM m
+ | nullM m = Nothing
+ | otherwise = Just m
+
+sides :: (a -> c) -> (a, b, a) -> (c, b, c)
+sides f (l, x, r) = (f l, x, f r)
+
+mapMaybeM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a ix -> Maybe (b ix)) -> m a ix -> m b ix
+mapMaybeM s f = snd . mapEitherM elemSize s (((,) (Nothing :: Maybe (Elem ix))) .: f)
+
+mapWithKeyM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a ix -> b ix) -> m a ix -> m b ix
+mapWithKeyM s f = unId . traverseWithKeyM s (Id .: f)
+
+mapM :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (a ix -> b ix) -> m a ix -> m b ix
+mapM s = mapWithKeyM s . const
+
+assocsM :: (TrieKey k m, m ~ TrieMap k) => m a ix -> [(k, a ix)]
+assocsM m = foldWithKeyM (\ k a xs -> (k, a):xs) m []
+
+insertM :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a ix -> m a ix -> m a ix
+insertM s = insertWithKeyM s (const const)
+
+insertWithKeyM :: (TrieKey k m, m ~ TrieMap k) => Sized a -> (k -> a ix -> a ix -> a ix) -> k -> a ix -> m a ix -> m a ix
+insertWithKeyM s f k a = alterM s f' k where
+ f' = Just . maybe a (f k a)
+
+singletonM :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a ix -> m a ix
+singletonM s k a = insertM s k a emptyM
+
+fromListM' :: (TrieKey k m, m ~ TrieMap k) => Sized a -> [(k, a ix)] -> m a ix
+fromListM' s = fromListM s (const const) --xs = foldr (uncurry insertM) emptyM xs
+
+unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
+unionMaybe _ Nothing y = y
+unionMaybe _ x Nothing = x
+unionMaybe f (Just x) (Just y) = f x y
+
+isectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
+isectMaybe f (Just x) (Just y) = f x y
+isectMaybe _ _ _ = Nothing
+
+diffMaybe :: (a -> b -> Maybe a) -> Maybe a -> Maybe b -> Maybe a
+diffMaybe f Nothing = const Nothing
+diffMaybe f (Just x) = maybe (Just x) (f x)
+
+subMaybe :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
+subMaybe _ Nothing _ = True
+subMaybe (<=) (Just a) (Just b) = a <= b
+subMaybe _ _ _ = False \ No newline at end of file
diff --git a/LICENSE b/LICENSE
index ae885ba..3b2c3c9 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2009, Louis Wasserman
+Copyright (c) 2008, Louis Wasserman
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
diff --git a/TrieMap.cabal b/TrieMap.cabal
index ab56554..ed92edb 100644
--- a/TrieMap.cabal
+++ b/TrieMap.cabal
@@ -1,33 +1,51 @@
-name: TrieMap
-version: 0.0.1.2
-license: BSD3
-license-file: LICENSE
-maintainer: wasserman.louis@gmail.com
-category: Data Structures
-synopsis: An implementation of generalized tries with sophisticated map type inference.
-description: Generalized trie implementation that automatically infers map types. Keys must implement the class 'TrieMap.Algebraic.Algebraic', which
- declares that they are isomorphic to an /algebraic type/,
- defined recursively as follows:
- .
- * () and 'Int' are algebraic types.
- .
- * If @'Ord' a@, then @'Ordered' a@ is an algebraic type.
- .
- * If @a,b@ are algebraic types, then so are @(a, b)@ and @Either a b@.
- .
- * If @a@ is algebraic, so is @[a]@.
- .
- This package exports almost the entire collection of methods available in Data.Map, and several new methods as well. In addition, each method will automatically infer the correct map type.
-
-build-type: Simple
-build-depends:
- base >= 4 && <= 5, containers == 0.2.0.1, bytestring
-exposed-modules:
- TrieMap
- TrieMap.Algebraic
+name: TrieMap
+version: 0.5.0
+tested-with: GHC
+category: Algorithms
+synopsis: Automatic type inference of generalized tries.
+description: Builds on the multirec library to create a system capable of automatic or simple generalized trie type inference.
+license: BSD3
+license-file: LICENSE
+author: Louis Wasserman
+maintainer: wasserman.louis@gmail.com
+build-Depends: base < 5.0.0.0, containers, multirec
+build-type: Simple
+exposed-modules:
+ Data.TrieMap,
+ Data.TrieMap.Class,
+ Data.TrieMap.Regular,
+ Data.TrieMap.MultiRec
+ -- Data.TrieMap.TrieKey
other-modules:
- TrieMap.TrieAlgebraic
- TrieMap.Applicative
- TrieMap.Reflection
- TrieMap.RadixTrie
- TrieMap.MapTypes
+ Data.TrieMap.Class.Instances,
+ Data.TrieMap.TrieKey,
+ Data.TrieMap.Applicative,
+ Data.TrieMap.MultiRec.FamMap,
+ Data.TrieMap.MultiRec.Eq,
+ Data.TrieMap.MultiRec.Ord,
+ Data.TrieMap.MultiRec.Class,
+ Data.TrieMap.MultiRec.ConstMap,
+ Data.TrieMap.MultiRec.IMap,
+ Data.TrieMap.MultiRec.Instances,
+ Data.TrieMap.MultiRec.ProdMap,
+ Data.TrieMap.MultiRec.TagMap,
+ Data.TrieMap.MultiRec.UnionMap,
+ Data.TrieMap.MultiRec.UnitMap,
+ Data.TrieMap.MultiRec.Sized,
+ Data.TrieMap.Regular.Base,
+ Data.TrieMap.Regular.Class,
+ Data.TrieMap.Regular.ConstMap,
+ Data.TrieMap.Regular.Eq,
+ Data.TrieMap.Regular.IdMap,
+ Data.TrieMap.Regular.Instances,
+ Data.TrieMap.Regular.Ord,
+ Data.TrieMap.Regular.ProdMap,
+ Data.TrieMap.Regular.RadixTrie,
+ Data.TrieMap.Regular.UnitMap,
+ Data.TrieMap.Regular.RegMap,
+ Data.TrieMap.Regular.UnionMap,
+ Data.TrieMap.Regular.Sized,
+ Data.TrieMap.IntMap,
+ Data.TrieMap.OrdMap,
+ Data.TrieMap.Sized,
+ Data.TrieMap.Applicative
diff --git a/TrieMap.hs b/TrieMap.hs
deleted file mode 100644
index db36022..0000000
--- a/TrieMap.hs
+++ /dev/null
@@ -1,954 +0,0 @@
-{-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleContexts, TypeFamilies #-}
-
--- | We will use the following terminology:
---
--- An /algebraic/ type is a type isomorphic to an algebraic type, as defined in the package description. This isomorphism is
--- declared via the type class 'Algebraic', where @'AlgRep' k@ is algebraic. It is assumed for purposes of ordering that
--- this isomorphism is order- and equality-preserving. We also require that if @k@ is algebraic, @'AlgRep' k ~ k@.
---
--- These methods will automatically infer the correct type of a 'TrieMap' on any given argument. For example,
---
--- @'fromList' [((\"alphabet\", 'Just' (0.2 :: 'Double'), 'True'), \"wxyz\")]@
---
--- returns a variable of type
---
--- @'TrieMap' ('String', 'Double', 'Bool') ('ProdMap' ('ConstMap' ('RadixTrie' 'Int' 'IntMap')) ('ProdMap' ('ConstMap' ('UnionMap' ('ConstMap' 'Maybe') 'IdMap' ('Ordered' 'Double') ('Map' 'Double'))) 'IdMap') (('Const' () :+: 'Id') '()') ('UnionMap' ('ConstMap' 'Maybe') 'IdMap' () 'Maybe')) 'String'@
---
--- The inference was done entirely automatically. Note also:
---
--- * @'AlgRep' 'Char' ~ 'Int'@: the 'Algebraic' instance for 'Char' maps characters to their ASCII representations, so an 'IntMap' can be used.
---
--- * @'AlgRep' ('Maybe' a) ~ 'Either' () ('AlgRep' a)@; a 'TrieMap' on a 'Maybe' key type simply gets a space for one extra (possible) value.
---
--- * @'AlgRep' 'Double' ~ 'Ordered' 'Double'@; the 'Algebraic' instance for 'Double' tells "TrieMap" to just use a regular 'Data.Map.Map'
--- and the default ordering for 'Double's.
---
--- * @'AlgRep' 'Bool' ~ 'Either' () ()@, so a 'TrieMap' on a 'Bool' takes the form of -- essentially -- a pair of 'Maybe's.
---
--- * @'AlgRep' (a, b, c) ~ ('AlgRep' a, ('AlgRep' b, 'AlgRep' c))@, so tuple types get handled by a sequence of map products.
---
--- (If you plan to use these maps in type arguments, it is strongly suggested that you either reproduce the context
--- @('Algebraic' k, 'TrieKey' ('AlgRep' k) m) => TrieMap k m a@, or you create a type alias!)
---
-
--- The following is a general attempt to describe the runtime of operations supported by 'TrieMap's.
---
--- * Lookup operations take /O(log n)/ for 'Ordered' keys, /O(max(log n, W))/ for 'Int' keys, /O(l)/ times lookup cost for @k@
--- for keys of type @[k]@, and otherwise will take @O(1)@ over the total cost of their components.
---
--- * Insertion operations take roughly the same asymptotic time as lookup operations.
---
--- * Traversal operations take /O(n)/ for all map types, with obviously greater overhead for use of specialized
--- 'Applicative' functors.
---
--- * Set operations (union, intersection, difference) take /O(m + n)/ in all cases.
-
-module TrieMap (
- -- * Map type
- TrieMap,
- Algebraic (..),
- AlgebraicT (..),
- TrieKey,
- TrieKeyT,
- EqT,
- -- * Map instances
- ProdMap, (:*:)(..), CProdMap, UnionMap, (:+:)(..), CUnionMap, RadixTrie, ConstMap, Const(..), IdMap, Id(..), CompMap, O, o, unO, FixMap, Fix(..),
- -- * Operators
- (!),
- (\\),
- -- * Query
- null,
- size,
- member,
- notMember,
- lookup,
- find,
- findWithDefault,
- -- * Construction
- empty,
- singleton,
- -- * Insertion
- insert,
- insertWith,
- insertWithKey,
- insertLookupWithKey,
- -- * Delete/Update
- delete,
- update,
- updateWithKey,
- updateLookupWithKey,
- alter,
- alterLookup,
- -- * Combine
- -- ** Union/Symmetric Difference
- union,
- unionWith,
- unionWithKey,
- unions,
- unionsWith,
- unionsWithKey,
- unionMaybeWith,
- unionMaybeWithKey,
- symDifference,
- -- ** Intersection
- intersection,
- intersectionWith,
- intersectionWithKey,
- intersectionMaybeWith,
- intersectionMaybeWithKey,
- -- ** Difference
- difference,
- differenceWith,
- differenceWithKey,
- -- * Traversal
- -- ** Map
- map,
- mapWithKey,
- traverseWithKey,
- mapMaybe,
- mapMaybeWithKey,
- mapEither,
- mapEitherWithKey,
- mapKeys,
- mapKeysWith,
- mapKeysMonotonic,
- -- ** Fold
- fold,
- foldWithKey,
- -- * Conversion
- elems,
- keys,
- assocs,
- -- ** Lists
- fromList,
- fromListWith,
- fromListWithKey,
- -- ** Ordered lists
- fromAscList,
- fromAscListWith,
- fromAscListWithKey,
- fromDistinctAscList,
- -- * Filter
- filter,
- filterWithKey,
- partition,
- partitionWithKey,
- split,
- splitLookup,
- -- * Submap
- isSubmapOf,
- isSubmapOfBy,
- -- * Min/Max
- findMin,
- getMin,
- findMax,
- getMax,
- deleteMin,
- deleteMax,
- deleteFindMin,
- deleteFindMax,
- updateMin,
- updateMax,
- updateMinWithKey,
- updateMaxWithKey,
- minView,
- maxView,
- minViewWithKey,
- maxViewWithKey) where
--- module TrieMap where
-
-import Control.Monad
-import Data.Monoid
-import Data.Traversable
-import TrieMap.MapTypes
-import TrieMap.Applicative
-import TrieMap.Algebraic
-import TrieMap.TrieAlgebraic
-import TrieMap.RadixTrie
-import TrieMap.Reflection
-import Control.Applicative hiding (Alternative(..), Const)
-import Data.Maybe hiding (mapMaybe)
-import Data.Map (Map)
-import Data.IntMap (IntMap)
-import Data.Foldable hiding (fold, find)
-import GHC.Exts
--- import TrieMap.FixPoint
--- import TrieMap.FixPoint.Algebraic
--- import TrieMap.Reflection
-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 (Elem a)}
-
-instance (Eq k, Eq a, Algebraic k, TrieKey (AlgRep k) m) => Eq (TrieMap k m a) where
- (==) = (==) `on` assocs
-
-instance (Ord k, Ord a, Algebraic k, TrieKey (AlgRep k) m) => Ord (TrieMap k m a) where
- compare = compare `on` assocs
-
-instance (Show k, Show a, Algebraic k, TrieKey (AlgRep k) m) => Show (TrieMap k m a) where
- show m = "fromList " ++ show (assocs m)
-
--- instance (Algebraic k, Algebraic a, TrieKey (AlgRep k) m) => Algebraic (TrieMap k m a) where
--- type AlgRep (TrieMap k m a) = ([(AlgRep k, AlgRep 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 SAlgebraicT m => AlgebraicT (TrieMap k m) where
- type AlgRepT (TrieMap k m) = SAlgRepT m :*: Const Int
- toAlgT (TrieMap n m) = fmap getElem (toSAlgT m) :*: Const n
- fromAlgT (m :*: Const n) = TrieMap n (fromSAlgT (fmap Elem m))
-
-instance Algebraic (m (Elem a)) => Algebraic (TrieMap k m a) where
- type AlgRep (TrieMap k m a) = AlgRep (m (Elem a), Int)
- toAlg (TrieMap n m) = toAlg (m, n)
- fromAlg = uncurry (flip TrieMap) . fromAlg
-{-
-instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m) => AlgebraicT (TrieMap k m) where
- type AlgRepT (TrieMap k m) = AlgRepT ([] `O` ((,) (AlgRep k)))
- toAlgT (TrieMap _ m) = toAlgT (o (fmap (fmap getElem) (assocsAlg m)))
- fromAlgT = mkTrieMap . fromDistAscListAlg . fmap (fmap Elem) . unO . fromAlgT
-
-instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m, Algebraic a) => Algebraic (TrieMap k m a) where
- type AlgRep (TrieMap k m a) = AlgRep (AlgWrap (TrieMap k m) a)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg-}
-
-
-instance TrieKey k' m => Functor (TrieMap k m) where
- fmap = fmapDefault
-
-instance TrieKey k' m => Foldable (TrieMap k m) where
- foldr f z = foldWithKeyAlg (\ _ (Elem x) z -> f x z) z . trieMap
-
-instance TrieKey k' m => Traversable (TrieMap k m) where
- traverse f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ _ (Elem v) -> Elem <$> f v) m
-
-instance (Algebraic k, TrieKey (AlgRep k) m) => Monoid (TrieMap k m a) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-mkTrieMap :: (Algebraic k, TrieKey (AlgRep k) m) => m (Elem a) -> TrieMap k m a
-mkTrieMap m = TrieMap (sizeAlg m) m
-
--- | Lookup the value of a key in the map.
---
--- The function will return the corresponding value as @('Just' value)@,
--- or 'Nothing' if the key isn't in the map.
-lookup :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Maybe a
-lookup k = fmap getElem . lookupAlg (toAlg k) . trieMap
-
--- | Is the key a member of the map? See also 'notMember'.
---
--- > member 5 (fromList [(5,'a'), (3,'b')]) == True
--- > member 1 (fromList [(5,'a'), (3,'b')]) == False
-member :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Bool
-member = isJust .: lookup
-
--- | Is the key not a member of the map? See also 'member'.
---
--- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
-notMember :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Bool
-notMember = not .: member
-
--- | Find the value at a key.
--- Calls 'error' when the element can not be found.
-
-find :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> a
-find = findWithDefault $ error "TrieMap.find: element not in the map"
-
--- | The expression @('findWithDefault' def k map)@ returns
--- the value at key @k@ or returns default value @def@
--- when the key is not in the map.
---
--- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
-findWithDefault :: (Algebraic k, TrieKey (AlgRep k) m) => a -> k -> TrieMap k m a -> a
-findWithDefault v = fromMaybe v .: lookup
-
--- | /O(1)/. A map with a single element.
---
--- > singleton 1 'a' == fromList [(1, 'a')]
-singleton :: (Algebraic k, TrieKey (AlgRep k) m) => k -> a -> TrieMap k m a
-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.
---
--- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
-(!) :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> k -> a
-m ! k = fromMaybe (error "element not in the map") (lookup k m)
-
-empty :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a
-empty = TrieMap 0 emptyAlg
-
--- | Check if the specified map is empty.
-null :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Bool
-null = nullAlg . trieMap
-
--- | Returns the size of the specified map.
-size :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Int
-size = sizeMap
-
--- | Build a map from a list of key\/value pairs. See also 'fromAscList'.
--- If the list contains more than one value for the same key, the last value
--- for the key is retained.
---
--- > fromList [] == empty
--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
-fromList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
-fromList = fromListWith const
-
--- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
---
--- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
--- > fromListWith (++) [] == empty
-fromListWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
-fromListWith = fromListWithKey . const
-
--- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
---
--- > let f k a1 a2 = (show k) ++ a1 ++ a2
--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
--- > fromListWithKey f [] == empty
-fromListWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
-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./
---
--- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
-fromAscList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
-fromAscList = fromAscListWith const
-
--- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
---
--- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
-fromAscListWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
-fromAscListWith = fromAscListWithKey . const
-
--- | /O(n)/. Build a map from an ascending list in linear time with a
--- combining function for equal keys.
--- /The precondition (input list is ascending) is not checked./
---
--- > 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 (AlgRep k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
-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 (AlgRep k) m) => [(k, a)] -> TrieMap k m a
-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
--- replaced with the supplied value. 'insert' is equivalent to
--- @'insertWith' 'const'@.
---
--- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
--- > insert 5 'x' empty == singleton 5 'x'
-insert :: (Algebraic k, TrieKey (AlgRep k) m) => k -> a -> TrieMap k m a -> TrieMap k m a
-insert = insertWith const
-
--- | Insert with a function, combining new value and old value.
--- @'insertWith' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key, f new_value old_value)@.
---
--- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
--- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
-insertWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
-insertWith = insertWithKey . const
-
--- | Insert with a function, combining key, new value and old value.
--- @'insertWithKey' f key value mp@
--- will insert the pair (key, value) into @mp@ if key does
--- not exist in the map. If the key does exist, the function will
--- insert the pair @(key,f key new_value old_value)@.
--- Note that the key passed to f is the same key passed to 'insertWithKey'.
---
--- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
--- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
-insertWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
-insertWithKey f k = snd .: insertLookupWithKey f k
-
--- | Combines insert operation with old value retrieval.
--- The expression (@'insertLookupWithKey' f k x map@)
--- 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 (AlgRep 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 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
--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
---
--- > let f x = if x == "a" then Just "new a" else Nothing
--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-update :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
-update = updateWithKey . const
-
--- | The expression (@'updateWithKey' f k map@) updates the
--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
--- to the new value @y@.
---
--- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
-updateWithKey f = snd .: updateLookupWithKey f
-
--- | Lookup and update. See also 'updateWithKey'.
--- The function returns changed value, if it is updated.
--- Returns the original key value if the map entry is deleted.
---
--- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
-updateLookupWithKey :: (Algebraic k, TrieKey (AlgRep 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 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.
---
--- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > delete 5 empty == empty
---
--- 'delete' is equivalent to @'alter' ('const' 'Nothing')@.
-delete :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> TrieMap k m a
-delete = alter (const Nothing)
-
--- | The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
--- 'alter' can be used to insert, delete, or update a value in a 'Map'.
--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
---
--- > let f _ = Nothing
--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- >
--- > let f _ = Just "c"
--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
-alter :: (Algebraic k, TrieKey (AlgRep k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
-alter f k = snd . alterLookup f k
-
--- | The expression (@'alterLookup' f k map@) alters the value @x@ at @k@, or absence thereof, and returns the old value.
--- 'alterLookup' can be used to insert, delete, or update a value in a 'Map'.
---
--- In short : @alterLookup f k m = (lookup k m, alter f k m)@.
-alterLookup :: (Algebraic k, TrieKey (AlgRep 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 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.
---
--- > let f key x = (show key) ++ ":" ++ x
--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
-mapWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b) -> TrieMap k m a -> TrieMap k m b
-mapWithKey f = unId . traverseWithKey (Id .: f)
-
--- | /O(n)/. Map a function over all values in the map.
---
--- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
-map :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b) -> TrieMap k m a -> TrieMap k m b
-map = mapWithKey . const
-
--- | Essentially equivalent to 'traverse' with a function that takes both the key and the value as arguments.
-traverseWithKey :: (Algebraic k, TrieKey (AlgRep k) m, Applicative f) =>
- (k -> a -> f b) -> TrieMap k m a -> f (TrieMap k m b)
-traverseWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) m
-
--- | /O(n)/. Map keys\/values and collect the 'Just' results.
---
--- > 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 (AlgRep k) m) => (k -> a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
-mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) . trieMap
-
--- | /O(n)/. Map values and collect the 'Just' results.
---
--- > let f x = if x == "a" then Just "new a" else Nothing
--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
-mapMaybe :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
-mapMaybe = mapMaybeWithKey . const
-
--- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
---
--- > let f a = if a < "c" then Left a else Right a
--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
--- >
--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
-mapEither :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
-mapEither = mapEitherWithKey . const
-
--- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
---
--- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
--- >
--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
--- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
-mapEitherWithKey :: (Algebraic k, TrieKey (AlgRep 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 (\ k (Elem v) ->
- either (\ k -> (Just (Elem k), Nothing)) (\ k -> (Nothing, Just (Elem k))) (f (fromAlg k) v))
- m
-
--- |
--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the value at the smallest of
--- these keys is retained.
---
--- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
-mapKeys :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
- (k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
-mapKeys = mapKeysWith const
-
--- |
--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
---
--- The size of the result may be smaller if @f@ maps two or more distinct
--- keys to the same new key. In this case the associated values will be
--- combined using @c@.
---
--- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
-mapKeysWith :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
- (a -> a -> a) -> (k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
-mapKeysWith f g m = fromListWith f [(g k, v) | (k, v) <- assocs m]
-
--- | /O(n)/.
--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
--- is strictly monotonic.
--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
--- /The precondition is not checked./
--- Semi-formally, we have:
---
--- > and [x < y ==> f x < f y | x <- ls, y <- ls]
--- > ==> mapKeysMonotonic f s == mapKeys f s
--- > where ls = keys s
---
--- This means that @f@ maps distinct original keys to distinct resulting keys.
--- This function has better performance than 'mapKeys'.
---
--- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
--- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
--- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False
-mapKeysMonotonic :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
- (k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
-mapKeysMonotonic f (TrieMap n m) = TrieMap n $ fromDistAscListAlg [(toAlg (f (fromAlg k)), v) | (k, v) <- assocsAlg m]
-
--- | /O(n)/. Filter all keys\/values that satisfy the predicate.
---
--- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-filterWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Bool) -> TrieMap k m a -> TrieMap k m a
-filterWithKey p = mapMaybeWithKey (\ k v -> if p k v then Just v else Nothing)
-
--- | /O(n)/. Filter all values that satisfy the predicate.
---
--- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
-filter :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Bool) -> TrieMap k m a -> TrieMap k m a
-filter = filterWithKey . const
-
--- | /O(n)/. Partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate.
---
--- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-partition :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
-partition = partitionWithKey . const
-
--- | /O(n)/. Partition the map according to a predicate. The first
--- map contains all elements that satisfy the predicate, the second all
--- elements that fail the predicate.
---
--- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-partitionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
-partitionWithKey p = mapEitherWithKey (\ k v -> (if p k v then Left else Right) v)
-
-{-# INLINE assocs #-}
--- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
---
--- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
--- > assocs empty == []
-assocs :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [(k, a)]
-assocs m = build (\ c n -> foldWithKey (curry c) n m)
-
--- | /O(n)/. Return all keys of the map in ascending order.
---
--- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
--- > keys empty == []
-keys :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [k]
-keys m = Prelude.map fst (assocs m)
-
--- | /O(n)/.
--- Return all elements of the map in the ascending order of their keys.
---
--- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
--- > elems empty == []
-elems :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [a]
-elems = toList
-
--- | /O(n)/. Fold the values in the map, such that
--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
--- For example,
---
--- > elems map = fold (:) [] map
---
--- > let f a len = len + (length a)
--- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
-fold :: TrieKey k m => (a -> b -> b) -> b -> TrieMap k m a -> b
-fold = foldr
-
--- | /O(n)/. Fold the keys and values in the map, such that
--- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'assocs'@.
--- For example,
---
--- > keys map = foldWithKey (\k x ks -> k:ks) [] map
---
--- > 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 (AlgRep k) m) => (k -> a -> b -> b) -> b -> TrieMap k m a -> b
-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 (AlgRep k) m) => (k -> a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-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.
---
--- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
-unionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-unionWithKey f = unionMaybeWithKey (\ k x y -> Just (f k x y))
-
--- | /O(n+m)/. Union with a combining function.
---
--- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
-unionWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-unionWith = unionWithKey . const
-
--- | /O(n+m)/. Union with a combining function that may discard some elements.
-unionMaybeWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-unionMaybeWith = unionMaybeWithKey . const
-
--- | /O(n+m)/.
--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
--- It prefers @t1@ when duplicate keys are encountered,
--- i.e. (@'union' == 'unionWith' 'const'@).
---
--- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
-union :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-union = unionWith const
-
-unions :: (Algebraic k, TrieKey (AlgRep k) m) => [TrieMap k m a] -> TrieMap k m a
-unions = unionsWith const
-
-unionsWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
-unionsWith = unionsWithKey . const
-
-unionsWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
-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)@.
-symDifference :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
-symDifference = unionMaybeWith (\ _ _ -> Nothing)
-
--- | /O(n+m)/. Intersection of two maps with a combining function that may discard some elements.
-intersectionMaybeWithKey :: (Algebraic k, TrieKey (AlgRep 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 (\ k (Elem a) (Elem b) -> Elem <$> f (fromAlg k) a b) m1 m2
-
--- | /O(n+m)/. Intersection with a combining function.
---
--- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
-intersectionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
-intersectionWithKey f = intersectionMaybeWithKey (\ k x y -> Just (f k x y))
-
--- | /O(n+m)/. Intersection with a combining function.
---
--- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
-intersectionWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
-intersectionWith f = intersectionMaybeWith (Just .: f)
-
--- | /O(n+m)/. Intersection of two maps with a combining function that may discard some elements.
-intersectionMaybeWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
-intersectionMaybeWith = intersectionMaybeWithKey . const
-
--- | /O(n+m)/. Intersection of two maps.
--- Return data in the first map for the keys existing in both maps.
--- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
---
--- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
-intersection :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
-intersection = intersectionWith const
-
--- | /O(n+m)/. Difference with a combining function. When two equal keys are
--- encountered, the combining function is applied to the key and both values.
--- If it returns 'Nothing', the element is discarded (proper set difference). If
--- it returns (@'Just' y@), the element is updated with a new value @y@.
---
--- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
--- > == singleton 3 "3:b|B"
-differenceWithKey :: (Algebraic k, TrieKey (AlgRep 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 (\ 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
--- encountered, the combining function is applied to the values of these keys.
--- If it returns 'Nothing', the element is discarded (proper set difference). If
--- it returns (@'Just' y@), the element is updated with a new value @y@.
---
--- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
--- > == singleton 3 "b:B"
-differenceWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
-differenceWith = differenceWithKey . const
-
--- | /O(n+m)/. Difference of two maps.
--- Return elements of the first map not existing in the second map.
---
--- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
-difference :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
-difference = differenceWith (\ _ _ -> Nothing)
-
--- | Same as 'difference'.
-(\\) :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
-(\\) = difference
-
--- | The minimal key of the map. Calls 'error' if the map is empty.
---
--- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
--- > findMin empty Error: empty map has no minimal element
-findMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> (k, a)
-findMin = fromMaybe (error "empty map has no minimal element") . getMin
-
--- | The minimal key of the map, if any. Returns 'Nothing' if the map is empty.
---
--- > getMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")
--- > getMin empty == Nothing
-getMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (k, a)
-getMin = fst <.> minViewWithKey
-
--- | The maximal key of the map. Calls 'error' is the map is empty.
---
--- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
--- > findMax empty Error: empty map has no maximal element
-findMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> (k, a)
-findMax = fromMaybe (error "empty map has no maximal element") . getMax
-
--- | The maximal key of the map, if any. Returns 'Nothing' if the map is empty.
---
--- > getMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")
--- > getMax empty == Nothing
-getMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (k, a)
-getMax = fst <.> maxViewWithKey
-
--- | Delete the minimal key. Returns an empty map if the map is empty.
---
--- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
--- > deleteMin empty == empty
-deleteMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a
-deleteMin m0@(TrieMap n m) = maybe m0 (TrieMap (n-1) . snd) $ getMinAlg m
-
--- | Delete the maximal key. Returns an empty map if the map is empty.
---
--- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
--- > deleteMax empty == empty
-deleteMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a
-deleteMax m0@(TrieMap n m) = maybe m0 (TrieMap (n-1) . snd) $ getMaxAlg m
-
--- | Delete and find the minimal element.
---
--- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
--- > deleteFindMin Error: can not return the minimal element of an empty map
-deleteFindMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
-deleteFindMin = fromMaybe (error "cannot return the minimal element of an empty map") . minViewWithKey
-
-checkNothing :: Maybe a -> (Bool, Maybe a)
-checkNothing x = (isNothing x, x)
-
--- | Delete and find the maximal element.
---
--- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
--- > deleteFindMax empty Error: can not return the maximal element of an empty map
-deleteFindMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
-deleteFindMax = fromMaybe (error "cannot return the maximal element of an empty map") . maxViewWithKey
-
--- | Update the value at the minimal key.
---
--- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
--- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateMin :: (Algebraic k, TrieKey (AlgRep 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 . g)) m
- g (Elem x) = Elem <$> f x
-
--- | Update the value at the maximal key.
---
--- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
--- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-updateMax :: (Algebraic k, TrieKey (AlgRep 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 . g)) m
- g (Elem x) = Elem <$> f x
-
--- | Update the value at the minimal key.
---
--- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
--- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateMinWithKey :: (Algebraic k, TrieKey (AlgRep 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 .: g) m
- g k (Elem v) = Elem <$> f (fromAlg k) v
-
--- | Update the value at the maximal key.
---
--- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
--- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-updateMaxWithKey :: (Algebraic k, TrieKey (AlgRep 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 .: 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
--- empty map.
---
--- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
--- > minView empty == Nothing
-minView :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
-minView (TrieMap n m) = do
- (~(_, Elem v), m') <- getMinAlg m
- return (v, TrieMap (n-1) m')
-
--- | Retrieves the value associated with the maximal key of the
--- map, and the map stripped of that element, or 'Nothing' if passed an
---
--- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
--- > maxView empty == Nothing
-maxView :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
-maxView (TrieMap n m) = do
- (~(_, Elem v), m') <- getMaxAlg m
- return (v, TrieMap (n-1) m')
-
--- | Retrieves the minimal (key,value) pair of the map, and
--- the map stripped of that element, or 'Nothing' if passed an empty map.
---
--- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
--- > minViewWithKey empty == Nothing
-minViewWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
-minViewWithKey (TrieMap n m) = do
- (~(k, Elem v), m') <- getMinAlg m
- return ((fromAlg k, v), TrieMap (n-1) m')
-
--- | Retrieves the maximal (key,value) pair of the map, and
--- the map stripped of that element, or 'Nothing' if passed an empty map.
---
--- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
--- > maxViewWithKey empty == Nothing
-maxViewWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
-maxViewWithKey (TrieMap n m) = do
- ~(~(k, Elem v), m') <- getMaxAlg m
- return ((fromAlg k, v), TrieMap (n-1) m')
-
--- | /O(n+m)/.
--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
---
-isSubmapOf :: (Algebraic k, TrieKey (AlgRep k) m, Eq a) => TrieMap k m a -> TrieMap k m a -> Bool
-isSubmapOf = isSubmapOfBy (==)
-
-{- | /O(n+m)/.
- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
- applied to their respective values. For example, the following
- expressions are all 'True':
-
- > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
-
- But the following are all 'False':
-
- > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
-
--}
-isSubmapOfBy :: (Algebraic k, TrieKey (AlgRep 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
- 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@.
--- Any key equal to @k@ is found in neither @map1@ nor @map2@.
---
--- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
-split :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
-split k m = case splitLookup k m of
- (mL, _, mR) -> (mL, mR)
-
--- | The expression (@'splitLookup' k map@) splits a map just
--- like 'split' but also returns @'lookup' k map@.
---
--- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
--- > 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 (AlgRep k) m) => k -> TrieMap k m a -> (TrieMap k m a, Maybe a, TrieMap k m a)
-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) \ No newline at end of file
diff --git a/TrieMap/Algebraic.hs b/TrieMap/Algebraic.hs
deleted file mode 100644
index 7f0095b..0000000
--- a/TrieMap/Algebraic.hs
+++ /dev/null
@@ -1,417 +0,0 @@
-{-# LANGUAGE TypeOperators, FlexibleContexts, UndecidableInstances, TypeFamilies, TypeSynonymInstances #-}
-
-module TrieMap.Algebraic (Algebraic(..), AlgebraicT(..), SAlgebraicT(..), Ordered(..), AlgWrap (..)) where
-
-import Control.Arrow
-import Data.Bits
-import Data.ByteString (ByteString, pack, unpack)
-import Data.Char
-import Data.Maybe
-import Data.List (unfoldr)
-import Data.Word
-import Data.IntSet (IntSet)
-import Data.Set(Set)
-import qualified Data.IntSet as ISet
-import qualified Data.Set as Set
-import Data.IntMap (IntMap)
-import Data.Map (Map)
-import qualified Data.IntMap as IMap
-import qualified Data.Map as Map
-import qualified Data.Foldable as Fold
-import GHC.Exts (build)
-
-import TrieMap.TrieAlgebraic
-import TrieMap.MapTypes
-
-newtype AlgWrap t a = AlgWrap {unAlgWrap :: t a}
-
--- | 'Algebraic' refers to a type with an algebraic representation, armed with methods to convert in each direction.
--- 'toAlg' and 'fromAlg' should preserve equality and ordering.
-class Algebraic k where
- -- | @'AlgRep' k@ is a fully decomposed representation of k into algebraic pieces.
- type AlgRep k
- toAlg :: k -> AlgRep k
- fromAlg :: AlgRep k -> k
-
-class Functor (AlgRepT t) => AlgebraicT t where
- type AlgRepT t :: * -> *
- toAlgT :: t a -> AlgRepT t a
- fromAlgT :: AlgRepT t a -> t a
-
-class Functor (SAlgRepT t) => SAlgebraicT t where
- type SAlgRepT t :: * -> *
- toSAlgT :: Sized a => t a -> SAlgRepT t a
- fromSAlgT :: Sized a => SAlgRepT t a -> t a
-
-instance AlgebraicT Id where
- type AlgRepT Id = Id
- toAlgT = id
- fromAlgT = id
-
-instance (AlgebraicT t, Algebraic a) => Algebraic (AlgWrap t a) where
- type AlgRep (AlgWrap t a) = AlgRepT t (AlgRep a)
- toAlg = fmap toAlg . toAlgT . unAlgWrap
- fromAlg = AlgWrap . fromAlgT . fmap fromAlg
-
-instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f `O` g) where
- type AlgRepT (f `O` g) = AlgRepT f `O` AlgRepT g
- toAlgT (O x) = O (fmap (\ (App y) -> App (toAlgT y)) (toAlgT x))
- fromAlgT (O x) = O (fromAlgT (fmap (\ (App y) -> App (fromAlgT y)) x))
-
-instance (Algebraic (f (g a)), Functor f) => Algebraic ((f `O` g) a) where
- type AlgRep ((f `O` g) a) = AlgRep (f (g a))
- toAlg = toAlg . unO
- fromAlg = o . fromAlg
-
-instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :*: g) where
- type AlgRepT (f :*: g) = AlgRepT f :*: AlgRepT g
- toAlgT (a :*: b) = toAlgT a :*: toAlgT b
- fromAlgT (a :*: b) = fromAlgT a :*: fromAlgT b
-
-instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :*: g) a) where
- type AlgRep ((f :*: g) a) = (AlgRepT f :*: AlgRepT g) (AlgRep a)
- toAlg (a :*: b) = fmap toAlg (toAlgT a :*: toAlgT b)
- fromAlg (a :*: b) = fromAlgT (fmap fromAlg a) :*: fromAlgT (fmap fromAlg b)
-
-instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :+: g) where
- type AlgRepT (f :+: g) = AlgRepT f :+: AlgRepT g
- toAlgT (A a) = A (toAlgT a)
- toAlgT (B b) = B (toAlgT b)
- fromAlgT (A a) = A (fromAlgT a)
- fromAlgT (B b) = B (fromAlgT b)
-
-instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :+: g) a) where
- type AlgRep ((f :+: g) a) = AlgRep (AlgWrap (f :+: g) a)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance AlgebraicT f => Algebraic (Fix f) where
- type AlgRep (Fix f) = Fix (AlgRepT f)
- toAlg (Fix x) = Fix (fmap toAlg (toAlgT x))
- fromAlg (Fix x) = Fix (fromAlgT (fmap fromAlg x))
-
-instance Algebraic a => AlgebraicT (Const a) where
- type AlgRepT (Const a) = Const (AlgRep a)
- toAlgT (Const a) = Const (toAlg a)
- fromAlgT (Const a) = Const (fromAlg a)
-
-instance Algebraic a => Algebraic (Const a b) where
- type AlgRep (Const a b) = Const (AlgRep a) b
- toAlg (Const a) = Const (toAlg a)
- fromAlg (Const a) = fromAlg (Const a)
-
-instance Algebraic a => AlgebraicT ((,) a) where
- type AlgRepT ((,) a) = (,) (AlgRep a)
- toAlgT = first toAlg
- fromAlgT = first fromAlg
-
-instance (Algebraic a, Algebraic b) => Algebraic (a, b) where
- type AlgRep (a, b) = AlgRep (AlgWrap ((,) a) b)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance (Algebraic a, Algebraic b) => AlgebraicT ((,,) a b) where
- type AlgRepT ((,,) a b) = (,) (AlgRep (a, b))
- toAlgT (a, b, c) = (toAlg (a, b), c)
- fromAlgT (ab, c) = case fromAlg ab of
- (a, b) -> (a, b, c)
-
-instance (Algebraic a, Algebraic b, Algebraic c) => Algebraic (a, b, c) where
- type AlgRep (a, b, c) = AlgRep (AlgWrap ((,,) a b) c)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance (Algebraic a, Algebraic b, Algebraic c) => AlgebraicT ((,,,) a b c) where
- type AlgRepT ((,,,) a b c) = (,) (AlgRep (a, b, c))
- toAlgT (a, b, c, d) = (toAlg (a, b, c), d)
- fromAlgT (abc, d) = case fromAlg abc of
- (a, b, c) -> (a, b, c, d)
-
-instance (Algebraic a, Algebraic b, Algebraic c, Algebraic d) => Algebraic (a, b, c, d) where
- type AlgRep (a, b, c, d) = AlgRep (AlgWrap ((,,,) a b c) d)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance Algebraic a => AlgebraicT (Either a) where
- type AlgRepT (Either a) = Either (AlgRep a)
- toAlgT = either (Left . toAlg) Right
- fromAlgT = either (Left . fromAlg) Right
-
-instance (Algebraic a, Algebraic b) => Algebraic (Either a b) where
- type AlgRep (Either a b) = AlgRep (AlgWrap (Either a) b)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance AlgebraicT [] where
- type AlgRepT [] = []
- toAlgT = id
- fromAlgT = id
-
-instance Algebraic k => Algebraic [k] where
- type AlgRep [k] = [AlgRep k]
- toAlg = map toAlg
- fromAlg = map fromAlg
-
-instance Algebraic () where
- type AlgRep () = ()
- toAlg = id
- fromAlg = id
-
-instance AlgebraicT Maybe where
- type AlgRepT Maybe = Either ()
- toAlgT = maybe (Left ()) Right
- fromAlgT = either (const Nothing) Just
-
-instance SAlgebraicT Maybe where
- type SAlgRepT Maybe = AlgRepT Maybe
- toSAlgT = toAlgT
- fromSAlgT = fromAlgT
-
-instance Algebraic a => Algebraic (Maybe a) where
- type AlgRep (Maybe a) = AlgRep (AlgWrap Maybe a)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance Algebraic Bool where
- type AlgRep Bool = AlgRep (Maybe ())
- toAlg b = toAlg $ if b then Just () else Nothing
- fromAlg = maybe False (const True) . fromAlg'
- where fromAlg' = fromAlg :: AlgRep (Maybe ()) -> Maybe ()
-
-instance Algebraic Int where
- type AlgRep Int = Int
- toAlg = id
- fromAlg = id
-
-instance Algebraic Char where
- type AlgRep Char = Int
- toAlg = ord
- fromAlg = chr
-
-instance Algebraic Float where
- type AlgRep Float = Ordered Float
- toAlg = Ord
- fromAlg = unOrd
-
-instance Algebraic Double where
- type AlgRep Double = Ordered Double
- toAlg = Ord
- fromAlg = unOrd
-
-instance Algebraic Rational where
- type AlgRep Rational = Ordered Rational
- toAlg = Ord
- fromAlg = unOrd
-
-instance Algebraic a => Algebraic (Ordered a) where
- type AlgRep (Ordered a) = AlgRep a
- toAlg = toAlg . unOrd
- fromAlg = Ord . fromAlg
-
-instance (Algebraic k, Algebraic v) => Algebraic (Map k v) where
- type AlgRep (Map k v) = AlgRep (AlgWrap (Map k) v)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance Algebraic k => AlgebraicT (Map k) where
- type AlgRepT (Map k) = [] `O` ((,) k)
- toAlgT = o . Map.assocs
- fromAlgT = Map.fromDistinctAscList . unO
-
-instance Algebraic k => SAlgebraicT (Map k) where
- type SAlgRepT (Map k) = [] `O` ((,) k)
- toSAlgT = o . Map.assocs
- fromSAlgT = Map.fromDistinctAscList . unO
-
-instance Algebraic v => Algebraic (IntMap v) where
- type AlgRep (IntMap v) = AlgRep (AlgWrap IntMap v)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance AlgebraicT IntMap where
- type AlgRepT IntMap = AlgRepT ([] `O` ((,) Int))
- toAlgT = toAlgT . o . IMap.assocs
- fromAlgT = IMap.fromDistinctAscList . unO . fromAlgT
-
-instance SAlgebraicT IntMap where
- type SAlgRepT IntMap = AlgRepT ([] `O` ((,) Int))
- toSAlgT = toAlgT . o . IMap.assocs
- fromSAlgT = IMap.fromDistinctAscList . unO . fromAlgT
-
-instance Algebraic a => Algebraic (Set a) where
- type AlgRep (Set a) = AlgRep (AlgWrap Set a)
- toAlg = toAlg . AlgWrap
- fromAlg = unAlgWrap . fromAlg
-
-instance AlgebraicT Set where
- type AlgRepT Set = AlgRepT []
- toAlgT = toAlgT . Fold.toList
- fromAlgT = Set.fromDistinctAscList . fromAlgT
-
-instance Algebraic IntSet where
- type AlgRep IntSet = AlgRep [Int]
- toAlg = toAlg . ISet.toList
- fromAlg = ISet.fromDistinctAscList . fromAlg
-
-{-# RULES
- "map/id" forall xs . map id xs = xs;
- #-}
-
-instance SAlgebraicT m => SAlgebraicT (ConstMap m k m') where
- type SAlgRepT (ConstMap m k m') = SAlgRepT m
- toSAlgT (ConstMap m) = toSAlgT m
- fromSAlgT = ConstMap . fromSAlgT
-
-instance Algebraic (m a) => Algebraic (ConstMap m k m' a) where
- type AlgRep (ConstMap m k m' a) = AlgRep (m a)
- toAlg (ConstMap m) = toAlg m
- fromAlg = ConstMap . fromAlg
-
-instance SAlgebraicT m => SAlgebraicT (IdMap k m) where
- type SAlgRepT (IdMap k m) = SAlgRepT m
- toSAlgT (IdMap m) = toSAlgT m
- fromSAlgT = IdMap . fromSAlgT
-
-instance Algebraic (m a) => Algebraic (IdMap k m a) where
- type AlgRep (IdMap k m a) = AlgRep (m a)
- toAlg (IdMap m) = toAlg m
- fromAlg = IdMap . fromAlg
-
-instance (SAlgebraicT (t1 k m), SAlgebraicT (t2 k m), TrieKey k m, TrieKeyT f2 t2) => SAlgebraicT (ProdMap t1 t2 k m) where
- type SAlgRepT (ProdMap t1 t2 k m) = (SAlgRepT (t1 k m) `O` SAlgRepT (t2 k m))
- toSAlgT (PMap m) = O (fmap (App . toSAlgT) (toSAlgT m))
- fromSAlgT (O m) = PMap (fromSAlgT (fmap (\ (App x) -> fromSAlgT x) m))
-
-instance Algebraic (t1 k m (t2 k m a)) => Algebraic (ProdMap t1 t2 k m a) where
- type AlgRep (ProdMap t1 t2 k m a) = AlgRep (t1 k m (t2 k m a))
- toAlg (PMap m) = toAlg m
- fromAlg = PMap . fromAlg
-
-instance (SAlgebraicT m1, SAlgebraicT m2, TrieKey k2 m2) => SAlgebraicT (CProdMap m1 k2 m2) where
- type SAlgRepT (CProdMap m1 k2 m2) = SAlgRepT m1 `O` SAlgRepT m2
- toSAlgT (CPMap m) = O (fmap (App . toSAlgT) (toSAlgT m))
- fromSAlgT (O m) = CPMap (fromSAlgT (fmap (fromSAlgT . unApp) m))
-
-instance (Algebraic (m1 (m2 a))) => Algebraic (CProdMap m1 k2 m2 a) where
- type AlgRep (CProdMap m1 k2 m2 a) = AlgRep (m1 (m2 a))
- toAlg (CPMap m) = toAlg m
- fromAlg = CPMap . fromAlg
-
-{-
-instance Algebraic (t1 k m (t2 k m a)) => Algebraic (ProdMap t1 t2 k m a) where
- type AlgRep (ProdMap t1 t2 k m a) = AlgRep (t1 k m (t2 k m a))
- toAlg = toAlg . unPMap
- fromAlg = PMap . fromAlg-}
-
-instance (SAlgebraicT (t1 k m), SAlgebraicT (t2 k m)) => SAlgebraicT (UnionMap t1 t2 k m) where
- type SAlgRepT (UnionMap t1 t2 k m) = SAlgRepT (t1 k m) :*: SAlgRepT (t2 k m)
- toSAlgT (UMap m1 m2) = toSAlgT m1 :*: toSAlgT m2
- fromSAlgT (m1 :*: m2) = UMap (fromSAlgT m1) (fromSAlgT m2)
-
-instance (Algebraic (t1 k m a), Algebraic (t2 k m a)) => Algebraic (UnionMap t1 t2 k m a) where
- type AlgRep (UnionMap t1 t2 k m a) = AlgRep (t1 k m a, t2 k m a)
- toAlg (UMap m1 m2) = toAlg (m1, m2)
- fromAlg = uncurry UMap . fromAlg
-
-instance (SAlgebraicT m1, SAlgebraicT m2) => SAlgebraicT (CUnionMap m1 k2 m2) where
- type SAlgRepT (CUnionMap m1 k2 m2) = SAlgRepT m1 :*: SAlgRepT m2
- toSAlgT (CUMap m1 m2) = toSAlgT m1 :*: toSAlgT m2
- fromSAlgT (m1 :*: m2) = CUMap (fromSAlgT m1) (fromSAlgT m2)
-
-instance (Algebraic (m1 a), Algebraic (m2 a)) => Algebraic (CUnionMap m1 k2 m2 a) where
- type AlgRep (CUnionMap m1 k2 m2 a) = AlgRep (m1 a, m2 a)
- toAlg (CUMap m1 m2) = toAlg (m1, m2)
- fromAlg = uncurry CUMap . fromAlg
-
--- instance (Algebraic (t1 k m a), Algebraic (t2 k m a)) => Algebraic (UnionMap t1 t2 k m a) where
--- type AlgRep (UnionMap t1 t2 k m a) = AlgRep (t1 k m a, t2 k m a)
--- toAlg (UMap m1 m2) = toAlg (m1, m2)
--- fromAlg = uncurry UMap . fromAlg
-
-instance SAlgebraicT f => SAlgebraicT (App f) where
- type SAlgRepT (App f) = SAlgRepT f
- toSAlgT = toSAlgT . unApp
- fromSAlgT = App . fromSAlgT
-
-instance AlgebraicT f => AlgebraicT (App f) where
- type AlgRepT (App f) = AlgRepT f
- toAlgT = toAlgT . unApp
- fromAlgT = App . fromAlgT
-
-instance Algebraic (f a) => Algebraic (App f a) where
- type AlgRep (App f a) = AlgRep (f a)
- toAlg = toAlg . unApp
- fromAlg = App . fromAlg
-
-instance SAlgebraicT (t1 (App f2 k) (App (t2 k m))) => SAlgebraicT (CompMap t1 f2 t2 k m) where
- type SAlgRepT (CompMap t1 f2 t2 k m) = SAlgRepT (t1 (App f2 k) (App (t2 k m)))
- toSAlgT (CompMap m) = toSAlgT m
- fromSAlgT = CompMap . fromSAlgT
-
-instance Algebraic (t1 (App f2 k) (App (t2 k m)) a) => Algebraic (CompMap t1 f2 t2 k m a) where
- type AlgRep (CompMap t1 f2 t2 k m a) = AlgRep (t1 (App f2 k) (App (t2 k m)) a)
- toAlg (CompMap m) = toAlg m
- fromAlg = CompMap . fromAlg
-
--- instance (AlgebraicT (t1 (App f2 k) (App (t2 k m))), Algebraic a) => Algebraic (CompMap t1 f2 t2 k m a) where
--- type AlgRep (CompMap t1 f2 t2 k m a) = AlgRep (AlgWrap (CompMap t1 f2 t2 k m) a)
--- toAlg = toAlg . AlgWrap
--- fromAlg = unAlgWrap . fromAlg
-
--- newtype f t a = FixMap (t (Fix f) (FixMap f t) a)
-
-instance (TrieKeyT f t) => SAlgebraicT (FixMap f t) where
- type SAlgRepT (FixMap f t) = [] `O` ((,) (Fix f))
- toSAlgT m = o (assocsAlg m)
- fromSAlgT = fromDistAscListAlg . unO
-
-instance (TrieKeyT f t, AlgebraicT f, Sized a, Algebraic a) => Algebraic (FixMap f t a) where
- type AlgRep (FixMap f t a) = AlgRep [(Fix f, a)]
- toAlg = toAlg . assocsAlg
- fromAlg = fromDistAscListAlg . fromAlg
-
--- instance (AlgebraicT f, TrieKeyT f t, Sized a, Algebraic a) => Algebraic (FixMap f t a) where
--- type AlgRep (FixMap f t a) = AlgRep [(Fix f, a)]
--- toAlg = toAlg . assocsAlg
--- fromAlg = fromDistAscListAlg . fromAlg
-
-instance Algebraic Word8 where
- type AlgRep Word8 = Int
- toAlg = fromIntegral
- fromAlg = fromIntegral
-
-instance Algebraic Word16 where
- type AlgRep Word16 = Int
- toAlg = fromIntegral
- fromAlg = fromIntegral
-
-instance Algebraic Word32 where
- type AlgRep Word32 = Int
- toAlg = fromIntegral
- fromAlg = fromIntegral
-
-instance Algebraic Integer where
- type AlgRep Integer = AlgRep [Word8]
- toAlg = toAlg . unroll
- fromAlg = roll . fromAlg
-
-instance Algebraic ByteString where
- type AlgRep ByteString = AlgRep [Word8]
- toAlg = toAlg . unpack
- fromAlg = pack . fromAlg
-
-unroll :: Integer -> [Word8]
-unroll = unfoldr step
- where
- step 0 = Nothing
- step i = Just (fromIntegral i, i `shiftR` 8)
-
-roll :: [Word8] -> Integer
-roll = foldr unstep 0
- where
- unstep b a = a `shiftL` 8 .|. fromIntegral b
-
-
-{-# RULES
- "toAlg/fromAlg" forall x . toAlg (fromAlg x) = x;
- #-} \ No newline at end of file
diff --git a/TrieMap/Applicative.hs b/TrieMap/Applicative.hs
deleted file mode 100644
index 5aaddc1..0000000
--- a/TrieMap/Applicative.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module TrieMap.Applicative(Id(..), (.:), (<.>), on, build) where
-
-import Control.Monad
-import Control.Applicative
-import Data.Traversable (sequenceA)
-import GHC.Exts (build)
-import TrieMap.MapTypes
-
-instance Applicative Id where
- pure = return
- (<*>) = ap
-
-instance Monad Id where
- return = Id
- m >>= k = k (unId m)
-
-(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
-(.:) = (.) . (.)
-
-(<.>) :: Functor f => (b -> c) -> (a -> f b) -> (a -> f c)
-(<.>) = (.) . (<$>)
-
-on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
-(f `on` g) x y = f (g x) (g y)
-
-infixr 9 <.>
-infixr 9 .:
-infixr 8 `on` \ No newline at end of file
diff --git a/TrieMap/MapTypes.hs b/TrieMap/MapTypes.hs
deleted file mode 100644
index d9ef27f..0000000
--- a/TrieMap/MapTypes.hs
+++ /dev/null
@@ -1,166 +0,0 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances, KindSignatures, StandaloneDeriving, GeneralizedNewtypeDeriving, IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving, ExistentialQuantification #-}
-
-module TrieMap.MapTypes where
-
-import Data.Foldable
-import Data.Traversable
-import Control.Applicative hiding (Const)
-import Prelude hiding (foldl, foldr)
-import qualified Data.IntMap as IMap
-
-data (f :*: g) a = f a :*: g a deriving (Eq, Ord, Show)
-data (f :+: g) a = A (f a) | B (g a) deriving (Eq, Ord, Show)
-newtype Const a b = Const {unConst :: a} deriving (Eq, Ord, Show)
-newtype Id a = Id {unId :: a} deriving (Eq, Ord, Show)
-newtype Fix f = Fix (f (Fix f))
-newtype FixMap f t a = FixMap (t (Fix f) (FixMap f t) a)
-
-newtype O f g a = O (f (App g a))
-newtype App f a = App {unApp :: f a}
-
-o :: Functor f => f (g a) -> (f `O` g) a
-o = O . fmap App
-
-unO :: Functor f => (f `O` g) a -> f (g a)
-unO (O x) = fmap unApp x
-
--- | 'ProdMap' is used to hold a map on the product of two key types.
-newtype ProdMap t1 t2 k (m :: * -> *) a = PMap {unPMap :: t1 k m (t2 k m a)}
-data UnionMap t1 t2 k (m :: * -> *) a = UMap (t1 k m a) (t2 k m a)
-newtype CProdMap m1 k2 m2 a = CPMap {unCPMap :: m1 (m2 a)}
-data CUnionMap m1 k2 m2 a = CUMap (m1 a) (m2 a)
-
-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 IdMap k m a = IdMap {unIdMap :: m a}
-
-newtype ConstMap (m :: * -> *) k (x :: * -> *) a = ConstMap {unConstMap :: m a}
-
-newtype CompMap t1 f2 (t2 :: * -> (* -> *) -> * -> *) k (m :: * -> *) a = CompMap (t1 (App f2 k) (App (t2 k m)) a)
-
--- newtype FixMap (m :: (* -> *) -> * -> *) a = FixMap (m (FixMap m) a)
-
-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 :+:
-infixr 8 :*:
-infixr 9 `O`
-
-class Sized a where
- getSize :: a -> Int
-
-instance Sized (Elem a) where
- getSize _ = 1
-
-instance Functor m => Functor (Edge k m) where
- fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts)
-raverse f (Radix e) = Radix <$> traverse (traverse f) e
-
-instance (Functor f, Functor g) => Functor (f :*: g) where
- fmap f (a :*: b) = fmap f a :*: fmap f b
-
-instance (Foldable f, Foldable g) => Foldable (f :*: g) where
- foldr f z (a :*: b) = foldr f (foldr f z b) a
- foldl f z (a :*: b) = foldl f (foldl f z a) b
-
-instance (Traversable f, Traversable g) => Traversable (f :*: g) where
- traverse f (a :*: b) = liftA2 (:*:) (traverse f a) (traverse f b)
-
-instance (Functor f, Functor g) => Functor (f :+: g) where
- fmap f (A a) = A (fmap f a)
- fmap f (B b) = B (fmap f b)
-
-instance (Foldable f, Foldable g) => Foldable (f :+: g) where
- foldr f z (A a) = foldr f z a
- foldr f z (B b) = foldr f z b
- foldl f z (A a) = foldl f z a
- foldl f z (B b) = foldl f z b
-
-instance (Traversable f, Traversable g) => Traversable (f :+: g) where
- traverse f (A a) = A <$> traverse f a
- traverse f (B b) = B <$> traverse f b
-
-instance Functor (Const a) where
- fmap f (Const x) = Const x
-
-instance Foldable (Const a) where
- foldr f z _ = z
- foldl f z _ = z
-
-instance Traversable (Const a) where
- traverse f (Const x) = pure (Const x)
-
-instance Functor Id where
- fmap f (Id a) = Id (f a)
-
-instance Foldable Id where
- foldr f z (Id a) = a `f` z
- foldl f z (Id a) = z `f` a
-
-instance Traversable Id where
- traverse f (Id a) = Id <$> f a
-
-class EqT f where
- eq :: Eq a => f a -> f a -> Bool
-
-instance EqT f => Eq (Fix f) where
- Fix x == Fix y = x `eq` y
-
-instance (EqT f, EqT g) => EqT (f :*: g) where
- (a :*: x) `eq` (b :*: y) = a `eq` b && x `eq` y
-
-instance (EqT f, EqT g) => EqT (f :+: g) where
- A a `eq` A b = a `eq` b
- B x `eq` B y = x `eq` y
- _ `eq` _ = False
-
-instance Eq a => EqT (Const a) where
- Const a `eq` Const b = a == b
-
-instance EqT Id where
- Id a `eq` Id b = a == b
-
-instance EqT [] where
- eq = (==)
-
-instance EqT Maybe where
- eq = (==)
-
-instance Eq a => EqT ((,) a) where
- eq = (==)
-
-instance Eq a => EqT (Either a) where
- eq = (==)
-
-instance EqT f => EqT (App f) where
- App a `eq` App b = a `eq` b
-
-instance (EqT f, Eq a) => Eq (App f a) where
- (==) = eq
-
-instance (EqT f, EqT g) => EqT (f `O` g) where
- O a `eq` O b = a `eq` b
-
-instance (EqT f, EqT g, Eq a) => Eq ((f `O` g) a) where
- (==) = eq
-
-instance (Functor f, Functor g) => Functor (f `O` g) where
- fmap f (O x) = O (fmap (\ (App x) -> App (fmap f x)) x)
-
-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
deleted file mode 100644
index 2ab4432..0000000
--- a/TrieMap/RadixTrie.hs
+++ /dev/null
@@ -1,274 +0,0 @@
-{-# LANGUAGE IncoherentInstances, PatternGuards, MultiParamTypeClasses, UndecidableInstances #-}
-
-module TrieMap.RadixTrie where
-
-import Control.Applicative
-
-import Data.Maybe
-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 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)
- 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
-
-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
- (l, e') <- getSingleAlg ts
- (ls, v) <- getSingleEdge e'
- return (ks ++ l:ls, v)
-getSingleEdge _ = Nothing
-
-guardNullEdge :: TrieKey k m => Edge k m a -> MEdge k m a
-guardNullEdge (Edge s ks Nothing ts)
- | nullAlg ts = Nothing
- | Just (l, Edge _ ls v ts') <- getSingleAlg ts
- = Just (Edge s (ks ++ l:ls) v ts')
-guardNullEdge e = Just e
-
-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 = 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
-
-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))
-
-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 (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 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 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)
-
-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 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
diff --git a/TrieMap/Reflection.hs b/TrieMap/Reflection.hs
deleted file mode 100644
index a07c552..0000000
--- a/TrieMap/Reflection.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
-
-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 AlgRep (Elem v) = AlgRep v
- toAlg (Elem v) = toAlg v
- fromAlg v = Elem (fromAlg v)
-
--- instance Algebraic (t1 k (m2 v)) => Algebraic (ProdMap m1 m2 v) where
--- type AlgRep (ProdMap m1 m2 v) = AlgRep (m1 (m2 v))
--- toAlg (PMap m) = toAlg m
--- fromAlg = PMap . fromAlg
---
--- instance (Ord k, Algebraic k, Sized v, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where
--- type AlgRep (RadixTrie k m v) = AlgRep [([k], v)]
--- toAlg m = toAlg (build (\ c n -> foldWithKeyAlg (curry c) n m))
--- fromAlg = fromDistAscListAlg . fromAlg
-
-instance (Algebraic k, TrieKey k m) => SAlgebraicT (RadixTrie k m) where
- type SAlgRepT (RadixTrie k m) = AlgRepT ([] `O` ((,) [k]))
- toSAlgT = toAlgT . o . assocsAlg
- fromSAlgT = fromDistAscListAlg . unO . fromAlgT
-
--- instance (AlgebraicT m, Algebraic k) => SAlgebraicT (Edge k m) where
--- type SAlgRepT (Edge k m) = AlgRepT (O Fix (O ((:*:) (Const Int :*: Co{--}nst [k] :*: AlgRepT m)) (O Const Maybe)))
-
-
-instance (AlgebraicT m, Algebraic k, Algebraic a) => Algebraic (Edge k m a) where
- type AlgRep (Edge k m a) = Fix (AlgRepT (Const (Int, [k], Maybe a)) :*: AlgRepT m)
- toAlg (Edge s ks v ts) = Fix (toAlgT (Const (s, ks, v)) :*: fmap toAlg (toAlgT ts))
- fromAlg (Fix (a :*: b)) = case (fromAlgT a, fmap fromAlg b) of
- (Const (s, ks, v), ts) ->
- Edge s ks v (fromAlgT ts)
-
-instance (AlgebraicT m, Algebraic k, Algebraic a) => Algebraic (RadixTrie k m a) where
- type AlgRep (RadixTrie k m a) = AlgRep (Maybe (Edge k m a))
- toAlg (Radix e) = toAlg e
- fromAlg = Radix . fromAlg \ No newline at end of file
diff --git a/TrieMap/TrieAlgebraic.hs b/TrieMap/TrieAlgebraic.hs
deleted file mode 100644
index b2893aa..0000000
--- a/TrieMap/TrieAlgebraic.hs
+++ /dev/null
@@ -1,898 +0,0 @@
-{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards, IncoherentInstances, TypeOperators #-}
-module TrieMap.TrieAlgebraic where
-
-import Control.Arrow ((***))
-import Data.Traversable
-import Data.Foldable
-import Data.Either
-import Data.Sequence (Seq)
-import Data.Maybe
-import Data.Monoid
-import Data.IntMap (IntMap)
-import Data.Map (Map)
-import qualified Data.Sequence as Seq
-import qualified Data.IntMap as IMap
-import qualified Data.Map as Map
-
-import Control.Monad
-import Control.Applicative hiding (Alternative(..), Const(..))
-import GHC.Exts (build)
-
-import TrieMap.Applicative
--- import TrieMap.Algebraic (Ordered (..))
-import TrieMap.MapTypes
-import Prelude hiding (foldr, foldl, all, any)
-
-newtype Ordered k = Ord {unOrd :: k} deriving (Eq, Ord)
-
-instance Show k => Show (Ordered k) where
- show = show . unOrd
- showsPrec x = showsPrec x . unOrd
-
-instance Functor Ordered where
- fmap f (Ord x) = Ord (f x)
-
-type L a = Fix (Const () :+: (Const a :*: Id))
-
-class EqT f => TrieKeyT f t | f -> t, t -> f where
- compareKeyT :: TrieKey k m => f k -> f k -> Ordering
- emptyT :: (Sized a, TrieKey k m) => t k m a
- nullT :: (Sized a, TrieKey k m) => t k m a -> Bool
- guardNullT :: (Sized a, TrieKey k m) => t k m a -> Maybe (t k m a)
- sizeT :: (Sized a, TrieKey k m) => t k m a -> Int
- getSingleT :: (Sized a, TrieKey k m) => t k m a -> Maybe (f k, a)
- alterLookupT :: (Sized a, TrieKey k m) =>
- (Maybe a -> (b, Maybe a)) -> f k -> t k m a -> (b, t k m a)
- lookupT :: (Sized a, TrieKey k m) => f k -> t k m a -> Maybe a
- foldWithKeyT :: (TrieKey k m) => (f k -> a -> b -> b) -> b -> t k m a -> b
- mapAppT :: (Applicative g, Sized a, Sized b, TrieKey k m) =>
- (f k -> a -> g b) -> t k m a -> g (t k m b)
- mapMaybeT :: (Sized a, Sized b, TrieKey k m) =>
- (f k -> a -> Maybe b) -> t k m a -> t k m b
- mapEitherT :: (Sized a, Sized b, Sized c, TrieKey k m) =>
- (f k -> a -> (Maybe b, Maybe c)) -> t k m a -> (t k m b, t k m c)
- unionT :: (Sized a, TrieKey k m) => (f k -> a -> a -> Maybe a) -> t k m a -> t k m a -> t k m a
- intersectT :: (Sized a, Sized b, Sized c, TrieKey k m) =>
- (f k -> a -> b -> Maybe c) -> t k m a -> t k m b -> t k m c
- differenceT :: (Sized a, Sized b, TrieKey k m) => (f k -> a -> b -> Maybe a) -> t k m a -> t k m b -> t k m a
- fromDistAscListT :: (Sized a, TrieKey k m) => [(f k, a)] -> t k m a
- fromAscListT :: (Sized a, TrieKey k m) => (f k -> a -> a -> a) -> [(f k, a)] -> t k m a
- fromListT :: (Sized a, TrieKey k m) => (f k -> a -> a -> a) -> [(f k, a)] -> t k m a
- getMinT :: (Sized a, TrieKey k m) => t k m a -> Maybe ((f k, a), t k m a)
- getMaxT :: (Sized a, TrieKey k m) => t k m a -> Maybe ((f k, a), t k m a)
- updateMinT :: (Sized a, TrieKey k m) => (f k -> a -> (Bool, Maybe a)) -> t k m a -> (Bool, t k m a)
- updateMaxT :: (Sized a, TrieKey k m) => (f k -> a -> (Bool, Maybe a)) -> t k m a -> (Bool, t k m a)
- isSubmapT :: (Sized a, Sized b, TrieKey k m) => (a -> b -> Bool) -> t k m a -> t k m b -> Bool
- splitLookupT :: (Sized a, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> f k -> t k m a -> (t k m a, Maybe b, t k m a)
-
- guardNullT m
- | nullT m = Nothing
- | otherwise = Just m
-
-eqKey :: TrieKey k m => k -> k -> Bool
-eqKey a b = compareKey a b == EQ
-
-eqKeyT :: (TrieKey k m, TrieKeyT f t) => f k -> f k -> Bool
-eqKeyT a b = compareKeyT a b == EQ
-
--- | TrieKey defines a bijection between map types and algebraic key types.
-class Eq k => TrieKey k m | k -> m, m -> k where
- compareKey :: k -> k -> Ordering
- emptyAlg :: Sized a => m a
- nullAlg :: Sized a => m a -> Bool
- sizeAlg :: Sized a => m a -> Int
- getSingleAlg :: Sized a => m a -> Maybe (k, a)
- guardNullAlg :: Sized a => m a -> Maybe (m a)
--- {-# SPECIALIZE alterAlg :: Sized v => (Maybe v -> Id (b, Maybe v)) -> a -> m v -> Id (b, m v) #-}
- alterLookupAlg :: Sized a => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a)
- lookupAlg :: Sized a => k -> m a -> Maybe a
- foldWithKeyAlg :: (k -> a -> b -> b) -> b -> m a -> b
- mapAppAlg :: (Applicative f, Sized a, Sized b) => (k -> a -> f b) -> m a -> f (m b)
- mapMaybeAlg :: (Sized a, Sized b) => (k -> a -> Maybe b) -> m a -> m b
- mapEitherAlg :: (Sized a, Sized b, Sized c) => (k -> a -> (Maybe b, Maybe c)) -> m a -> (m b, m c)
- unionMaybeAlg :: Sized a => (k -> a -> a -> Maybe a) -> m a -> m a -> m a
- intersectAlg :: (Sized a, Sized b, Sized c) => (k -> a -> b -> Maybe c) -> m a -> m b -> m c
- differenceAlg :: (Sized a, Sized b) => (k -> a -> b -> Maybe a) -> m a -> m b -> m a
- fromDistAscListAlg :: Sized a => [(k, a)] -> m a
- fromAscListAlg :: Sized a => (k -> a -> a -> a) -> [(k, a)] -> m a
- fromListAlg :: Sized a => (k -> a -> a -> a) -> [(k, a)] -> m a
- getMinAlg :: Sized a => m a -> Maybe ((k, a), m a)
- getMaxAlg :: Sized a => m a -> Maybe ((k, a), m a)
- updateMinAlg :: Sized a => (k -> a -> (Bool, Maybe a)) -> m a -> (Bool, m a)
- updateMaxAlg :: Sized a => (k -> a -> (Bool, Maybe a)) -> m a -> (Bool, m a)
- valid :: Sized a => m a -> Bool
- isSubmapAlg :: (Sized a, Sized b) => (a -> b -> Bool) -> m a -> m b -> Bool
- splitLookupAlg :: (Sized a) => (a -> (Maybe a, Maybe b, Maybe a)) -> k -> m a -> (m a, Maybe b, m a)
-
- 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
- distinct k v ((k', v'):xs)
- | k `eqKey` k' = distinct k (f k v v') xs
- | otherwise = (k, v):distinct k' v' xs
- distinct k v [] = [(k, v)]
- fromDistAscListAlg = fromListAlg'
- sizeAlg = foldWithKeyAlg (\ _ x n -> n + getSize x) 0
-
- updateMinAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMinAlg m)
- updateMaxAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMaxAlg m)
- valid = (`seq` True)
-
-instance TrieKeyT f t => TrieKey (Fix f) (FixMap f t) where
- compareKey (Fix a) (Fix b) = compareKeyT a b
- emptyAlg = FixMap emptyT
- nullAlg (FixMap m) = nullT m
- sizeAlg (FixMap m) = sizeT m
- getSingleAlg (FixMap m) = do
- (k, v) <- getSingleT m
- return (Fix k, v)
- lookupAlg (Fix k) (FixMap m) = lookupT k m
- alterLookupAlg f (Fix k) (FixMap m) = FixMap <$> alterLookupT f k m
- foldWithKeyAlg f z (FixMap m) = foldWithKeyT (f . Fix) z m
- mapAppAlg f (FixMap m) = FixMap <$> mapAppT (f . Fix) m
- mapMaybeAlg f (FixMap m) = FixMap (mapMaybeT (f . Fix) m)
- mapEitherAlg f (FixMap m) = case mapEitherT (f . Fix) m of
- (mL, mR) -> (FixMap mL, FixMap mR)
- unionMaybeAlg f (FixMap m1) (FixMap m2) = FixMap (unionT (f . Fix) m1 m2)
- intersectAlg f (FixMap m1) (FixMap m2) = FixMap (intersectT (f . Fix) m1 m2)
- differenceAlg f (FixMap m1) (FixMap m2) = FixMap (differenceT (f . Fix) m1 m2)
- getMinAlg (FixMap m) = do
- (~(k, v), m') <- getMinT m
- return ((Fix k, v), FixMap m')
- getMaxAlg (FixMap m) = do
- (~(k, v), m') <- getMaxT m
- return ((Fix k, v), FixMap m')
- updateMinAlg f (FixMap m) = FixMap <$> updateMinT (f . Fix) m
- updateMaxAlg f (FixMap m) = FixMap <$> updateMaxT (f . Fix) m
- isSubmapAlg (<=) (FixMap m1) (FixMap m2) = isSubmapT (<=) m1 m2
- splitLookupAlg f (Fix k) (FixMap m) = case splitLookupT f k m of
- (mL, ans, mR) -> (FixMap mL, ans, FixMap mR)
-
-instance (Sized a, TrieKey k m) => Sized (m a) where
- getSize = sizeAlg
-
-instance (Sized a, TrieKey k m, TrieKeyT f t) => Sized (t k m a) where
- getSize = sizeT
-
-fromListAlg' :: (Sized v, TrieKey k m) => [(k, v)] -> m v
-fromListAlg' = fromListAlg (const const)
-
-singletonAlg :: (Sized v, TrieKey k m) => k -> v -> m v
-singletonAlg k v = insertAlg k v emptyAlg
-
-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)
-
-mapWithKeyT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (f k -> v -> w) -> t k m v -> t k m w
-mapWithKeyT f m = unId (mapAppT (\ k v -> Id (f k v)) m)
-
-mapAlg :: (Sized v, Sized w, TrieKey k m) => (v -> w) -> m v -> m w
-mapAlg = mapWithKeyAlg . const
-
-mapT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (v -> w) -> t k m v -> t k m w
-mapT = mapWithKeyT . const
-
--- 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 :: (Sized v, TrieKey k m) => k -> v -> m v -> m v
-insertAlg k v = alterAlg (const (Just v)) k
-
-insertT :: (Sized v, TrieKey k m, TrieKeyT f t) => f k -> v -> t k m v -> t k m v
-insertT k v = alterT (const (Just v)) k
-
-alterAlg :: (Sized v, TrieKey k m) => (Maybe v -> Maybe v) -> k -> m v -> m v
-alterAlg f k = snd . alterLookupAlg (\ x -> ((), f x)) k
-
-alterT :: (Sized v, TrieKey k m, TrieKeyT f t) => (Maybe v -> Maybe v) -> f k -> t k m v -> t k m v
-alterT f k = snd . alterLookupT (\ 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 :: (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
-unionMaybe f (Just x) (Just y) = f x y
-unionMaybe _ Nothing y = y
-unionMaybe _ x Nothing = x
-
-intersectMaybe :: (a -> b -> Maybe c) -> Maybe a -> Maybe b -> Maybe c
-intersectMaybe f (Just x) (Just y) = f x y
-intersectMaybe _ _ _ = Nothing
-
-differenceMaybe :: (a -> b -> Maybe a) -> Maybe a -> Maybe b -> Maybe a
-differenceMaybe _ Nothing _ = Nothing
-differenceMaybe _ x Nothing = x
-differenceMaybe f (Just x) (Just y) = f x y
-
-filterLeft :: a -> Either b c -> Maybe b
-filterLeft _ (Left x) = Just x
-filterLeft _ _ = Nothing
-
-filterRight :: a -> Either b c -> Maybe c
-filterRight _ (Right x) = Just x
-filterRight _ _ = Nothing
-
-{-# INLINE assocsAlg #-}
-assocsAlg :: (TrieKey k m) => m a -> [(k, a)]
-assocsAlg m = build (\ c n -> foldWithKeyAlg (\ k v xs -> (k,v) `c` xs) n m)
-
-instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 :*: f2) (t1 `ProdMap` t2) where
- compareKeyT (a :*: x) (b :*: y) = compareKeyT a b `mappend` compareKeyT x y
- emptyT = PMap emptyT
- nullT (PMap m) = nullT m
- sizeT (PMap m) = sizeT m
- getSingleT (PMap m) = do
- (k1, m') <- getSingleT m
- (k2, v) <- getSingleT m'
- return (k1 :*: k2, v)
- lookupT (k1 :*: k2) (PMap m) = lookupT k1 m >>= lookupT k2
- alterLookupT f (k1 :*: k2) (PMap m) = PMap <$> alterLookupT g k1 m where
- g = fmap guardNullT . alterLookupT f k2 . fromMaybe emptyT
- foldWithKeyT f z (PMap m) = foldWithKeyT (\ k1 -> flip (foldWithKeyT (\ k2 -> f (k1 :*: k2)))) z m
- mapAppT f (PMap m) = PMap <$> mapAppT (\ k1 -> mapAppT (\ k2 -> f (k1 :*: k2))) m
- mapMaybeT f (PMap m) = PMap (mapMaybeT (\ k1 -> guardNullT . mapMaybeT (\ k2 -> f (k1 :*: k2))) m)
- mapEitherT f (PMap m) = (PMap *** PMap) (mapEitherT (\ k1 -> (guardNullT *** guardNullT) . mapEitherT (\ k2 -> f (k1 :*: k2))) m)
- unionT f (PMap m1) (PMap m2) = PMap (unionT (\ k1 -> guardNullT .: unionT (\ k2 -> f (k1 :*: k2))) m1 m2)
- intersectT f (PMap m1) (PMap m2) = PMap (intersectT (\ k1 -> guardNullT .: intersectT (\ k2 -> f (k1 :*: k2))) m1 m2)
- differenceT f (PMap m1) (PMap m2) = PMap (differenceT (\ k1 -> guardNullT .: differenceT (\ k2 -> f (k1 :*: k2))) m1 m2)
- fromListT f xs = PMap $ mapWithKeyT (\ k1 (Elem xs) -> fromListT (\ k2 -> f (k1 :*: k2)) xs) $
- fromListT (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k1, Elem [(k2, v)]) | ((k1 :*: k2), v) <- xs]
- fromDistAscListT xs = PMap $ fromDistAscListT [(k1, fromDistAscListT ys) | (k1, ys) <- breakFst eqKeyT xs]
- fromAscListT f xs = PMap $ fromDistAscListT [(k1, fromAscListT (\ k2 -> f (k1 :*: k2)) ys) | (k1, ys) <- breakFst eqKeyT xs]
- getMinT (PMap m) = do
- ((k1, m'), m1') <- getMinT m
- ((k2, v), m2') <- getMinT m'
- return ((k1 :*: k2, v), PMap (maybe m1' (\ m2' -> insertT k1 m2' m) (guardNullT m2')))
- getMaxT (PMap m) = do
- ((k1, m'), m1') <- getMaxT m
- ((k2, v), m2') <- getMaxT m'
- return ((k1 :*: k2, v), PMap (maybe m1' (\ m2' -> insertT k1 m2' m) (guardNullT m2')))
- updateMinT f (PMap m) =
- PMap <$> updateMinT (\ k1 -> guardNullT <.> updateMinT (\ k2 -> f (k1 :*: k2))) m
- updateMaxT f (PMap m) =
- PMap <$> updateMaxT (\ k1 -> guardNullT <.> updateMaxT (\ k2 -> f (k1 :*: k2))) m
- isSubmapT (<=) (PMap m1) (PMap m2) =
- isSubmapT (isSubmapT (<=)) m1 m2
- splitLookupT f (k1 :*: k2) (PMap m) = case splitLookupT g k1 m of
- (mL, ans, mR) -> (PMap mL, ans, PMap mR)
- where g m' = case splitLookupT f k2 m' of
- (mL, ans, mR) -> (guardNullT mL, ans, guardNullT mR)
-
-instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :*: f2) k) (ProdMap t1 t2 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
-
-breakFst :: (f1 k -> f1 k -> Bool) -> [((f1 :*: f2) k, v)] -> [(f1 k, [(f2 k, v)])]
-breakFst _ [] = []
-breakFst eq (((k1 :*: k2), x):xs) = breakFst' k1 (Seq.singleton (k2, x)) xs where
- breakFst' k xs (((k' :*: k2), x):xss)
- | k `eq` k' = breakFst' k ((Seq.|>) xs (k2, x)) xss
- | otherwise = (k, toList xs):breakFst' k' (Seq.singleton (k2, x)) xss
- breakFst' k xs [] = [(k, toList xs)]
-
-instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 :+: f2) (UnionMap t1 t2) where
- compareKeyT (A a) (A b) = compareKeyT a b
- compareKeyT (B x) (B y) = compareKeyT x y
- compareKeyT A{} B{} = LT
- compareKeyT B{} A{} = GT
- emptyT = UMap emptyT emptyT
- nullT (UMap m1 m2) = nullT m1 && nullT m2
- getSingleT (UMap m1 m2) = case (getSingleT m1, getSingleT m2) of
- (Just (k, v), Nothing) -> Just (A k, v)
- (Nothing, Just (k, v)) -> Just (B k, v)
- _ -> Nothing
- sizeT (UMap m1 m2) = sizeT m1 + sizeT m2
- lookupT (A k) (UMap m1 _) = lookupT k m1
- lookupT (B k) (UMap _ m2) = lookupT k m2
- alterLookupT f (A k) (UMap m1 m2) = (`UMap` m2) <$> alterLookupT f k m1
- alterLookupT f (B k) (UMap m1 m2) = UMap m1 <$> alterLookupT f k m2
- foldWithKeyT f z (UMap m1 m2) = foldWithKeyT (f . A) (foldWithKeyT (f . B) z m2) m1
- mapAppT f (UMap m1 m2) = UMap <$> mapAppT (f . A) m1 <*> mapAppT (f . B) m2
- mapMaybeT f (UMap m1 m2) = UMap (mapMaybeT (f . A) m1) (mapMaybeT (f . B) m2)
- mapEitherT f (UMap m1 m2) = (UMap m1L m2L, UMap m1R m2R)
- where (m1L, m1R) = mapEitherT (f . A) m1
- (m2L, m2R) = mapEitherT (f . B) m2
- unionT f (UMap m11 m12) (UMap m21 m22) =
- UMap (unionT (f . A) m11 m21) (unionT (f . B) m12 m22)
- intersectT f (UMap m11 m12) (UMap m21 m22) =
- UMap (intersectT (f . A) m11 m21) (intersectT (f . B) m12 m22)
- differenceT f (UMap m11 m12) (UMap m21 m22) =
- UMap (differenceT (f . A) m11 m21) (differenceT (f . B) m12 m22)
- getMinT (UMap m1 m2)
- | Just ~(~(k, v), m1') <- getMinT m1
- = Just ((A k, v), UMap m1' m2)
- | Just ~(~(k, v), m2') <- getMinT m2
- = Just ((B k, v), UMap m1 m2')
- | otherwise = Nothing
- getMaxT (UMap m1 m2)
- | Just ~(~(k, v), m2') <- getMaxT m2
- = Just ((B k, v), UMap m1 m2')
- | Just ~(~(k, v), m1') <- getMaxT m1
- = Just ((A k, v), UMap m1' m2)
- | otherwise = Nothing
- updateMinT f (UMap m1 m2)
- | nullT m1 = UMap m1 <$> updateMinT (f . B) m2
- | otherwise = (`UMap` m2) <$> updateMinT (f . A) m1
- updateMaxT f (UMap m1 m2)
- | nullT m2 = (`UMap` m2) <$> updateMaxT (f . A) m1
- | otherwise = UMap m1 <$> updateMaxT (f . B) m2
- fromDistAscListT xs = UMap (fromDistAscListT ys) (fromDistAscListT zs)
- where (ys, zs) = partitionEithers' (map pullEither xs)
- fromAscListT f xs = UMap (fromAscListT (f . A) ys) (fromAscListT (f . B) zs)
- where (ys, zs) = partitionEithers' (map pullEither xs)
- fromListT f xs = UMap (fromListT (f . A) ys) (fromListT (f . B) zs)
- where (ys, zs) = partitionEithers' (map pullEither xs)
- isSubmapT (<=) (UMap m11 m12) (UMap m21 m22) = isSubmapT (<=) m11 m21 && isSubmapT (<=) m12 m22
- splitLookupT f (A k) (UMap m1 m2) = case splitLookupT f k m1 of
- (m1L, ans, m1R) -> (UMap m1L emptyT, ans, UMap m1R m2)
- splitLookupT f (B k) (UMap m1 m2) = case splitLookupT f k m2 of
- (m2L, ans, m2R) -> (UMap m1 m2L, ans, UMap emptyT m2R)
-
-instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :+: f2) k) (UnionMap t1 t2 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
-
-instance TrieKey k m => TrieKeyT ((,) k) (CProdMap m) where
- compareKeyT (a, x) (b, y) = compareKey a b `mappend` compareKey x y
- emptyT = CPMap emptyAlg
- nullT (CPMap m) = nullAlg m
- getSingleT (CPMap m) = do
- (k1, m') <- getSingleAlg m
- (k2, v) <- getSingleAlg m'
- return ((k1, k2), v)
- guardNullT (CPMap m) = CPMap <$> guardNullAlg m
- sizeT (CPMap m) = sizeAlg m
- lookupT (k1, k2) (CPMap m) = lookupAlg k1 m >>= lookupAlg k2
- alterLookupT f (k1, k2) (CPMap m) = CPMap <$> alterLookupAlg g k1 m where
- g = guardNullAlg <.> alterLookupAlg f k2 . fromMaybe emptyAlg
- foldWithKeyT f z (CPMap m) = foldWithKeyAlg (\ k1 -> flip $ foldWithKeyAlg (\ k2 -> f (k1, k2))) z m
- mapAppT f (CPMap m) = CPMap <$> mapAppAlg (\ k1 -> mapAppAlg (\ k2 -> f (k1, k2))) m
- mapMaybeT f (CPMap m) = CPMap (mapMaybeAlg (\ k1 -> guardNullAlg . mapMaybeAlg (\ k2 -> f (k1, k2))) m)
- mapEitherT f (CPMap m) = (CPMap *** CPMap) (mapEitherAlg (\ k1 -> (guardNullAlg *** guardNullAlg) . mapEitherAlg (\ k2 -> f (k1, k2))) m)
- unionT f (CPMap m1) (CPMap m2) =
- CPMap (unionMaybeAlg (\ k1 -> guardNullAlg .: unionMaybeAlg (\ k2 -> f (k1, k2))) m1 m2)
- intersectT f (CPMap m1) (CPMap m2) =
- CPMap (intersectAlg (\ k1 -> guardNullAlg .: intersectAlg (\ k2 -> f (k1, k2))) m1 m2)
- differenceT f (CPMap m1) (CPMap m2) =
- CPMap (differenceAlg (\ k1 -> guardNullAlg .: differenceAlg (\ k2 -> f (k1, k2))) m1 m2)
- getMinT (CPMap m) = do
- ((k1, m1), m') <- getMinAlg m
- ((k2, v), m1') <- getMinAlg m1
- return (((k1, k2), v), CPMap $ maybe m' (\ m1' -> snd $ updateMinAlg (\ _ _ -> (False, Just m1')) m) (guardNullAlg m1'))
- getMaxT (CPMap m) = do
- ((k1, m1), m') <- getMaxAlg m
- ((k2, v), m1') <- getMaxAlg m1
- return (((k1, k2), v), CPMap $ maybe m' (\ m1' -> snd $ updateMaxAlg (\ _ _ -> (False, Just m1')) m) (guardNullAlg m1'))
- updateMinT f (CPMap m) =
- CPMap <$> updateMinAlg (\ k1 -> guardNullAlg <.> updateMinAlg (\ k2 -> f (k1, k2))) m
- updateMaxT f (CPMap m) =
- CPMap <$> updateMaxAlg (\ k1 -> guardNullAlg <.> updateMaxAlg (\ k2 -> f (k1, k2))) m
- isSubmapT (<=) (CPMap m1) (CPMap m2) = isSubmapAlg (isSubmapAlg (<=)) m1 m2
- splitLookupT f (k1, k2) (CPMap m) = case splitLookupAlg g k1 m of
- (mL, ans, mR) -> (CPMap mL, ans, CPMap mR)
- where g m = case splitLookupAlg f k2 m of
- (mL, ans, mR) -> (guardNullAlg mL, ans, guardNullAlg mR)
- fromDistAscListT xs = CPMap (fromDistAscListAlg [(k1, fromDistAscListAlg ys) | (k1, ys) <- breakFst' (==) xs])
- fromAscListT f xs = CPMap (fromDistAscListAlg [(k1, fromAscListAlg (\ k2 -> f (k1, k2)) ys) | (k1, ys) <- breakFst' (==) xs])
- fromListT f xs = CPMap (mapWithKeyAlg (\ k1 (Elem ys) -> fromListAlg (\ k2 -> f (k1, k2)) ys) $
- fromListAlg (\ _ (Elem ys) (Elem zs) -> Elem (ys ++ zs)) [(k1, Elem [(k2, v)]) | ((k1, k2), v) <- xs])
-
-breakFst' :: (k1 -> k1 -> Bool) -> [((k1, k2), v)] -> [(k1, [(k2, v)])]
-breakFst' _ [] = []
-breakFst' eq (((k1, k2), x):xs) = breakFst'' k1 (Seq.singleton (k2, x)) xs where
- breakFst'' k xs (((k', k2), x):xss)
- | k `eq` k' = breakFst'' k ((Seq.|>) xs (k2, x)) xss
- | otherwise = (k, toList xs):breakFst'' k' (Seq.singleton (k2, x)) xss
- breakFst'' k xs [] = [(k, toList xs)]
-
-instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (k1, k2) (CProdMap m1 k2 m2) 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
-
-instance TrieKey k m => TrieKeyT (Either k) (CUnionMap m) where
- {-# SPECIALIZE instance TrieKeyT (Either ()) (CUnionMap Maybe) #-}
- compareKeyT (Left a) (Left b) = compareKey a b
- compareKeyT (Right a) (Right b) = compareKey a b
- compareKeyT Left{} Right{} = LT
- compareKeyT Right{} Left{} = GT
- emptyT = CUMap emptyAlg emptyAlg
- nullT (CUMap m1 m2) = nullAlg m1 && nullAlg m2
- sizeT (CUMap m1 m2) = sizeAlg m1 + sizeAlg m2
- getSingleT (CUMap m1 m2) = case (getSingleAlg m1, getSingleAlg m2) of
- (Just (k, v), Nothing) -> Just (Left k, v)
- (Nothing, Just (k, v)) -> Just (Right k, v)
- _ -> Nothing
- lookupT k (CUMap m1 m2) = either (`lookupAlg` m1) (`lookupAlg` m2) k
- alterLookupT f (Left k) (CUMap m1 m2) = (`CUMap` m2) <$> alterLookupAlg f k m1
- alterLookupT f (Right k) (CUMap m1 m2) = CUMap m1 <$> alterLookupAlg f k m2
- foldWithKeyT f z (CUMap m1 m2) = foldWithKeyAlg (f . Left) (foldWithKeyAlg (f . Right) z m2) m1
- mapAppT f (CUMap m1 m2) = CUMap <$> mapAppAlg (f . Left) m1 <*> mapAppAlg (f . Right) m2
- mapMaybeT f (CUMap m1 m2) = CUMap (mapMaybeAlg (f . Left) m1) (mapMaybeAlg (f . Right) m2)
- mapEitherT f (CUMap m1 m2) = (CUMap m1L m2L, CUMap m1R m2R)
- where (m1L, m1R) = mapEitherAlg (f . Left) m1
- (m2L, m2R) = mapEitherAlg (f . Right) m2
- unionT f (CUMap m11 m12) (CUMap m21 m22) =
- CUMap (unionMaybeAlg (f . Left) m11 m21) (unionMaybeAlg (f . Right) m12 m22)
- intersectT f (CUMap m11 m12) (CUMap m21 m22) =
- CUMap (intersectAlg (f . Left) m11 m21) (intersectAlg (f . Right) m12 m22)
- differenceT f (CUMap m11 m12) (CUMap m21 m22) =
- CUMap (differenceAlg (f . Left) m11 m21) (differenceAlg (f . Right) m12 m22)
- isSubmapT (<=) (CUMap m11 m12) (CUMap m21 m22) =
- isSubmapAlg (<=) m11 m21 && isSubmapAlg (<=) m12 m22
- splitLookupT f (Left k) (CUMap m1 m2) = case splitLookupAlg f k m1 of
- (m1L, ans, m1R) -> (CUMap m1L emptyAlg, ans, CUMap m1R m2)
- splitLookupT f (Right k) (CUMap m1 m2) = case splitLookupAlg f k m2 of
- (m2L, ans, m2R) -> (CUMap m1 m2L, ans, CUMap emptyAlg m2R)
- getMinT (CUMap m1 m2) = case (getMinAlg m1, getMinAlg m2) of
- (Just ((k, v), m1'), _) -> Just ((Left k, v), CUMap m1' m2)
- (_, Just ((k, v), m2')) -> Just ((Right k, v), CUMap m1 m2')
- _ -> Nothing
- getMaxT (CUMap m1 m2) = case (getMaxAlg m1, getMaxAlg m2) of
- (_, Just ((k, v), m2')) -> Just ((Right k, v), CUMap m1 m2')
- (Just ((k, v), m1'), _) -> Just ((Left k, v), CUMap m1' m2)
- _ -> Nothing
- updateMinT f (CUMap m1 m2)
- | nullAlg m1 = CUMap m1 <$> updateMinAlg (f . Right) m2
- | otherwise = (`CUMap` m2) <$> updateMinAlg (f . Left) m1
- updateMaxT f (CUMap m1 m2)
- | nullAlg m2 = (`CUMap` m2) <$> updateMaxAlg (f . Left) m1
- | otherwise = CUMap m1 <$> updateMaxAlg (f . Right) m2
- fromListT f xs = CUMap (fromListAlg (f . Left) ys) (fromListAlg (f . Right) zs)
- where (ys, zs) = partitionEithers (map pullEither' xs)
- fromAscListT f xs = CUMap (fromAscListAlg (f . Left) ys) (fromAscListAlg (f . Right) zs)
- where (ys, zs) = partitionEithers (map pullEither' xs)
- fromDistAscListT xs = CUMap (fromDistAscListAlg ys) (fromDistAscListAlg zs)
- where (ys, zs) = partitionEithers (map pullEither' xs)
-
-instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (Either k1 k2) (CUnionMap m1 k2 m2) where
- {-# SPECIALIZE instance TrieKey k m => TrieKey (Either () k) (CUnionMap Maybe k m) #-}
- 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
-
-partitionEithers' :: [Either a b] -> ([a], [b])
-partitionEithers' = foldr part ([], []) where
- part (Left x) (xs, ys) = (x:xs, ys)
- part (Right y) (xs, ys) = (xs, y:ys)
-
-pullEither :: ((f1 :+: f2) k, v) -> Either (f1 k, v) (f2 k, v)
-pullEither (A k, v) = Left (k, v)
-pullEither (B k, v) = Right (k, v)
-
-pullEither' :: (Either k1 k2, v) -> Either (k1, v) (k2, v)
-pullEither' (Left k, v) = Left (k, v)
-pullEither' (Right k, v) = Right (k, v)
-
-instance TrieKey k m => TrieKeyT (Const k) (ConstMap m) where
- compareKeyT (Const a) (Const b) = compareKey a b
- emptyT = ConstMap emptyAlg
- nullT (ConstMap m) = nullAlg m
- sizeT (ConstMap m) = sizeAlg m
- getSingleT (ConstMap m) = do
- (k, v) <- getSingleAlg m
- return (Const k, v)
- lookupT (Const k) (ConstMap m) = lookupAlg k m
- alterLookupT f (Const k) (ConstMap m) = ConstMap <$> alterLookupAlg f k m
- foldWithKeyT f z (ConstMap m) = foldWithKeyAlg (f . Const) z m
- mapAppT f (ConstMap m) = ConstMap <$> mapAppAlg (f . Const) m
- mapMaybeT f (ConstMap m) = ConstMap (mapMaybeAlg (f . Const) m)
- mapEitherT f (ConstMap m) = case mapEitherAlg (f . Const) m of
- (mL, mR) -> (ConstMap mL, ConstMap mR)
- unionT f (ConstMap m1) (ConstMap m2) = ConstMap (unionMaybeAlg (f . Const) m1 m2)
- intersectT f (ConstMap m1) (ConstMap m2) = ConstMap (intersectAlg (f . Const) m1 m2)
- differenceT f (ConstMap m1) (ConstMap m2) = ConstMap (differenceAlg (f . Const) m1 m2)
- fromDistAscListT xs = ConstMap (fromDistAscListAlg [(k, v) | (Const k, v) <- xs])
- fromAscListT f xs = ConstMap (fromAscListAlg (f . Const) [(k, v) | (Const k, v) <- xs])
- fromListT f xs = ConstMap (fromListAlg (f . Const) [(k, v) | (Const k, v) <- xs])
- getMinT (ConstMap m) = do
- (~(k, v), m') <- getMinAlg m
- return ((Const k, v), ConstMap m')
- getMaxT (ConstMap m) = do
- (~(k, v), m') <- getMaxAlg m
- return ((Const k, v), ConstMap m')
- updateMinT f (ConstMap m) = ConstMap <$> updateMinAlg (f . Const) m
- updateMaxT f (ConstMap m) = ConstMap <$> updateMaxAlg (f . Const) m
- isSubmapT (<=) (ConstMap m1) (ConstMap m2) = isSubmapAlg (<=) m1 m2
- splitLookupT f (Const k) (ConstMap m) = case splitLookupAlg f k m of
- (mL, ans, mR) -> (ConstMap mL, ans, ConstMap mR)
-
-instance (TrieKey k m, TrieKey k' m') => TrieKey (Const k k') (ConstMap m 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
-
-instance TrieKeyT Id IdMap where
- compareKeyT (Id a) (Id b) = compareKey a b
- emptyT = IdMap emptyAlg
- nullT (IdMap m) = nullAlg m
- sizeT (IdMap m) = sizeAlg m
- getSingleT (IdMap m) = do
- (k, v) <- getSingleAlg m
- return (Id k, v)
- lookupT (Id k) (IdMap m) = lookupAlg k m
- alterLookupT f (Id k) (IdMap m) = IdMap <$> alterLookupAlg f k m
- foldWithKeyT f z (IdMap m) = foldWithKeyAlg (f . Id) z m
- mapAppT f (IdMap m) = IdMap <$> mapAppAlg (f . Id) m
- mapMaybeT f (IdMap m) = IdMap (mapMaybeAlg (f . Id) m)
- mapEitherT f (IdMap m) = case mapEitherAlg (f . Id) m of
- (mL, mR) -> (IdMap mL, IdMap mR)
- unionT f (IdMap m1) (IdMap m2) = IdMap (unionMaybeAlg (f . Id) m1 m2)
- intersectT f (IdMap m1) (IdMap m2) = IdMap (intersectAlg (f . Id) m1 m2)
- differenceT f (IdMap m1) (IdMap m2) = IdMap (differenceAlg (f . Id) m1 m2)
- fromDistAscListT xs = IdMap (fromDistAscListAlg [(k, v) | (Id k, v) <- xs])
- fromAscListT f xs = IdMap (fromAscListAlg (f . Id) [(k, v) | (Id k, v) <- xs])
- fromListT f xs = IdMap (fromListAlg (f . Id) [(k, v) | (Id k, v) <- xs])
- getMinT (IdMap m) = do
- (~(k, v), m') <- getMinAlg m
- return ((Id k, v), IdMap m')
- getMaxT (IdMap m) = do
- (~(k, v), m') <- getMaxAlg m
- return ((Id k, v), IdMap m')
- updateMinT f (IdMap m) = IdMap <$> updateMinAlg (f . Id) m
- updateMaxT f (IdMap m) = IdMap <$> updateMaxAlg (f . Id) m
- isSubmapT (<=) (IdMap m1) (IdMap m2) = isSubmapAlg (<=) m1 m2
- splitLookupT f (Id k) (IdMap m) = case splitLookupAlg f k m of
- (mL, ans, mR) -> (IdMap mL, ans, IdMap mR)
-
-instance TrieKey k m => TrieKey (Id k) (IdMap 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
-
--- instance (Sized k, TrieKey k m) => TrieKey (SizeElem k) (SizedMap k m) where
--- compareKey (SElem a) (SElem b) = compareKey a b
--- emptyAlg = SizedMap emptyAlg
--- nullAlg (SizedMap m) = nullAlg m
--- sizeAlg (SizedMap m) = sizeAlg m
--- getSingleAlg (SizedMap m) = do
--- (k, v) <- getSingleAlg m
--- return (SElem k, v)
--- lookupAlg (SElem k) (SizedMap m) = lookupAlg k m
--- alterLookupAlg f (SElem k) (SizedMap m) = SizedMap <$> alterLookupAlg f k m
--- foldWithKeyAlg f z (SizedMap m) = foldWithKeyAlg (f . SElem) z m
--- mapAppAlg f (SizedMap m) = SizedMap <$> mapAppAlg (f . SElem) m
--- mapMaybeAlg f (SizedMap m) = SizedMap (mapMaybeAlg (f . SElem) m)
--- mapEitherAlg f (SizedMap m) = case mapEitherAlg (f . SElem) m of
--- (mL, mR) -> (SizedMap mL, SizedMap mR)
--- unionMaybeAlg f (SizedMap m1) (SizedMap m2) = SizedMap (unionMaybeAlg (f . SElem) m1 m2)
--- intersectAlg f (SizedMap m1) (SizedMap m2) = SizedMap (intersectAlg (f . SElem) m1 m2)
--- differenceAlg f (SizedMap m1) (SizedMap m2) = SizedMap (differenceAlg (f . SElem) m1 m2)
--- fromDistAscListAlg xs = SizedMap (fromDistAscListAlg [(k, v) | (SElem k, v) <- xs])
--- fromAscListAlg f xs = SizedMap (fromAscListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])
--- fromListAlg f xs = SizedMap (fromListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])
--- getMinAlg (SizedMap m) = do
--- (~(k, v), m') <- getMinAlg m
--- return ((SElem k, v), SizedMap m')
--- getMaxAlg (SizedMap m) = do
--- (~(k, v), m') <- getMaxAlg m
--- return ((SElem k, v), SizedMap m')
--- updateMinAlg f (SizedMap m) = SizedMap <$> updateMinAlg (f . SElem) m
--- updateMaxAlg f (SizedMap m) = SizedMap <$> updateMaxAlg (f . SElem) m
--- isSubmapAlg (<=) (SizedMap m1) (SizedMap m2) = isSubmapAlg (<=) m1 m2
--- splitLookupAlg f (SElem k) (SizedMap m) = case splitLookupAlg f k m of
--- (mL, ans, mR) -> (SizedMap mL, ans, SizedMap mR)
-
-instance TrieKey Int IntMap where
- compareKey = compare
- emptyAlg = IMap.empty
- nullAlg = IMap.null
- getSingleAlg m
- | IMap.size m == 1, [(k, v)] <- IMap.toList m
- = Just (k, v)
- getSingleAlg _ = Nothing
- lookupAlg = IMap.lookup
- alterLookupAlg f k m = fmap (\ v' -> IMap.alter (const v') k m) (f x)
- where x = IMap.lookup k m
- foldWithKeyAlg = IMap.foldWithKey
- mapAppAlg = sequenceA .: IMap.mapWithKey
- mapMaybeAlg = IMap.mapMaybeWithKey
- mapEitherAlg f m = (IMap.mapMaybeWithKey (fst .: f) m, IMap.mapMaybeWithKey (snd .: f) m)
- unionMaybeAlg f m1 m2 = IMap.mapMaybe (either Just id) (IMap.unionWithKey g (fmap Left m1) (fmap Left m2)) where
- g k (Left v1) (Left v2) = Right (f k v1 v2)
- g k (Right v) _ = Right v
- g k _ (Right v) = Right v
- intersectAlg f m1 m2 = IMap.mapMaybe (either (const Nothing) Just) $ IMap.intersectionWithKey g (fmap Left m1) m2 where
- g k (Left x) = maybe (Left x) Right . f k x
- g _ (Right x) = const (Right x)
- differenceAlg = IMap.differenceWithKey
- fromListAlg = IMap.fromListWithKey
- fromAscListAlg = IMap.fromAscListWithKey
- fromDistAscListAlg = IMap.fromDistinctAscList
- getMinAlg = IMap.minViewWithKey
- getMaxAlg = IMap.maxViewWithKey
- updateMinAlg f m = case IMap.minViewWithKey m of
- Just ((k, v), m') -> let (ans, v') = f k v in (ans, maybe m' (\ v' -> IMap.updateMin (const v') m) v')
- _ -> (False, m)
- updateMaxAlg f m = case IMap.maxViewWithKey m of
- Just ((k, v), m') -> let (ans, v') = f k v in (ans, maybe m' (\ v' -> IMap.updateMax (const v') m) v')
- _ -> (False, m)
- isSubmapAlg = IMap.isSubmapOfBy
- splitLookupAlg f k m = case IMap.splitLookup k m of
- (mL, Nothing, mR) -> (mL, Nothing, mR)
- (mL, Just v, mR) -> case f v of
- (vL, ans, vR) -> (maybe mL (flip (IMap.insert k) mL) vL, ans, maybe mR (flip (IMap.insert k) mR) vR)
-
-instance Ord k => TrieKey (Ordered k) (Map k) where
- compareKey = compare
- emptyAlg = Map.empty
- nullAlg = Map.null
--- sizeAlg = foldl' (\ n x -> n + getSize x) 0
- getSingleAlg m
- | Map.size m == 1, (k, v) <- Map.findMin m
- = Just (Ord k, v)
- lookupAlg = Map.lookup . unOrd
- alterLookupAlg f (Ord k) m = fmap (\ v -> Map.alter (const v) k m) (f x)
- where x = Map.lookup k m
- foldWithKeyAlg f = Map.foldWithKey (f . Ord)
- mapAppAlg f = sequenceA . Map.mapWithKey (f . Ord)
- mapMaybeAlg f = Map.mapMaybeWithKey (f . Ord)
- mapEitherAlg f m = (Map.mapMaybeWithKey (fst .: f . Ord) m, Map.mapMaybeWithKey (snd .: f . Ord) m)
- unionMaybeAlg f m1 m2 = Map.mapMaybe (either Just id) (Map.unionWithKey g (fmap Left m1) (fmap Left m2)) where
- g k (Left v1) (Left v2) = Right (f (Ord k) v1 v2)
- g k (Right v) _ = Right v
- g k _ (Right v) = Right v
- intersectAlg f = Map.mapMaybe id .: Map.intersectionWithKey (f . Ord)
- differenceAlg f = Map.differenceWithKey (f . Ord)
- fromListAlg f xs = Map.fromListWithKey (f . Ord) [(k, v) | (Ord k, v) <- xs]
- fromAscListAlg f xs = Map.fromAscListWithKey (f . Ord) [(k, v) | (Ord k, v) <- xs]
- fromDistAscListAlg xs = Map.fromDistinctAscList [(k, v) | (Ord k, v) <- xs]
- getMinAlg m = do (~(k, v), m') <- Map.minViewWithKey m
- return ((Ord k, v), m')
- getMaxAlg m = do (~(k, v), m') <- Map.maxViewWithKey m
- return ((Ord k, v), m')
- updateMinAlg f m
- | Map.null m = (False, m)
- | otherwise = case Map.findMin m of
- (k, v) -> let (ans, v') = f (Ord k) v in (ans, Map.updateMin (const v') m)
- updateMaxAlg f m
- | Map.null m = (False, m)
- | otherwise = case Map.findMin m of
- (k, v) -> let (ans, v') = f (Ord k) v in (ans, Map.updateMax (const v') m)
- isSubmapAlg = Map.isSubmapOfBy
- splitLookupAlg f (Ord k) m = case Map.splitLookup k m of
- (mL, Nothing, mR) -> (mL, Nothing, mR)
- (mL, Just v, mR) -> case f v of
- (vL, ans, vR) -> (maybe mL (flip (Map.insert k) mL) vL, ans, maybe mR (flip (Map.insert k) mR) vR)
-
-instance TrieKey () Maybe where
- compareKey _ _ = EQ
- emptyAlg = Nothing
- nullAlg = isNothing
- sizeAlg = maybe 0 getSize
- getSingleAlg = fmap ((,) ())
- lookupAlg _ = id
- alterLookupAlg f _ = f
- foldWithKeyAlg f = foldr (f ())
- mapAppAlg f = traverse (f ())
- mapMaybeAlg f = (>>= f ())
- mapEitherAlg f = maybe (Nothing, Nothing) (f ())
- unionMaybeAlg f = unionMaybe (f ())
- intersectAlg f = intersectMaybe (f ())
- differenceAlg f = differenceMaybe (f ())
- 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
- g v = (((), v), Nothing)
- updateMinAlg f = maybe (False, Nothing) (f ())
- updateMaxAlg f = maybe (False, Nothing) (f ())
- isSubmapAlg _ Nothing _ = True
- isSubmapAlg _ _ Nothing = False
- isSubmapAlg (<=) (Just x) (Just y) = x <= y
- splitLookupAlg f _ = maybe (Nothing, Nothing, Nothing) f
-
-{-# 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;
- #-}
-
-instance (TrieKeyT f t, TrieKey k m) => TrieKey (App f k) (App (t k m)) where
- compareKey (App a) (App b) = compareKeyT a b
- emptyAlg = App emptyT
- nullAlg (App m) = nullT m
- getSingleAlg (App m) = do
- (k, v) <- getSingleT m
- return (App k, v)
- alterLookupAlg f (App k) (App m) = App <$> alterLookupT f k m
- foldWithKeyAlg f z (App m) = foldWithKeyT (f . App) z m
- mapAppAlg f (App m) = App <$> mapAppT (f . App) m
- mapMaybeAlg f (App m) = App (mapMaybeT (f . App) m)
- mapEitherAlg f (App m) = (App *** App) (mapEitherT (f . App) m)
- fromListAlg f xs = App (fromListT (f . App) [(k, v) | (App k, v) <- xs])
- fromAscListAlg f xs = App (fromAscListT (f . App) [(k, v) | (App k, v) <- xs])
- fromDistAscListAlg xs = App (fromDistAscListT [(k, v) | (App k, v) <- xs])
- unionMaybeAlg f (App m1) (App m2) = App (unionT (f . App) m1 m2)
- intersectAlg f (App m1) (App m2) = App (intersectT (f . App) m1 m2)
- differenceAlg f (App m1) (App m2) = App (differenceT (f . App) m1 m2)
- getMinAlg (App m) = do
- ((k, v), m') <- getMinT m
- return ((App k, v), App m')
- getMaxAlg (App m) = do
- ((k, v), m') <- getMaxT m
- return ((App k, v), App m')
- updateMinAlg f (App m) = App <$> updateMinT (f . App) m
- updateMaxAlg f (App m) = App <$> updateMaxT (f . App) m
- isSubmapAlg (<=) (App m1) (App m2) = isSubmapT (<=) m1 m2
- splitLookupAlg f (App k) (App m) = case splitLookupT f k m of
- (mL, ans, mR) -> (App mL, ans, App mR)
-
-instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 `O` f2) (CompMap t1 f2 t2) where
- compareKeyT (O a) (O b) = compareKeyT a b
- emptyT = CompMap emptyT
- nullT (CompMap m) = nullT m
- guardNullT (CompMap m) = CompMap <$> guardNullT m
- sizeT (CompMap m) = sizeT m
- getSingleT (CompMap m) = do
- (k, v) <- getSingleT m
- return (O k, v)
- lookupT (O k) (CompMap m) = lookupT k m
- alterLookupT f (O k) (CompMap m) = CompMap <$> alterLookupT f k m
- foldWithKeyT f z (CompMap m) = foldWithKeyT (f . O) z m
- mapAppT f (CompMap m) = CompMap <$> mapAppT (f . O) m
- mapMaybeT f (CompMap m) = CompMap (mapMaybeT (f . O) m)
- mapEitherT f (CompMap m) = (CompMap *** CompMap) (mapEitherT (f . O) m)
- unionT f (CompMap m1) (CompMap m2) = CompMap (unionT (f . O) m1 m2)
- intersectT f (CompMap m1) (CompMap m2) = CompMap (intersectT (f . O) m1 m2)
- differenceT f (CompMap m1) (CompMap m2) = CompMap (differenceT (f . O) m1 m2)
- fromDistAscListT xs = CompMap (fromDistAscListT [(k, v) | (O k, v) <- xs])
- fromAscListT f xs = CompMap (fromAscListT (f . O) [(k, v) | (O k, v) <- xs])
- fromListT f xs = CompMap (fromListT (f . O) [(k, v) | (O k, v) <- xs])
- getMinT (CompMap m) = do
- ((k, v), m') <- getMinT m
- return ((O k, v), CompMap m')
- getMaxT (CompMap m) = do
- ((k, v), m') <- getMaxT m
- return ((O k, v), CompMap m')
- updateMinT f (CompMap m) = CompMap <$> updateMinT (f . O) m
- updateMaxT f (CompMap m) = CompMap <$> updateMaxT (f . O) m
- isSubmapT (<=) (CompMap m1) (CompMap m2) = isSubmapT (<=) m1 m2
- splitLookupT f (O k) (CompMap m) = case splitLookupT f k m of
- (mL, ans, mR) -> (CompMap mL, ans, CompMap mR)
-
-instance (TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 `O` f2) k) (CompMap t1 f2 t2 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 \ No newline at end of file