summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLouisWasserman <>2009-10-14 19:07:43 (GMT)
committerLuite Stegeman <luite@luite.com>2009-10-14 19:07:43 (GMT)
commit6d4ac0e48f4a3fb8b7022f86e4a9e55b463662cd (patch)
treea81523ff048f21b66a592af390a8cbdc531642fc
parent7f73bb8a254ca5f9b2e2cfc68728f6bee0cfed6c (diff)
version 0.5.20.5.2
-rw-r--r--Data/TrieMap.hs151
-rw-r--r--Data/TrieMap/Applicative.hs52
-rw-r--r--Data/TrieMap/Class.hs21
-rw-r--r--Data/TrieMap/Class/Instances.hs237
-rw-r--r--Data/TrieMap/IntMap.hs351
-rw-r--r--Data/TrieMap/Modifiers.hs12
-rw-r--r--Data/TrieMap/MultiRec.hs3
-rw-r--r--Data/TrieMap/MultiRec/Base.hs105
-rw-r--r--Data/TrieMap/MultiRec/Class.hs157
-rw-r--r--Data/TrieMap/MultiRec/ConstMap.hs49
-rw-r--r--Data/TrieMap/MultiRec/Eq.hs9
-rw-r--r--Data/TrieMap/MultiRec/FamMap.hs135
-rw-r--r--Data/TrieMap/MultiRec/FixMap.hs37
-rw-r--r--Data/TrieMap/MultiRec/IMap.hs106
-rw-r--r--Data/TrieMap/MultiRec/Instances.hs5
-rw-r--r--Data/TrieMap/MultiRec/Ord.hs11
-rw-r--r--Data/TrieMap/MultiRec/ProdMap.hs218
-rw-r--r--Data/TrieMap/MultiRec/Sized.hs4
-rw-r--r--Data/TrieMap/MultiRec/TH.hs89
-rw-r--r--Data/TrieMap/MultiRec/TagMap.hs106
-rw-r--r--Data/TrieMap/MultiRec/UnionMap.hs125
-rw-r--r--Data/TrieMap/MultiRec/UnitMap.hs51
-rw-r--r--Data/TrieMap/OrdMap.hs219
-rw-r--r--Data/TrieMap/Regular/Base.hs11
-rw-r--r--Data/TrieMap/Regular/Class.hs90
-rw-r--r--Data/TrieMap/Regular/CompMap.hs89
-rw-r--r--Data/TrieMap/Regular/ConstMap.hs36
-rw-r--r--Data/TrieMap/Regular/Eq.hs27
-rw-r--r--Data/TrieMap/Regular/IdMap.hs29
-rw-r--r--Data/TrieMap/Regular/Instances.hs4
-rw-r--r--Data/TrieMap/Regular/Ord.hs34
-rw-r--r--Data/TrieMap/Regular/ProdMap.hs129
-rw-r--r--Data/TrieMap/Regular/RadixTrie.hs258
-rw-r--r--Data/TrieMap/Regular/RegMap.hs20
-rw-r--r--Data/TrieMap/Regular/Rep.hs71
-rw-r--r--Data/TrieMap/Regular/Sized.hs2
-rw-r--r--Data/TrieMap/Regular/TH.hs46
-rw-r--r--Data/TrieMap/Regular/UnionMap.hs105
-rw-r--r--Data/TrieMap/Regular/UnitMap.hs53
-rw-r--r--Data/TrieMap/Rep.hs26
-rw-r--r--Data/TrieMap/Rep/Instances.hs236
-rw-r--r--Data/TrieMap/Rep/TH.hs54
-rw-r--r--Data/TrieMap/Representation.hs6
-rw-r--r--Data/TrieMap/Representation/TH.hs3
-rw-r--r--Data/TrieMap/ReverseMap.hs59
-rw-r--r--Data/TrieMap/Sized.hs4
-rw-r--r--Data/TrieMap/TrieKey.hs118
-rw-r--r--Data/TrieSet.hs173
-rw-r--r--TrieMap.cabal22
49 files changed, 2721 insertions, 1237 deletions
diff --git a/Data/TrieMap.hs b/Data/TrieMap.hs
index 2bf740a..af1b2ac 100644
--- a/Data/TrieMap.hs
+++ b/Data/TrieMap.hs
@@ -16,7 +16,7 @@ module Data.TrieMap (
findWithDefault,
-- * Construction
empty,
- showMap,
+-- showMap,
singleton,
-- ** Insertion
insert,
@@ -87,6 +87,16 @@ module Data.TrieMap (
-- * Submap
isSubmapOf,
isSubmapOfBy,
+ -- * Indexed
+ predecessor,
+ lookupWithIndex,
+ successor,
+ neighborhood,
+ lookupIndex,
+ predecessorAt,
+ lookupAt,
+ successorAt,
+ neighborhoodAt,
-- * Min/Max
findMin,
findMax,
@@ -108,9 +118,12 @@ import Data.TrieMap.Class
import Data.TrieMap.Class.Instances()
import Data.TrieMap.TrieKey
import Data.TrieMap.Applicative
+import Data.TrieMap.Rep
+import Data.TrieMap.Sized
import Control.Applicative hiding (empty)
import Control.Arrow
+import Control.Monad
import Data.Maybe hiding (mapMaybe)
import Data.Monoid(First(..), Last(..))
-- import Data.Foldable
@@ -143,7 +156,7 @@ 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
+lookup k (TMap m) = getElem <$> lookupM (toRep k) m
findWithDefault :: TKey k => a -> k -> TMap k a -> a
findWithDefault a = fromMaybe a .: lookup
@@ -152,7 +165,34 @@ findWithDefault a = fromMaybe a .: lookup
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)
+alter f k (TMap m) = TMap (alterM elemSize (fmap Elem . f . fmap getElem) (toRep k) m)
+
+-- | Projects information out of an individual association pair, over all alternatives in the map.
+-- For example,
+--
+-- > minViewWithKey == getFirst (extract (\ k a -> return ((k, a), Nothing)))
+-- > updateMaxWithKey f m == maybe m snd (getLast (extract (\ k a -> return ((), f k a)) m))
+--
+-- In addition,
+--
+-- > getFirst (extract (\ k a -> if p k a then return ((k, a), Nothing) else mzero) m)
+--
+-- finds and removes the first association pair satisfying the predicate |p|.
+
+extract :: (TKey k, MonadPlus m) => (k -> a -> m (x, Maybe a)) -> TMap k a -> m (x, TMap k a)
+extract f m = unwrapMonad (extractA (WrapMonad .: f) m)
+
+-- | Generalization of 'extract' for 'Alternative' functors.
+extractA :: (TKey k, Alternative f) => (k -> a -> f (x, Maybe a)) -> TMap k a -> f (x, TMap k a)
+extractA f (TMap m) = second TMap <$> extractM elemSize (\ k (Elem a) -> second (fmap Elem) <$> f (fromRep k) a) m
+
+-- | Like 'extract', but does not modify the map.
+about :: (TKey k, MonadPlus m) => (k -> a -> m x) -> TMap k a -> m x
+about f = unwrapMonad . aboutA (WrapMonad .: f)
+
+-- | Generalization of 'about' for 'Alternative' functors.
+aboutA :: (TKey k, Alternative f) => (k -> a -> f x) -> TMap k a -> f x
+aboutA f = fst <.> extractA (\ k a -> flip (,) Nothing <$> f k a)
insert :: TKey k => k -> a -> TMap k a -> TMap k a
insert = insertWith const
@@ -183,20 +223,20 @@ 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
+foldWithKey f z (TMap m) = foldWithKeyM (\ k (Elem 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
+foldlWithKey f z (TMap m) = foldlWithKeyM (\ k z (Elem 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
+traverseWithKey f (TMap m) = TMap <$> traverseWithKeyM elemSize (\ k (Elem a) -> Elem <$> 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)
+mapWithKey f (TMap m) = TMap (mapWithKeyM elemSize (\ k (Elem a) -> Elem (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]
@@ -220,8 +260,8 @@ unionMaybeWith :: TKey k => (a -> a -> Maybe a) -> TMap k a -> TMap k a -> TMap
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
+unionMaybeWithKey f (TMap m1) (TMap m2) = TMap (unionM elemSize f' m1 m2) where
+ f' k (Elem a) (Elem b) = Elem <$> f (fromRep k) a b
symmetricDifference :: TKey k => TMap k a -> TMap k a -> TMap k a
symmetricDifference = unionMaybeWith (\ _ _ -> Nothing)
@@ -239,8 +279,8 @@ intersectionMaybeWith :: TKey k => (a -> b -> Maybe c) -> TMap k a -> TMap k b -
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
+intersectionMaybeWithKey f (TMap m1) (TMap m2) = TMap (isectM elemSize f' m1 m2) where
+ f' k (Elem a) (Elem b) = Elem <$> f (fromRep k) a b
difference, (\\) :: TKey k => TMap k a -> TMap k b -> TMap k a
difference = differenceWith (\ x _ -> Nothing)
@@ -251,8 +291,8 @@ differenceWith :: TKey k => (a -> b -> Maybe a) -> TMap k a -> TMap k b -> TMap
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
+differenceWithKey f (TMap m1) (TMap m2) = TMap (diffM elemSize f' m1 m2) where
+ f' k (Elem a) (Elem b) = Elem <$> f (fromRep k) a b
minView, maxView :: TKey k => TMap k a -> Maybe (a, TMap k a)
minView m = first snd <$> minViewWithKey m
@@ -271,20 +311,16 @@ 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)
+updateMinWithKey f m = maybe m snd (getFirst (extract (\ k a -> return ((), f k a)) m))
+updateMaxWithKey f m = maybe m snd (getLast (extract (\ k a -> return ((), f 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')
+minViewWithKey = getFirst . extract (\ k a -> return ((k, a), Nothing))
+maxViewWithKey = getLast . extract (\ k a -> return ((k, a), Nothing))
elems :: TKey k => TMap k a -> [a]
elems = fmap snd . assocs
@@ -299,18 +335,18 @@ 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
+mapEitherWithKey f (TMap m) = case mapEitherM elemSize elemSize 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))
+ where f' k (Elem a) = case f (fromRep k) a of
+ Left b -> (Just (Elem b), Nothing)
+ Right c -> (Nothing, Just (Elem 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)
+mapMaybeWithKey f (TMap m) = TMap (snd (mapEitherM elemSize elemSize f' m)) where
+ f' k (Elem a) = (Nothing, Elem <$> f (fromRep k) a)
partition :: TKey k => (a -> Bool) -> TMap k a -> (TMap k a, TMap k a)
partition = partitionWithKey . const
@@ -329,16 +365,16 @@ 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
+splitLookup k (TMap m) = case splitLookupM elemSize f (toRep k) m of
(mL, x, mR) -> (TMap mL, x, TMap mR)
- where f (K0 x) = (Nothing, Just x, Nothing)
+ where f (Elem 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
+ Elem a <<= Elem b = a <= b
fromList, fromAscList :: TKey k => [(k, a)] -> TMap k a
fromList = fromListWith const
@@ -349,14 +385,14 @@ 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])
+fromListWithKey f xs = TMap (fromListM elemSize (\ k (Elem a) (Elem b) -> Elem (f (fromRep k) a b)) [(toRep k, Elem a) | (k, a) <- xs])
+fromAscListWithKey f xs = TMap (fromAscListM elemSize (\ k (Elem a) (Elem b) -> Elem (f (fromRep k) a b)) [(toRep k, Elem a) | (k, a) <- xs])
fromDistinctAscList :: TKey k => [(k, a)] -> TMap k a
-fromDistinctAscList xs = TMap (fromDistAscListM sizeK0 [(toRep k, K0 a) | (k, a) <- xs])
+fromDistinctAscList xs = TMap (fromDistAscListM elemSize [(toRep k, Elem a) | (k, a) <- xs])
size :: TKey k => TMap k a -> Int
-size (TMap m) = sizeM sizeK0 m
+size (TMap m) = sizeM elemSize m
member :: TKey k => k -> TMap k a -> Bool
member = isJust .: lookup
@@ -364,5 +400,48 @@ member = isJust .: lookup
notMember :: TKey k => k -> TMap k a -> Bool
notMember = not .: member
-showMap :: (TKey k, Show (TrieMap (Rep k) (K0 a) (Rep k))) => TMap k a -> String
-showMap (TMap m) = show m \ No newline at end of file
+-- showMap :: (TKey k, Show (TrieMap (Rep k) (Elem a) (Rep k))) => TMap k a -> String
+-- showMap (TMap m) = show m
+
+-- | @'predecessor' k a@ returns the index, key, and value of the immediate predecessor of @k@ in the map.
+-- The predecessor is the element with the largest key @< k@.
+predecessor :: TKey k => k -> TMap k a -> Maybe (Int, k, a)
+predecessor k m = fst3 (neighborhood k m)
+
+lookupIndex :: TKey k => k -> TMap k a -> Maybe Int
+lookupIndex k m = fst3 <$> lookupWithIndex k m
+
+fst3 (a, b, c) = a
+snd3 (a, b, c) = b
+thd3 (a, b, c) = c
+
+findIndex :: TKey k => k -> TMap k a -> Int
+findIndex k m = fromMaybe (error "element is not in the map") (lookupIndex k m)
+
+lookupWithIndex :: TKey k => k -> TMap k a -> Maybe (Int, k, a)
+lookupWithIndex k m = snd3 (neighborhood k m)
+
+successor :: TKey k => k -> TMap k a -> Maybe (Int, k, a)
+successor k m = thd3 (neighborhood k m)
+
+neighborhood :: TKey k => k -> TMap k a -> (Maybe (Int, k, a), Maybe (Int, k, a), Maybe (Int, k, a))
+neighborhood k (TMap m) = case lookupIxM elemSize (toRep k) m of
+ (pr, x, su) -> (fix <$> getLast pr, fix <$> x, fix <$> getFirst su)
+ where fix (Asc i k (Elem a)) = (i, fromRep k, a)
+
+predecessorAt :: TKey k => Int -> TMap k a -> Maybe (Int, k, a)
+predecessorAt k m = fst3 (neighborhoodAt k m)
+
+lookupAt :: TKey k => Int -> TMap k a -> Maybe (Int, k, a)
+lookupAt k m = snd3 (neighborhoodAt k m)
+
+successorAt :: TKey k => Int -> TMap k a -> Maybe (Int, k, a)
+successorAt k m = thd3 (neighborhoodAt k m)
+
+neighborhoodAt :: TKey k => Int -> TMap k a -> (Maybe (Int, k, a), Maybe (Int, k, a), Maybe (Int, k, a))
+neighborhoodAt i (TMap m) = case assocAtM elemSize i m of
+ (pr, x, su) -> (fix <$> getLast pr, fix <$> x, fix <$> getFirst su)
+ where fix (Asc i k (Elem a)) = (i, fromRep k, a)
+
+keysSet :: TKey k => TMap k a -> TSet k
+keysSet = TSet . map (const ()) \ No newline at end of file
diff --git a/Data/TrieMap/Applicative.hs b/Data/TrieMap/Applicative.hs
index 3618bc3..5962575 100644
--- a/Data/TrieMap/Applicative.hs
+++ b/Data/TrieMap/Applicative.hs
@@ -3,17 +3,33 @@
module Data.TrieMap.Applicative where
import Control.Applicative
+import Control.Arrow
import Control.Monad
-import Data.Monoid
+import Data.Monoid hiding (Dual)
newtype Id a = Id {unId :: a}
+newtype WM w m a = WM {runWM :: m (w, a)}
deriving instance Functor First
deriving instance Functor Last
deriving instance Monad First
deriving instance Monad Last
+instance Functor m => Functor (WM w m) where
+ fmap f (WM x) = WM (fmap (second f) x)
+
+instance (Applicative m, Monoid w) => Applicative (WM w m) where
+ pure x = WM (pure (mempty, x))
+ WM f <*> WM x = WM (fmap (\ (fW, ff) (xW, xx) -> (fW `mappend` xW, ff xx)) f <*> x)
+
+instance (Alternative m, Monoid w) => Alternative (WM w m) where
+ empty = WM empty
+ WM a <|> WM b = WM (a <|> b)
+
+write :: (Functor m, Monoid w) => w -> WM w m a -> WM w m a
+write w (WM m) = WM (fmap (\ (v, xx) -> (v `mappend` w, xx)) m)
+
instance Applicative Id where
pure = Id
Id f <*> Id x = Id (f x)
@@ -43,4 +59,36 @@ instance MonadPlus Last where
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
+(f <.:> g) x y = f <$> g x y
+{-
+(<|>) :: MonadPlus m => m a -> m a -> m a
+(<|>) = mplus-}
+
+instance Applicative First where
+ pure = return
+ (<*>) = ap
+
+instance Alternative First where
+ empty = mempty
+ (<|>) = mplus
+
+instance Applicative Last where
+ pure = return
+ (<*>) = ap
+
+instance Alternative Last where
+ empty = mempty
+ (<|>) = mplus
+
+newtype Dual f a = Dual {runDual :: f a}
+
+instance Functor f => Functor (Dual f) where
+ fmap f (Dual x) = Dual (fmap f x)
+
+instance Applicative f => Applicative (Dual f) where
+ pure = Dual . pure
+ Dual f <*> Dual x = Dual (flip ($) <$> x <*> f)
+
+instance Alternative f => Alternative (Dual f) where
+ empty = Dual empty
+ Dual a <|> Dual b = Dual (b <|> a) \ No newline at end of file
diff --git a/Data/TrieMap/Class.hs b/Data/TrieMap/Class.hs
index 5301bf1..277d505 100644
--- a/Data/TrieMap/Class.hs
+++ b/Data/TrieMap/Class.hs
@@ -1,36 +1,41 @@
{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}
-module Data.TrieMap.Class (TMap(..), TKey(..), Rep, Ordered (..), TrieMap, TrieKey) where
+module Data.TrieMap.Class (TMap(..), TSet (..), TKey, TKeyT, Rep, TrieMap, TrieKey) where
import Data.TrieMap.TrieKey
import Data.TrieMap.OrdMap
+import Data.TrieMap.Rep
+import Data.TrieMap.Sized
import Control.Applicative
import Data.Foldable
import Data.Traversable
-- import Generics.MultiRec.Base
+import Data.TrieMap.Regular.Class
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)}
+newtype TMap k a = TMap {getTMap :: TrieMap (Rep k) (Elem a)}
+newtype TSet a = TSet (TMap a ())
-type family Rep k
+class (Repr k, TrieKey (Rep k) (TrieMap (Rep k))) => TKey k
+-- toRep :: k -> Rep k
+-- fromRep :: Rep k -> k
-class TrieKey (Rep k) (TrieMap (Rep k)) => TKey k where
- toRep :: k -> Rep k
- fromRep :: Rep k -> k
+class (ReprT f, TrieKeyT (RepT f) (TrieMapT (RepT f))) => TKeyT f
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
+ foldr f z (TMap m) = foldWithKeyM (\ _ (Elem 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
+trv f (TMap m) = TMap <$> traverseWithKeyM elemSize (\ _ (Elem a) -> Elem <$> f a) m \ No newline at end of file
diff --git a/Data/TrieMap/Class/Instances.hs b/Data/TrieMap/Class/Instances.hs
index c6bb235..f8047ab 100644
--- a/Data/TrieMap/Class/Instances.hs
+++ b/Data/TrieMap/Class/Instances.hs
@@ -1,14 +1,22 @@
-{-# LANGUAGE CPP, Rank2Types, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell, CPP, Rank2Types, TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
module Data.TrieMap.Class.Instances where
import Data.TrieMap.Class
import Data.TrieMap.TrieKey
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.TH
+import Data.TrieMap.Rep.Instances
+import Data.TrieMap.Sized
-- import Data.TrieMap.RadixTrie()
import Data.TrieMap.MultiRec.Instances
-import Data.TrieMap.IntMap()
-import Data.TrieMap.OrdMap(Ordered(..))
+import Data.TrieMap.IntMap
+import Data.TrieMap.OrdMap
+import Data.TrieMap.ReverseMap
+import Data.TrieMap.ProdMap
+import Data.TrieMap.UnionMap
import Data.TrieMap.Class
+import Data.TrieMap.Modifiers
import Data.TrieMap.Regular.Base
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Instances
@@ -23,6 +31,9 @@ import Data.Foldable
import Data.Int
import Data.List hiding (foldr)
import Data.Word
+import Data.Array.IArray
+import Data.Map(Map)
+import Data.Set(Set)
import Prelude hiding (foldr)
@@ -39,164 +50,62 @@ instance TKey k => TKey [k] where
toRep = map toRep
fromRep = map fromRep-}
-type instance Rep Int = Int
-instance TKey Int where
- toRep = id
- fromRep = id
-
-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 = (I0 :+: I0) (Rep [Int32])
-instance TKey Integer where
- toRep x = (if x >= 0 then R . I0 else L . I0) (toRep (unroll x))
- fromRep (L (I0 xs)) = - roll (map negate (fromRep xs))
- fromRep (R (I0 xs)) = roll (fromRep xs)
-
-unroll :: Integer -> [Int32]
-unroll x = if x >= 0 then unfoldr step x else map negate (unfoldr step (negate x)) 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 Bool = (U0 :+: U0) (U0 ())
-instance TKey Bool where
- toRep False = L U0
- toRep True = R U0
- fromRep L{} = False
- fromRep R{} = True
-
-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
-
-type instance Rep (TMap k a) = L (K0 (Rep k) :*: I0) (Rep a)
-instance (TKey k, TKey a) => TKey (TMap k a) where
- toRep (TMap m) = List [K0 k :*: I0 (toRep a) | (k, K0 a) <- foldWithKeyM (curry (:)) m []]
- fromRep (List xs) = TMap (fromDistAscListM (const 1) [(k, K0 (fromRep a)) | K0 k :*: I0 a <- xs])
+instance TKey Int
+instance TKey Double
+instance TKey Char
+instance TKey Bool
+instance TKey Word
+instance TKey Int32
+instance TKey Word32
+instance TKey Word16
+instance TKey Word8
+instance TKey Int8
+instance TKey Int16
+instance TKey Word64
+instance TKey Int64
+instance TKey ()
+instance TKey a => TKeyT ((,) a)
+instance (TKey a, TKey b) => TKey (a, b)
+instance (TKey a, TKey b) => TKeyT ((,,) a b)
+instance (TKey a, TKey b, TKey c) => TKey (a, b, c)
+instance (TKey a, TKey b, TKey c) => TKeyT ((,,,) a b c)
+instance (TKey a, TKey b, TKey c, TKey d) => TKey (a, b, c, d)
+instance TKey a => TKey (I0 a)
+instance TKeyT I0
+instance TKey (U0 a)
+instance TKeyT U0
+instance TKey a => TKey (K0 a b)
+instance TKey a => TKeyT (K0 a)
+instance TKeyT f => TKeyT (L f)
+instance (TKeyT f, TKey a) => TKey (L f a)
+instance (Functor f, TKeyT f, TKeyT g) => TKeyT (f `O` g)
+instance (TKeyT f, TKeyT g, TKey a) => TKey ((f `O` g) a)
+instance (TKeyT f, TKeyT g) => TKeyT (f :*: g)
+instance (TKeyT f, TKeyT g, TKey a) => TKey ((f :*: g) a)
+instance (TKey a, TKey b) => TKey (Either a b)
+instance TKey a => TKeyT (Either a)
+instance TKey a => TKey [a]
+instance TKeyT []
+instance TKey a => TKey (Maybe a)
+instance TKeyT Maybe
+instance (TKey k, TKey a) => TKey (TMap k a)
+instance TKey k => TKeyT (TMap k)
+instance TKeyT Set
+instance TKeyT Rev
+instance TKey a => TKey (Rev a)
+instance TKey a => TKey (Set a)
+instance TKey k => TKeyT (Map k)
+instance (TKey k, TKey a) => TKey (Map k a)
+instance (TKey i, Ix i) => TKeyT (Array i)
+instance (TKey i, Ix i, TKey e) => TKey (Array i e)
+
+type instance RepT (TMap k) = L (K0 (Rep k) :*: I0)
+type instance Rep (TMap k a) = RepT (TMap k) (Rep a)
+
+instance TKey k => ReprT (TMap k) where
+ toRepTMap f (TMap m) = List (foldWithKeyM (\ k (Elem a) xs -> (K0 k :*: I0 (f a)):xs) m [])
+ fromRepTMap f (List xs) = TMap (fromDistAscListM (const 1) [(k, Elem (f a)) | (K0 k :*: I0 a) <- xs])
+
+instance (TKey k, Repr a) => Repr (TMap k a) where
+ toRep = toRepTMap toRep
+ fromRep = fromRepTMap fromRep
diff --git a/Data/TrieMap/IntMap.hs b/Data/TrieMap/IntMap.hs
index aa81e23..79fcef1 100644
--- a/Data/TrieMap/IntMap.hs
+++ b/Data/TrieMap/IntMap.hs
@@ -1,18 +1,24 @@
-{-# LANGUAGE BangPatterns, Rank2Types, CPP, MagicHash, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell, TypeOperators, UndecidableInstances, BangPatterns, Rank2Types, CPP, MagicHash, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}
module Data.TrieMap.IntMap () where
import Data.TrieMap.TrieKey
+import Data.TrieMap.MultiRec.Base
import Data.TrieMap.Applicative
import Data.TrieMap.Sized
+import Data.TrieMap.ReverseMap
+-- import Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.TH
-import Control.Applicative (Applicative(..), (<$>))
+import Control.Applicative (Applicative(..), Alternative(..), (<$>))
import Control.Arrow
+import Control.Monad (MonadPlus(..))
import Data.Bits
import Data.Maybe
import Data.Monoid
import Data.Word
+import Data.Int
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts ( Word(..), Int(..), shiftRL# )
@@ -25,27 +31,46 @@ import Data.Word
import Prelude hiding (lookup, null, foldl, foldr)
-type Nat = Word
+type Nat = Word32
-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)
+data WordMap a = Nil
+ | Tip {-# UNPACK #-} !Size {-# UNPACK #-} !Key (a)
+ | Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(WordMap a) !(WordMap a)
deriving (Show)
-type instance TrieMap Int = IntMap
+-- data IntMap a = IMap (WordMap a) (WordMap a)
+type instance TrieMap Word32 = WordMap
+-- type instance TrieMap Int32 = IntMap
-type Prefix = Int
-type Mask = Int
-type Key = Int
+type Prefix = Word32
+type Mask = Word32
+type Key = Word32
type Size = Int
-instance TrieKey Int IntMap where
+-- type instance RepT WordMap = FamT KeyFam (HFix (U :+: (K Size :*: K Key :*: X) :+:
+-- (K Size :*: K Prefix :*: K Mask :*: A0 :*: A0)))
+-- type instance Rep (WordMap a) = RepT WordMap (Rep a)
+--
+-- -- $(genRepT [d|
+-- instance ReprT WordMap where
+-- toRepT = FamT . toFix where
+-- toFix = HIn . toFix'
+-- toFix' Nil = L U
+-- toFix' (Tip s kx x) = R (L (K s :*: K kx :*: X x))
+-- toFix' (Bin s p m l r) = R (R (K s :*: K p :*: K m :*: A0 (toFix l) :*: A0 (toFix r)))
+-- fromRepT (FamT m) = fromFix m where
+-- fromFix (HIn x) = fromFix' x
+-- fromFix' L{} = Nil
+-- fromFix' (R (L (K s :*: K kx :*: X x))) = Tip s kx x
+-- fromFix' (R (R (K s :*: K p :*: K m :*: A0 l :*: A0 r))) = Bin s p m (fromFix l) (fromFix r) |])
+
+instance TrieKey Word32 WordMap where
emptyM = Nil
nullM = null
sizeM _ = size
- lookupM = lookup . natFromInt
- lookupIxM _ = lookupIx . natFromInt
- assocAtM _ = fromJust .: assocAt
- updateAtM = updateAt
+ lookupM = lookup
+ lookupIxM s = lookupIx s 0
+ assocAtM s = assocAt s 0
+-- updateAtM s r = updateAt s r 0
alterM = alter
traverseWithKeyM = traverseWithKey
foldWithKeyM = foldr
@@ -55,98 +80,154 @@ instance TrieKey Int IntMap where
unionM = unionWithKey
isectM = intersectionWithKey
diffM = differenceWithKey
- extractMinM _ = First . minViewWithKey
- extractMaxM _ = Last . maxViewWithKey
- alterMinM = updateMinWithKey
- alterMaxM = updateMaxWithKey
+ extractM s f = extract s f
+-- extractMinM s f = First . minViewWithKey s f
+-- extractMaxM s f = Last . maxViewWithKey s f
+-- alterMinM = updateMinWithKey
+-- alterMaxM = updateMaxWithKey
isSubmapM = isSubmapOfBy
-natFromInt :: Int -> Nat
-natFromInt = fromIntegral
-
-intFromNat :: Nat -> Int
-intFromNat = fromIntegral
+{-instance TrieKey Int32 IntMap where
+ emptyM = IMap Nil Nil
+ nullM (IMap mN mP) = nullM mN && nullM mP
+ sizeM s (IMap mN mP) = sizeM s mN + sizeM s mP
+ lookupM k (IMap mN mP)
+ | k < 0 = lookupM (fromIntegral (-k)) mN
+ | otherwise = lookupM (fromIntegral k) mP
+ lookupIxM s k (IMap mN mP)
+ | k < 0 = do (i, v) <- lookupIx' 0 s (fromIntegral (-k)) mN
+ return (sizeM s mN - 1 - i, v)
+ | otherwise = do (i, v) <- lookupIxM s (fromIntegral k) mP
+ return (i + sizeM s mN, v)
+ assocAtM s i (IMap mN mP)
+ | i < sN, (i', k, a) <- assocAt' s i mN
+ = (i', - fromIntegral k, a)
+ | (i', k, a) <-assocAtM s (i - sN) mP
+ = (i' + sN, fromIntegral k, a)
+ where sN = sizeM s mN
+ updateAtM s f i (IMap mN mP)
+ | i < sN = updateAtM s (\ i' k -> f i' (- fromIntegral k)) (sN - 1 - i) mN `IMap` mP
+ | otherwise = mN `IMap` updateAtM s (\ i' k -> f (i' + sN) (fromIntegral k)) (i - sN) mP
+ where sN = sizeM s mN
+ alterM s f k (IMap mN mP)
+ | k < 0 = alterM s f (fromIntegral (- k)) mN `IMap` mP
+ | otherwise = mN `IMap` alterM s f (fromIntegral k) mP
+ traverseWithKeyM s f (IMap mN mP) =
+ IMap <$> traverseWithKeyM s (\ k -> f (- fromIntegral k)) mN <*>
+ traverseWithKeyM s (f . fromIntegral) mP
+ foldWithKeyM f (IMap mN mP) =
+ foldlWithKeyM (\ k -> flip (f (- fromIntegral k))) mN . foldWithKeyM (f . fromIntegral) mP
+ foldlWithKeyM f (IMap mN mP) =
+ foldlWithKeyM (f . fromIntegral) mP . foldWithKeyM (\ k -> flip (f (- fromIntegral k))) mN
+ mapEitherM s1 s2 f (IMap mN mP) = (IMap mNL mPL, IMap mNR mPR)
+ where (mNL, mNR) = mapEitherM s1 s2 (\ k -> f (- fromIntegral k)) mN
+ (mPL, mPR) = mapEitherM s1 s2 (f . fromIntegral) mP
+ splitLookupM s f k (IMap mN mP)
+ | k < 0, (mNL, ans, mNR) <- splitLookupM s ((\ (l, x, r) -> (r, x, l)) . f) (fromIntegral (-k)) mN
+ = (IMap mNR emptyM, ans, IMap mNL mP)
+ | (mPL, ans, mPR) <- splitLookupM s f (fromIntegral k) mP
+ = (IMap mN mPL, ans, IMap emptyM mPR)-}
+
+natFromInt :: Word32 -> Nat
+natFromInt = id
+
+intFromNat :: Nat -> Word32
+intFromNat = id
shiftRL :: Nat -> Key -> Nat
-#if __GLASGOW_HASKELL__
+-- #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
+-- shiftRL (W# x) (I# i)
+-- = W# (shiftRL# x i)
+-- #else
+shiftRL x i = shiftR x (fromIntegral i)
+-- #endif
-size :: IntMap a ix -> Int
+size :: WordMap a -> Int
size Nil = 0
size (Tip s _ _) = s
size (Bin s _ _ _ _) = s
-null :: IntMap a ix -> Bool
+null :: WordMap a -> 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 :: Nat -> WordMap a -> Maybe (a)
+lookup k (Bin _ _ m l r) = lookup k (if zeroN k m then l else r)
lookup k (Tip _ kx x)
- | k == natFromInt kx = Just x
+ | k == kx = Just x
lookup _ _ = Nothing
-lookupIx :: Nat -> IntMap a ix -> Maybe (Int, a ix)
+{-
+lookupIx :: Nat -> WordMap a -> Maybe (Int, a)
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
+ Nil -> Nothing-}
+
+-- assocAt :: Int -> WordMap a -> Maybe (Int, Key, a)
+-- 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 :: Sized a -> Int -> Int -> WordMap a -> IndexPos Key a
+assocAt s !i0 !i (Bin _ _ _ l r)
+ | i < sl, (lb, x, ub) <- assocAt s i0 i l
+ = (lb, x, ub <|> fst <$> First (minViewWithKey s (\ k a -> (Asc (i0 + size l) k a, Just a)) r))
+ | (lb, x, ub) <- assocAt s (i0 + sl) (i - sl) r
+ = (fst <$> Last (maxViewWithKey s (\ k a -> (Asc (i0 + size l - s a) k a, Just a)) l) <|> lb, x, ub)
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
+assocAt _ i0 _ (Tip _ k x) = (mzero, return (Asc i0 k x), mzero)
+assocAt _ _ _ _ = (mzero, mzero, mzero)
+
+-- updateAt :: Sized a -> (Int -> Key -> a -> Maybe (a)) -> Int -> WordMap a -> WordMap a
+-- 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 -> Round -> Int -> (Int -> Key -> a -> Maybe (a)) -> Int -> WordMap a -> WordMap a
+updateAt s True !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
+ if i < sl then bin p m (updateAt s True i0 f i l) r
+ else bin p m l (updateAt s True (i0 + sl) f (i - sl) r)
+ Tip _ kx x -> singletonMaybe s kx (f i0 kx x)
+ _ -> t
+updateAt s False !i0 f !i t = case t of
+ Bin sz p m l r -> let {sl = size l; mI = maxIx l} in
+ if i < mI then bin p m (updateAt s False i0 f i l) r
+ else bin p m l (updateAt s False (i0 + sl) f (i - sl) r)
+ Tip _ kx x -> singletonMaybe s kx (f i0 kx x)
+ _ -> t
+ where maxIx m = maybe (size m) fst (maxViewWithKey s (\ _ a -> (size m - s a, Just a)) m)
+
+lookupIx :: Sized a -> Int -> Nat -> WordMap a -> IndexPos Nat a
+lookupIx s !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
+ | zeroN k m, (lb, x, ub) <- lookupIx s i k l
+ -> (lb, x, ub <|> fst <$> First (minViewWithKey s (\ k a -> (Asc (i + size l) k a, Just a)) r))
+ | (lb, x, ub) <- lookupIx s (i + size l) k r
+ -> (fst <$> Last (maxViewWithKey s (\ k a -> (Asc (i + size l - s a) k a, Just a)) l) <|> lb, x, ub)
Tip _ kx x
- | k == natFromInt kx -> Just (i, x)
- _ -> Nothing
+ | k == kx -> (mzero, return (Asc i kx x), mzero)
+ _ -> (mzero, mzero, mzero)
-singleton :: Sized a -> Key -> a ix -> IntMap a ix
+singleton :: Sized a -> Key -> a -> WordMap a
singleton s k a = Tip (s a) k a
-singletonMaybe :: Sized a -> Key -> Maybe (a ix) -> IntMap a ix
+singletonMaybe :: Sized a -> Key -> Maybe (a) -> WordMap a
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 :: Sized a -> (Maybe (a) -> Maybe (a)) -> Key -> WordMap a -> WordMap a
alter s f k t = case t of
Bin sz p m l r
| nomatch k p m -> join k (singletonMaybe s k (f Nothing)) p t
@@ -159,48 +240,48 @@ alter s f k t = case t of
| 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 :: Applicative f => Sized b -> (Key -> a -> f (b)) -> WordMap a -> f (WordMap b)
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 -> b -> b) -> WordMap a -> 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
+foldr :: (Key -> a -> b -> b) -> WordMap a -> b -> b
+foldr f t
= case t of
- Bin _ _ _ l r -> foldr' f l . foldr' f r
+ 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
+foldl{-, foldl' -}:: (Key -> b -> a -> b) -> WordMap a -> 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
+ Nil -> id-}
+foldl f t
= case t of
- Bin _ _ _ l r -> foldl' f r . foldl' f l
+ 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 :: Sized b -> Sized c -> EitherMap Key (a) (b) (c) ->
+ WordMap a -> (WordMap b, WordMap c)
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
+splitLookup :: Sized a -> SplitMap (a) x -> Key -> WordMap a -> (WordMap a ,Maybe x,WordMap a)
+{-splitLookup s f k t
= case t of
Bin _ _ m l r
| m < 0 -> (if k >= 0 -- handle negative numbers.
@@ -213,8 +294,8 @@ splitLookup s f k 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
+splitLookup' :: Sized a -> SplitMap (a) x -> Key -> WordMap a -> (WordMap a ,Maybe x,WordMap a)-}
+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)
@@ -226,7 +307,7 @@ splitLookup' s f k t
| otherwise -> singletonMaybe s k `sides` f y
Nil -> (Nil,Nothing,Nil)
-union :: Sized a -> IntMap a ix -> IntMap a ix -> IntMap a ix
+union :: Sized a -> WordMap a -> WordMap a -> WordMap a
union s t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
| shorter m1 m2 = union1
| shorter m2 m1 = union2
@@ -245,7 +326,7 @@ union s t (Tip _ k x) = alter s (Just . fromMaybe x) k t -- right bias
union _ Nil t = t
union _ t Nil = t
-unionWithKey :: Sized a -> UnionFunc Key (a ix) -> IntMap a ix -> IntMap a ix -> IntMap a ix
+unionWithKey :: Sized a -> UnionFunc Key (a) -> WordMap a -> WordMap a -> WordMap a
unionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
| shorter m1 m2 = union1
| shorter m2 m1 = union2
@@ -264,7 +345,7 @@ 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 :: Sized c -> IsectFunc Key (a) (b) (c) -> WordMap a -> WordMap b -> WordMap c
intersectionWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
| shorter m1 m2 = intersection1
| shorter m2 m1 = intersection2
@@ -286,7 +367,7 @@ intersectionWithKey s f t1 (Tip _ 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 :: Sized a -> (Key -> a -> b -> Maybe (a)) -> WordMap a -> WordMap b -> WordMap a
differenceWithKey s f t1@(Bin _ p1 m1 l1 r1) t2@(Bin _ p2 m2 l2 r2)
| shorter m1 m2 = difference1
| shorter m2 m1 = difference2
@@ -307,7 +388,7 @@ 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 :: LEq (a) (b) -> LEq (WordMap a) (WordMap b)
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
@@ -317,62 +398,68 @@ isSubmapOfBy _ (Bin _ _ _ _ _) _ = False
isSubmapOfBy (<=) (Tip _ k x) t = maybe False (x <=) (lookup (natFromInt k) t)
isSubmapOfBy _ Nil _ = True
+extract :: Alternative f => Sized a -> (Key -> a -> f (x, Maybe a)) -> WordMap a -> f (x, WordMap a)
+extract s f t = case t of
+ Bin _ p m l r -> second (\ l' -> bin p m l' r) <$> extract s f l
+ <|> second (bin p m l) <$> extract s f r
+ Tip _ k x -> second (singletonMaybe s k) <$> f k x
+ Nil -> empty
-maxViewWithKey, minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)
-maxViewWithKey t
+maxViewWithKey, minViewWithKey :: Sized a -> (Key -> a -> (x, Maybe a)) -> WordMap a -> Maybe (x, WordMap a)
+maxViewWithKey s f 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)
+-- 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 s f r in Just (result, bin p m l t')
+ Tip _ k y -> let (result, x) = f k y in Just (result, singletonMaybe s k x)
Nil -> Nothing
-maxViewUnsigned, minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)
-maxViewUnsigned t
+maxViewUnsigned, minViewUnsigned :: Sized a -> (Key -> a -> (x, Maybe a)) -> WordMap a -> (x, WordMap a)
+maxViewUnsigned s f 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)
+ Bin _ p m l r -> let (result,t') = maxViewUnsigned s f r in (result,bin p m l t')
+ Tip _ k y -> let (result, x) = f k y in (result, singletonMaybe s k x)
Nil -> error "maxViewUnsigned Nil"
--
--- minViewWithKey :: IntMap a ix -> Maybe ((Key, a ix), IntMap a ix)
-minViewWithKey t
+-- minViewWithKey :: WordMap a -> Maybe ((Key, a), WordMap a)
+minViewWithKey s f 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)
+-- 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 s f l in Just (result, bin p m t' r)
+ Tip _ k y -> let (result, x) = f k y in Just (result, singletonMaybe s k x)
Nil -> Nothing
--- minViewUnsigned :: IntMap a ix -> ((Key, a ix), IntMap a ix)
-minViewUnsigned t
+-- minViewUnsigned :: WordMap a -> ((Key, a), WordMap a)
+minViewUnsigned s f 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)
+ Bin _ p m l r -> let (result,t') = minViewUnsigned s f l in (result,bin p m t' r)
+ Tip _ k y -> let (result, x) = f k y in (result, singletonMaybe s k x)
Nil -> error "minViewUnsigned Nil"
-updateMinWithKey :: Sized a -> (Key -> a ix -> Maybe (a ix)) -> IntMap a ix -> IntMap a ix
+updateMinWithKey :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a
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 | 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 :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a
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 :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a
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 | 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 :: Sized a -> (Key -> a -> Maybe (a)) -> WordMap a -> WordMap a
updateMaxWithKeyUnsigned s f t
= case t of
Bin _ p m l r -> let t' = updateMaxWithKeyUnsigned s f r in bin p m l t'
@@ -419,7 +506,7 @@ highestBitMask x0
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 :: Prefix -> WordMap a -> Prefix -> WordMap a -> WordMap a
join p1 t1 p2 t2
| zero p1 m = bin p m t1 t2
| otherwise = bin p m t2 t1
@@ -427,19 +514,19 @@ join p1 t1 p2 t2
m = branchMask p1 p2
p = mask p1 m
-bin :: Prefix -> Mask -> IntMap a ix -> IntMap a ix -> IntMap a ix
+bin :: Prefix -> Mask -> WordMap a -> WordMap a -> WordMap a
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.WordMap
+-- import qualified Data.WordMap as IMap
-- import Data.Traversable
--
--- newtype IntTMap a ix = ITMap (IntMap (a ix))
+-- newtype IntTMap a = ITMap (WordMap (a))
-- type instance TrieMap Int = IntTMap
--- newtype MaybeF a ix = MF {unF :: Maybe (a ix)}
+-- newtype MaybeF a = MF {unF :: Maybe (a)}
--
-- instance TrieKey Int IntTMap where
-- emptyM = ITMap empty
diff --git a/Data/TrieMap/Modifiers.hs b/Data/TrieMap/Modifiers.hs
new file mode 100644
index 0000000..839296b
--- /dev/null
+++ b/Data/TrieMap/Modifiers.hs
@@ -0,0 +1,12 @@
+module Data.TrieMap.Modifiers where
+
+newtype Ordered a = Ord {unOrd :: a} deriving (Eq, Ord)
+newtype Rev k = Rev {getRev :: k} deriving (Eq)
+instance Ord k => Ord (Rev k) where
+ compare (Rev a) (Rev b) = compare b a
+
+instance Functor Ordered where
+ fmap f (Ord a) = Ord (f a)
+
+instance Functor Rev where
+ fmap f (Rev a) = Rev (f a) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec.hs b/Data/TrieMap/MultiRec.hs
index e67bbfc..97896f3 100644
--- a/Data/TrieMap/MultiRec.hs
+++ b/Data/TrieMap/MultiRec.hs
@@ -1,6 +1,7 @@
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.FamMap
import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Base
import Data.TrieMap.MultiRec.Ord \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Base.hs b/Data/TrieMap/MultiRec/Base.hs
new file mode 100644
index 0000000..2953490
--- /dev/null
+++ b/Data/TrieMap/MultiRec/Base.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, ExistentialQuantification, KindSignatures, FlexibleInstances, MultiParamTypeClasses #-}
+
+module Data.TrieMap.MultiRec.Base (module Generics.MultiRec.Base, module Generics.MultiRec.HFix, {-A0(..), X(..), -}Family(..), FamT(..), KeyFam(..), FunctorT (..), breakEither) where
+
+import Data.TrieMap.TrieKey
+
+import Generics.MultiRec
+import Generics.MultiRec.Base
+import Generics.MultiRec.HFix
+
+import Control.Applicative
+
+-- newtype A f (r :: * -> *) ix = A {unA :: f r ix}
+-- newtype A0 (r :: * -> *) ix = A0 {unA0 :: r ix}
+-- newtype R (r1 :: * -> *) (r :: * -> *) ix = Rec {unRec :: r1 (r ix)}
+-- newtype X (r :: * -> *) ix = X {unX :: ix}
+newtype Family (phi :: * -> *) ix = F ix
+
+data KeyFam k = TrieKey k (TrieMap k) => KF
+newtype FamT (phi :: * -> *) f ix = FamT (f ix)
+
+instance TrieKey k (TrieMap k) => El KeyFam k where
+ proof = KF
+
+-- instance HFunctor phi f => HFunctor phi (A f) where
+-- hmapA f pf (A x) = A <$> hmapA f pf x
+
+-- instance HFunctor phi A0 where
+-- hmapA f pf (A0 x) = A0 <$> f pf x
+
+-- instance HEq phi f => HEq phi (A f) where
+-- heq f pf (A x) (A y) = heq f pf x y
+
+-- instance HEq phi A0 where
+-- heq f pf (A0 x) (A0 y) = f pf x y
+
+class FunctorT f where
+ fmapp :: Functor r => (a -> b) -> f r a -> f r b
+
+instance FunctorT (FamT phi) where
+ fmapp f (FamT x) = FamT (fmap f x)
+
+instance Functor (Family phi) where
+ fmap f (F x) = F (f x)
+
+instance Functor f => Functor (FamT phi f) where
+ fmap = fmapp
+
+instance FunctorT (K k) where
+ fmapp = fmap
+
+instance Functor (K k r) where
+ fmap f (K a) = K a
+
+instance FunctorT (I ix) where
+ fmapp = fmap
+
+instance Functor (I ix r) where
+ fmap f (I a) = I a
+
+instance FunctorT U where
+ fmapp f U = U
+
+instance Functor (U r) where
+ fmap f U = U
+
+instance (FunctorT f, FunctorT g) => FunctorT (f :*: g) where
+ fmapp f (x :*: y) = fmapp f x :*: fmapp f y
+
+instance (Functor (f r), Functor (g r)) => Functor ((f :*: g) r) where
+ fmap f (x :*: y) = fmap f x :*: fmap f y
+
+instance (FunctorT f, FunctorT g) => FunctorT (f :+: g) where
+ fmapp f (L l) = L (fmapp f l)
+ fmapp f (R r) = R (fmapp f r)
+
+instance (Functor (f r), Functor (g r)) => Functor ((f :+: g) r) where
+ fmap f (L l) = L (fmap f l)
+ fmap f (R r) = R (fmap f r)
+
+-- instance FunctorT f => FunctorT (A f) where
+-- fmapp f (A x) = A (fmapp f x)
+
+-- instance FunctorT A0 where
+-- fmapp f (A0 x) = A0 (fmap f x)
+
+-- instance (FunctorT f, Functor r) => Functor (A f r) where
+-- fmap = fmapp
+
+-- instance Functor r => Functor (A0 r) where
+-- fmap = fmapp
+
+-- instance FunctorT X where
+-- fmapp = fmap
+
+-- instance Functor (X r) where
+-- fmap f (X x) = X (f x)
+
+instance FunctorT f => Functor (HFix f) where
+ fmap f (HIn x) = HIn (fmapp f x)
+
+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) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Class.hs b/Data/TrieMap/MultiRec/Class.hs
index b51cf01..9638841 100644
--- a/Data/TrieMap/MultiRec/Class.hs
+++ b/Data/TrieMap/MultiRec/Class.hs
@@ -12,111 +12,124 @@ import Control.Applicative
import Data.Monoid
import Generics.MultiRec.Eq
-type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> (* -> *) -> * -> *
-type family HTrieMap (phi :: * -> *) (r :: * -> *) :: (* -> *) -> * -> *
+type family HTrieMapT (phi :: * -> *) (f :: (* -> *) -> * -> *) :: (* -> *) -> * -> * -> *
+type family HTrieMap (phi :: * -> *) (r :: * -> *) :: * -> * -> *
class HOrd phi f => HTrieKeyT (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
+ emptyT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a
+ nullT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> m r ix a -> Bool
+ sizeT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> m r ix a -> Int
+ lookupT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> f r ix -> m r ix a -> Maybe a
+ lookupIxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> f r ix -> m r ix a -> IndexPos (f r ix) a
+ assocAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a -> Int -> m r ix a -> IndexPos (f r ix) a
+-- updateAtT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+-- phi ix -> HSized phi a -> Round -> (Int -> f r ix -> a -> Maybe a) -> Int -> m r ix a -> m r ix a
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
+ phi ix -> HSized phi a -> (Maybe a -> Maybe a) -> f r ix ->
+ m r ix a -> m r ix a
{-# 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) #-}
+ phi ix -> HSized phi b -> (f r ix -> ix a -> Id b) -> m r ix a -> Id (m r ix b) #-}
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)
+ phi ix -> HSized phi b -> (f r ix -> a -> t b) -> m r ix a -> t (m r ix b)
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
+ phi ix -> (f r ix -> a -> b -> b) -> m r ix a -> 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
+ phi ix -> (f r ix -> b -> a -> b) -> m r ix a -> 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)
+ HSized phi b -> HSized phi c -> EitherMap (f r ix) a b c -> m r ix a -> (m r ix b, m r ix c)
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)
+ phi ix -> HSized phi a -> SplitMap a x -> f r ix ->
+ m r ix a -> (m r ix a, Maybe x, m r ix a)
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
+ phi ix -> HSized phi a -> UnionFunc (f r ix) a ->
+ m r ix a -> m r ix a -> m r ix a
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
+ phi ix -> HSized phi c -> IsectFunc (f r ix) a b c -> m r ix a -> m r ix b -> m r ix c
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
+ phi ix -> HSized phi a -> DiffFunc (f r ix) a b -> m r ix a -> m r ix b -> m r ix a
+ extractT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r), Alternative t) =>
+ phi ix -> HSized phi a -> ExtractFunc t (m r ix a) (f r ix) a x
+-- extractMinT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+-- phi ix -> HSized phi a -> ExtractFunc (f r ix) First a (m r ix a) x
+-- extractMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+-- phi ix -> HSized phi a -> ExtractFunc (f r ix) Last a (m r ix a) x
+-- alterMinT:: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+-- phi ix -> HSized phi a -> (f r ix -> a -> Maybe a) -> m r ix a -> First (m r ix a)
+-- alterMaxT :: (m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r)) =>
+-- phi ix -> HSized phi a -> (f r ix -> a -> Maybe a) -> m r ix a -> Last (m r ix a)
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)
+ phi ix -> LEq a b -> LEq (m r ix a) (m r ix b)
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
+ phi ix -> HSized phi a -> (f r ix -> a -> a -> a ) -> [(f r ix, a )] -> m r ix a
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
+ phi ix -> HSized phi a -> [(f r ix, a )] -> m r ix a
+ sizeT pf s m = foldWithKeyT pf (\ _ x n -> s 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 | 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) #-}
+ emptyH :: m ~ HTrieMap phi r => phi ix -> m ix a
+ nullH :: m ~ HTrieMap phi r => phi ix -> m ix a -> Bool
+ sizeH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> m ix a -> Int
+ lookupH :: m ~ HTrieMap phi r => phi ix -> r ix -> m ix a -> Maybe a
+ alterH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (Maybe a -> Maybe a) -> r ix -> m ix a -> m ix a
+ lookupIxH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> r ix -> m ix a -> IndexPos (r ix) a
+ assocAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Int -> m ix a -> IndexPos (r ix) a
+-- updateAtH :: m ~ HTrieMap phi r => phi ix -> HSized phi a -> Round -> (Int -> r ix -> a -> Maybe a) -> Int -> m ix a -> m ix a
+ {-# SPECIALIZE traverseWithKeyH :: phi ix -> (r ix -> ix a -> Id b) ->
+ m ix a -> Id (m ix b) #-}
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
+ phi ix -> HSized phi b -> (r ix -> a -> f b) -> m ix a -> f (m ix b)
+ foldWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> a -> b -> b) -> m ix a -> b -> b
+ foldlWithKeyH :: m ~ HTrieMap phi r => phi ix -> (r ix -> b -> a -> b) -> m ix a -> 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
+ EitherMap (r ix) a b c -> m ix a -> (m ix b, m ix c)
+ splitLookupH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> SplitMap a x -> r ix -> m ix a ->
+ (m ix a, Maybe x, m ix a)
+ unionH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> UnionFunc (r ix) a -> m ix a -> m ix a
+ -> m ix a
+ isectH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi c -> IsectFunc (r ix) a b c ->
+ m ix a -> m ix b -> m ix c
+ diffH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> DiffFunc (r ix) a b ->
+ m ix a -> m ix b -> m ix a
+ extractH :: (m ~ HTrieMap phi r, Alternative t) =>
+ phi ix -> HSized phi a -> ExtractFunc t (m ix a) (r ix) a x
+-- extractMinH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) First a (m ix a) x
+-- extractMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> ExtractFunc (r ix) Last a (m ix a) x
+-- alterMinH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a -> Maybe a) ->
+-- m ix a -> First (m ix a)
+-- alterMaxH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a -> Maybe a) ->
+-- m ix a -> Last (m ix a)
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
+ phi ix -> LEq a b -> LEq (m ix a) (m ix b)
+ fromListH, fromAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> (r ix -> a -> a -> a) ->
+ [(r ix, a)] -> m ix a
+ fromDistAscListH :: (m ~ HTrieMap phi r) => phi ix -> HSized phi a -> [(r ix, a)] -> m ix a
+ sizeH pf s m = foldWithKeyH pf (\ _ x n -> s 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
+ phi ix -> HSized phi b -> (f r ix -> a -> b ) -> HTrieMapT phi f r ix a -> HTrieMapT phi f r ix b
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
+ phi ix -> HSized phi b -> (r ix -> a -> b) -> HTrieMap phi r ix a -> HTrieMap phi r ix b
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)
+ phi ix -> m r ix a -> Maybe (m r ix a)
guardNullT pf m
| nullT pf m = Nothing
- | otherwise = Just m \ No newline at end of file
+ | otherwise = Just m
+
+-- alterMaxT, alterMinT :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r)) =>
+-- phi ix -> HSized phi a -> (f r ix -> a -> Maybe a) -> m r ix a -> m r ix a
+-- alterMaxT pf s f m = maybe m snd $ getLast (extractMaxT pf s (\ k a -> ((), f k a)) m)
+-- alterMinT pf s f m = maybe m snd $ getFirst (extractMinT pf s (\ k a -> ((), f k a)) m)
+
+aboutT :: (m ~ HTrieMapT phi f, HTrieKeyT phi f m, HTrieKey phi r (HTrieMap phi r), Alternative t) =>
+ phi ix -> (f r ix -> a -> t z) -> m r ix a -> t z
+aboutT pf f m = fst <$> extractT pf (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) m \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/ConstMap.hs b/Data/TrieMap/MultiRec/ConstMap.hs
index 3671ec2..7f780ed 100644
--- a/Data/TrieMap/MultiRec/ConstMap.hs
+++ b/Data/TrieMap/MultiRec/ConstMap.hs
@@ -1,12 +1,14 @@
-{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
-module Data.TrieMap.MultiRec.ConstMap where
+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 Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.TH
import Control.Applicative
import Control.Arrow
@@ -16,10 +18,18 @@ import Data.Maybe
import Data.Foldable
import Generics.MultiRec
-newtype KMap (phi :: * -> *) m (r :: * -> *) (a :: * -> *) ix = KMap (m a ix)
+newtype KMap (phi :: * -> *) m (r :: * -> *) ix a = KMap (m a)
type instance HTrieMapT phi (K k) = KMap phi (TrieMap k)
type instance HTrieMap phi (K k r) = HTrieMapT phi (K k) r
+-- type instance RepT (KMap phi m r ix) = RepT m
+-- type instance Rep (KMap phi m r ix a) = RepT m (Rep a)
+--
+-- -- $(genRepT [d|
+-- instance ReprT m => ReprT (KMap phi m r ix) where
+-- toRepT (KMap m) = toRepT m
+-- fromRepT = KMap . fromRepT |])
+
instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where
emptyT = emptyH
nullT = nullH
@@ -27,7 +37,7 @@ instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where
lookupT = lookupH
lookupIxT = lookupIxH
assocAtT = assocAtH
- updateAtT = updateAtH
+-- updateAtT = updateAtH
alterT = alterH
traverseWithKeyT = traverseWithKeyH
foldWithKeyT = foldWithKeyH
@@ -37,10 +47,11 @@ instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where
unionT = unionH
isectT = isectH
diffT = diffH
- extractMinT = extractMinH
- extractMaxT = extractMaxH
- alterMinT = alterMinH
- alterMaxT = alterMaxH
+ extractT = extractH
+-- extractMinT = extractMinH
+-- extractMaxT = extractMaxH
+-- alterMinT = alterMinH
+-- alterMaxT = alterMaxH
isSubmapT = isSubmapH
fromListT = fromListH
fromAscListT = fromAscListH
@@ -49,12 +60,11 @@ instance TrieKey k m => HTrieKeyT phi (K k) (KMap phi m) where
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
+ 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)
+ lookupIxH _ s (K k) (KMap m) = onKey K (lookupIxM s k m)
+ assocAtH _ s i (KMap m) = onKey K (assocAtM s i m)
+-- updateAtH _ s r f i (KMap m) = KMap (updateAtM s r (\ 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
@@ -64,14 +74,11 @@ instance TrieKey k m => HTrieKey phi (K k r) (KMap phi m r) where
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)
+ extractH pf s f (KMap m) = second KMap <$> extractM s (f . K) m
+-- extractMinH pf s f (KMap m) = second KMap <$> extractMinM (s) (f . K) m
+-- extractMaxH pf s f (KMap m) = second KMap <$> extractMaxM s (f . K) 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])
diff --git a/Data/TrieMap/MultiRec/Eq.hs b/Data/TrieMap/MultiRec/Eq.hs
index bde9463..b3a0838 100644
--- a/Data/TrieMap/MultiRec/Eq.hs
+++ b/Data/TrieMap/MultiRec/Eq.hs
@@ -2,7 +2,8 @@
module Data.TrieMap.MultiRec.Eq where
-import Generics.MultiRec
+import Data.TrieMap.MultiRec.Base
+import Generics.MultiRec.HFix
import Generics.MultiRec.Eq
class HEq0 phi r where
@@ -13,6 +14,12 @@ heqT = heq heqH
instance Eq k => HEq0 phi (K k r) where
heqH _ (K x) (K y) = x == y
+{-
+instance HEq0 phi r => HEq0 phi (A0 r) where
+ heqH pf (A0 x) (A0 y) = heqH pf x y-}
+
+-- instance (HEq phi f, HEq0 phi r) => HEq0 phi (A f r) where
+-- heqH pf (A x) (A y) = heqT pf 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
diff --git a/Data/TrieMap/MultiRec/FamMap.hs b/Data/TrieMap/MultiRec/FamMap.hs
index 3628057..85b61c2 100644
--- a/Data/TrieMap/MultiRec/FamMap.hs
+++ b/Data/TrieMap/MultiRec/FamMap.hs
@@ -1,14 +1,16 @@
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, Rank2Types, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE PatternGuards, TypeFamilies, MultiParamTypeClasses, Rank2Types, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
-module Data.TrieMap.MultiRec.FamMap where
+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.MultiRec.Base
import Data.TrieMap.Sized
import Data.TrieMap.Applicative
import Data.TrieMap.TrieKey
+import qualified Data.TrieMap.Regular.Class as Reg
import Control.Applicative
import Control.Arrow
@@ -20,8 +22,7 @@ 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)
+newtype FamMap (phi :: * -> *) m ix a = FamMap (m (Family phi) ix a)
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
@@ -36,6 +37,21 @@ instance (El phi ix, Fam phi, HEq phi (PF phi), HFunctor phi (PF phi)) => Eq (Fa
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
+instance HEq0 phi r => HEq0 phi (FamT phi r) where
+ heqH pf (FamT x) (FamT y) = heqH pf x y
+
+instance HOrd0 phi r => HOrd0 phi (FamT phi r) where
+ compareH0 pf (FamT x) (FamT y) = compareH0 pf x y
+
+instance (El phi ix, HEq0 phi r) => Eq (FamT phi r ix) where
+ x == y = heqH (prove' x) x y
+
+instance (El phi ix, HOrd0 phi r) => Ord (FamT phi r ix) where
+ x `compare` y = compareH0 (prove' x) x y
+
+prove' :: El phi ix => FamT phi r ix -> phi ix
+prove' _ = proof
+
prove :: El phi ix => Family phi ix -> phi ix
prove _ = proof
@@ -51,12 +67,11 @@ 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
+ sizeH pf s (FamMap m) = sizeT pf 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)
+ lookupIxH pf s (F k) (FamMap m) = onKey (F . to' pf) (lookupIxT pf s (from' pf k) m)
+ assocAtH pf s i (FamMap m) = onKey (F . to' pf) (assocAtT pf s i m)
+-- updateAtH pf s r f i (FamMap m) = FamMap (updateAtT pf s r (\ 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
@@ -67,59 +82,75 @@ instance (Fam phi, HFunctor phi (PF phi), HTrieKeyT phi (PF phi) m) => HTrieKey
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)
+ extractH pf s f (FamMap m) = second FamMap <$> extractT pf s (f . F . to' pf) m
+-- extractMinH pf s f (FamMap m) = second FamMap <$> extractMinT pf s (f . F . to' pf) m
+-- extractMaxH pf s f (FamMap m) = second FamMap <$> extractMaxT pf s (f . F . to' pf) 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)
+newtype FMap (phi :: * -> *) m ix a = FMap (m ix a)
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
+ sizeM s (FMap m) = sizeH proof s m
+ lookupM k (FMap m) = lookupH proof k m
+ lookupIxM s k (FMap m) = lookupIxH proof s k m
+ assocAtM s i (FMap m) = assocAtH proof s i m
+-- updateAtM s r f i (FMap m) = FMap (updateAtH proof s r f i m)
+ alterM s f k (FMap m) = FMap (alterH proof s f k m)
+ traverseWithKeyM s f (FMap m) = FMap <$> traverseWithKeyH proof s f m
+ foldWithKeyM f (FMap m) = foldWithKeyH proof f m
+ foldlWithKeyM f (FMap m) = foldlWithKeyH proof f 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
+ (FMap *** FMap) (mapEitherH proof s1 s2 f m)
+ splitLookupM s f k (FMap m) = FMap `sides` splitLookupH proof s (f) k m
+ unionM s f (FMap m1) (FMap m2) = FMap (unionH proof s f m1 m2)
+ isectM s f (FMap m1) (FMap m2) = FMap (isectH proof s f m1 m2)
+ diffM s f (FMap m1) (FMap m2) = FMap (diffH proof s f m1 m2)
+ extractM s f (FMap m) = second FMap <$> extractH proof s f m
+-- extractMinM s f (FMap m) = second FMap <$> extractMinH proof s f m
+-- extractMaxM s f (FMap m) = second FMap <$> extractMaxH proof s f m
+-- alterMinM s f (FMap m) = FMap (alterMinH proof s f m)
+-- alterMaxM s f (FMap m) = FMap (alterMaxH proof s f m)
+ isSubmapM (<=) (FMap m1) (FMap m2) = isSubmapH proof (<=) m1 m2
+ fromListM s f xs = FMap (fromListH proof s f xs)
+ fromAscListM s f xs = FMap (fromAscListH proof s f xs)
+ fromDistAscListM s xs = FMap (fromDistAscListH proof s xs)
+
+newtype FTMap (phi :: * -> *) (r :: * -> *) ix a = FTMap (HTrieMap phi r ix a)
+type instance TrieMap (FamT phi r ix) = FTMap phi r ix
+
+-- instance (HTrieKey KeyFam r (HTrieMap KeyFam r)) => Reg.TrieKeyT (FamT KeyFam r) (FTMap KeyFam r) where
+-- emptyT = FTMap (emptyH KF)
+
+instance (El phi ix, HTrieKey phi r (HTrieMap phi r)) => TrieKey (FamT phi r ix) (FTMap phi r ix) where
+ emptyM = FTMap (emptyH proof)
+ nullM (FTMap m) = nullH proof m
+ sizeM s (FTMap m) = sizeH proof s m
+ lookupM (FamT k) (FTMap m) = lookupH proof k m
+ lookupIxM s (FamT k) (FTMap m) = onKey FamT (lookupIxH proof s k m)
+ assocAtM s i (FTMap m) = onKey FamT (assocAtH proof s i m)
+-- updateAtM s r f i (FTMap m) = FTMap (updateAtH proof s r (\ i' -> f i' . FamT) i m)
+ alterM s f (FamT k) (FTMap m) = FTMap (alterH proof s f k m)
+ foldWithKeyM f (FTMap m) = foldWithKeyH proof (f . FamT) m
+ foldlWithKeyM f (FTMap m) = foldlWithKeyH proof (f . FamT) m
+ traverseWithKeyM s f (FTMap m) = FTMap <$> traverseWithKeyH proof s (f . FamT) m
+ mapEitherM s1 s2 f (FTMap m) = (FTMap *** FTMap) (mapEitherH proof s1 s2 (f . FamT) m)
+ splitLookupM s f (FamT k) (FTMap m) = FTMap `sides` splitLookupH proof s f k m
+ unionM s f (FTMap m1) (FTMap m2) = FTMap (unionH proof s (f . FamT) m1 m2)
+ isectM s f (FTMap m1) (FTMap m2) = FTMap (isectH proof s (f . FamT) m1 m2)
+ diffM s f (FTMap m1) (FTMap m2) = FTMap (diffH proof s (f . FamT) m1 m2)
+ isSubmapM (<=) (FTMap m1) (FTMap m2) = isSubmapH proof (<=) m1 m2
+ extractM s f (FTMap m) = second FTMap <$> extractH proof s (f . FamT) m
+-- extractMinM s f (FTMap m){--} = second FTMap <$> extractMinH proof s (f . FamT) m
+-- extractMaxM s f (FTMap m) = second FTMap <$> extractMaxH proof s (f . FamT) m
+-- alterMinM s f (FTMap m) = FTMap (alterMinH proof s (f . FamT) m)
+-- alterMaxM s f (FTMap m) = FTMap (alterMaxH proof s (f . FamT) m) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/FixMap.hs b/Data/TrieMap/MultiRec/FixMap.hs
new file mode 100644
index 0000000..a4964d0
--- /dev/null
+++ b/Data/TrieMap/MultiRec/FixMap.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE PatternGuards, FlexibleContexts, FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-}
+
+module Data.TrieMap.MultiRec.FixMap () where
+
+import Data.TrieMap.MultiRec.Base
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.TrieKey
+
+import Control.Applicative
+import Control.Arrow
+
+newtype HFixMap (phi :: * -> *) (f :: (* -> *) -> * -> *) a ix = HFixMap (HTrieMapT phi f (HFix f) a ix)
+type instance HTrieMap phi (HFix f) = HFixMap phi f
+
+instance HTrieKeyT phi f (HTrieMapT phi f) => HTrieKey phi (HFix f) (HFixMap phi f) where
+ emptyH = HFixMap . emptyT
+ nullH pf (HFixMap m) = nullT pf m
+ sizeH pf s (HFixMap m) = sizeT pf s m
+ lookupH pf (HIn k) (HFixMap m) = lookupT pf k m
+ lookupIxH pf s (HIn k) (HFixMap m) = onKey HIn (lookupIxT pf s k m)
+ assocAtH pf s i (HFixMap m) = onKey HIn (assocAtT pf s i m)
+-- updateAtH pf s r f i (HFixMap m) = HFixMap (updateAtT pf s r (\ i' -> f i' . HIn) i m)
+ alterH pf s f (HIn k) (HFixMap m) = HFixMap (alterT pf s f k m)
+ traverseWithKeyH pf s f (HFixMap m) = HFixMap <$> traverseWithKeyT pf s (f . HIn) m
+ foldWithKeyH pf f (HFixMap m) = foldWithKeyT pf (f . HIn) m
+ foldlWithKeyH pf f (HFixMap m) = foldlWithKeyT pf (f . HIn) m
+ unionH pf s f (HFixMap m1) (HFixMap m2) = HFixMap (unionT pf s (f . HIn) m1 m2)
+ isectH pf s f (HFixMap m1) (HFixMap m2) = HFixMap (isectT pf s (f . HIn) m1 m2)
+ diffH pf s f (HFixMap m1) (HFixMap m2) = HFixMap (diffT pf s (f . HIn) m1 m2)
+ isSubmapH pf (<=) (HFixMap m1) (HFixMap m2) = isSubmapT pf (<=) m1 m2
+ mapEitherH pf s1 s2 f (HFixMap m) = (HFixMap *** HFixMap) (mapEitherT pf s1 s2 (f . HIn) m)
+ splitLookupH pf s f (HIn k) (HFixMap m) = HFixMap `sides` splitLookupT pf s f k m
+ extractH pf s f (HFixMap m) = second HFixMap <$> extractT pf s (f . HIn) m
+-- extractMinH pf s f (HFixMap m) = second HFixMap <$> extractMinT pf s (f . HIn) m
+-- extractMaxH pf s f (HFixMap m) = second HFixMap <$> extractMaxT pf s (f . HIn) m
+-- alterMinH pf s f (HFixMap m) = HFixMap <$> alterMinT pf s (f . HIn) m
+-- alterMaxH pf s f (HFixMap m) = HFixMap <$> alterMaxT pf s (f . HIn) m \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/IMap.hs b/Data/TrieMap/MultiRec/IMap.hs
index b8de76c..c35913e 100644
--- a/Data/TrieMap/MultiRec/IMap.hs
+++ b/Data/TrieMap/MultiRec/IMap.hs
@@ -1,9 +1,12 @@
-{-# LANGUAGE Rank2Types, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, Rank2Types, TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses #-}
-module Data.TrieMap.MultiRec.IMap where
+module Data.TrieMap.MultiRec.IMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.MultiRec.TH
+-- import Data.TrieMap.Rep.TH
+-- import Data.TrieMap.Rep
import Data.TrieMap.TrieKey
import Control.Applicative
@@ -11,76 +14,43 @@ import Control.Arrow
import Generics.MultiRec
-newtype IMap phi xi r a ix = IMap (HTrieMap phi r (I ix a) xi)
+newtype IMap phi xi r ix a = IMap (HTrieMap phi r xi a)
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
+-- type instance RepT (IMap phi xi r ix) = RepT (HTrieMap phi r xi)
+-- type instance Rep (IMap phi xi r ix a) = RepT (IMap phi xi r ix) (Rep a)
+--
+-- -- $(genRepT [d|
+-- instance ReprT (HTrieMap phi r xi) => ReprT (IMap phi xi r ix) where
+-- toRepT (IMap m) = toRepT m
+-- fromRepT = IMap . fromRepT |] )
-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
+$(inferH [d|
+ 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
+ sizeT _ s (IMap m) = sizeH proof s m
+ lookupT _ (I k) (IMap m) = lookupH proof k m
+ lookupIxT _ s (I k) (IMap m) = onKey I (lookupIxH proof s k m)
+ assocAtT _ s i (IMap m) = onKey I (assocAtH proof s i m)
+-- updateAtT _ s r f i (IMap m) = IMap (updateAtH proof s r (\ i' -> f i' . I) i m)
+ alterT _ s f (I k) (IMap m) = IMap (alterH proof s f k m)
+ traverseWithKeyT _ s f (IMap m) = IMap <$> traverseWithKeyH proof s (f . I) m
+ foldWithKeyT _ f (IMap m) = foldWithKeyH proof (f . I) m
+ foldlWithKeyT _ f (IMap m) = foldlWithKeyH proof (f . I) m
+ mapEitherT _ s1 s2 f (IMap m) = (IMap *** IMap) (mapEitherH proof s1 s2 (f . I) m)
+ splitLookupT pf s f (I k) (IMap m) = IMap `sides` splitLookupH proof s (f) k m
+ unionT pf s f (IMap m1) (IMap m2) = IMap (unionH proof s (f . I) m1 m2)
+ isectT pf s f (IMap m1) (IMap m2) = IMap (isectH proof s (f . I) m1 m2)
+ diffT pf s f (IMap m1) (IMap m2) = IMap (diffH proof s (f . I) m1 m2)
+ extractT pf s f (IMap m) = second IMap <$> extractH proof s (f . I) m
+-- extractMinT pf s f (IMap m) = second IMap <$> extractMinH proof s (f . I) m
+-- extractMaxT pf s f (IMap m) = second IMap <$> extractMaxH proof s (f . I) m
+-- alterMinT pf s f (IMap m) = IMap <$> alterMinH proof s (f . I) m
+-- alterMaxT pf s f (IMap m) = IMap <$> alterMaxH proof s (f . I) m
+ isSubmapT pf (<=) (IMap m1) (IMap m2) = isSubmapH proof (<=) m1 m2
+ fromListT _ s f xs = IMap (fromListH proof s (f . I) [(k, a) | (I k, a) <- xs])
+ fromAscListT _ s f xs = IMap (fromAscListH proof s (f . I) [(k, a) | (I k, a) <- xs])
+ fromDistAscListT _ s xs = IMap (fromDistAscListH proof s [(k, a) | (I k, a) <- xs]) |]) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Instances.hs b/Data/TrieMap/MultiRec/Instances.hs
index 91f46c6..3330dfb 100644
--- a/Data/TrieMap/MultiRec/Instances.hs
+++ b/Data/TrieMap/MultiRec/Instances.hs
@@ -6,4 +6,7 @@ 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
+import Data.TrieMap.MultiRec.FamMap
+-- import Data.TrieMap.MultiRec.AppMap
+-- import Data.TrieMap.MultiRec.XMap
+import Data.TrieMap.MultiRec.FixMap \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Ord.hs b/Data/TrieMap/MultiRec/Ord.hs
index bf18ff8..25bb6e8 100644
--- a/Data/TrieMap/MultiRec/Ord.hs
+++ b/Data/TrieMap/MultiRec/Ord.hs
@@ -3,7 +3,7 @@
module Data.TrieMap.MultiRec.Ord where
import Data.TrieMap.MultiRec.Eq
-
+import Data.TrieMap.MultiRec.Base
import Generics.MultiRec
import Data.Monoid
@@ -19,6 +19,15 @@ hcompare = compareH compareH0
class HEq0 phi r => HOrd0 phi r where
compareH0 :: phi ix -> Comparator (r ix)
+-- instance HOrd0 phi r => HOrd0 phi (A0 r) where
+-- compareH0 pf (A0 a) (A0 b) = compareH0 pf a b
+
+-- instance (HOrd phi f, HOrd0 phi r) => HOrd0 phi (A f r) where
+-- compareH0 pf (A a) (A b) = hcompare pf a b
+
+-- instance HOrd phi A0 where
+-- compareH cmp pf (A0 a) (A0 b) = cmp pf a b
+
instance Ord k => HOrd phi (K k) where
compareH _ = compareH0
diff --git a/Data/TrieMap/MultiRec/ProdMap.hs b/Data/TrieMap/MultiRec/ProdMap.hs
index b416db4..6c97a23 100644
--- a/Data/TrieMap/MultiRec/ProdMap.hs
+++ b/Data/TrieMap/MultiRec/ProdMap.hs
@@ -1,126 +1,138 @@
-{-# LANGUAGE TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards, TemplateHaskell, TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}
-module Data.TrieMap.MultiRec.ProdMap where
+module Data.TrieMap.MultiRec.ProdMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Ord
import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.MultiRec.TH
+import Data.TrieMap.Regular.Base (O(..))
import Data.TrieMap.Applicative
import Data.TrieMap.TrieKey
+-- import Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.TH
import Control.Applicative
import Control.Arrow
import Data.Maybe
+import Data.Monoid
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)
+newtype ProdMap (phi :: * -> *) f g (r :: * -> *) ix a = PMap (HTrieMapT phi f r ix (HTrieMapT phi g r ix a))
+type instance HTrieMapT phi (f :*: g) = ProdMap phi f g--(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
+-- type instance RepT (ProdMap phi f g r ix) = RepT (HTrieMapT phi f r ix) `O` RepT (HTrieMapT phi g r ix)
+-- type instance Rep (ProdMap phi f g r ix a) = RepT (ProdMap phi f g r ix) (Rep a)
-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])
+-- -- $(genRepT [d|
+-- instance (ReprT (HTrieMapT phi f r ix), ReprT (HTrieMapT phi g r ix)) =>
+-- ReprT (ProdMap phi f g r ix) where
+-- toRepT (PMap m) = O (fmap toRepT (toRepT m))
+-- fromRepT (O m) = PMap (fromRepT (fmap fromRepT m)) |] )
-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)]
+maxIx :: (HTrieKeyT phi f (HTrieMapT phi f), HTrieKey phi r (HTrieMap phi r)) => phi ix -> HSized phi a ->
+ HTrieMapT phi f r ix a -> Int
+maxIx pf s m = fromMaybe (sizeT pf s m) (getFirst (aboutT pf (\ _ a -> return (sizeT pf s m - s a)) m))
-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
+$(inferH [d|
+ instance (HTrieKeyT phi f (HTrieMapT phi f), HTrieKeyT phi g (HTrieMapT phi g)) =>
+ HTrieKeyT phi (f :*: g) (ProdMap phi f g) where
+ emptyT = PMap . emptyT
+ nullT pf (PMap m) = nullT pf m
+ sizeT pf s (PMap m) = sizeT pf (sizeT pf s) m
+ lookupT pf (a :*: b) (PMap m) = lookupT pf a m >>= lookupT pf b
+ lookupIxT pf s (a :*: b) (PMap m) = case lookupIxT pf (sizeT pf s) a m of
+ (lb, x, rb) -> let lookupX = do Asc i a' m' <- x
+ let (lb', x', rb') = lookupIxT pf s b m'
+ let f = onIndexA (i +) . onKeyA (a' :*:)
+ return (f <$> lb', f <$> x', f <$> rb')
+ in ((do Asc iA aL mL <- lb
+ fmap (onIndexA (iA +) . onKeyA (aL :*:)) (getLast pf s mL)) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, rb') <- First lookupX
+ rb') <|>
+ (do Asc iA aR mR <- rb
+ fmap (onIndexA (iA +) . onKeyA (aR :*:)) (getFirst pf s mR)))
+ where getLast pf s m = aboutT pf (\ k a -> return (Asc (sizeT pf s m - s a) k a)) m
+ getFirst pf s m = aboutT pf (\ k a -> return (Asc 0 k a)) m
+ assocAtT pf s i (PMap m) = case assocAtT pf (sizeT pf s) i m of
+ (lb, x, rb) -> let lookupX = do Asc i' a' m' <- x
+ let (lb', x', rb') = assocAtT pf s (i - i') m'
+ let f = onIndexA (i' +) . onKeyA (a' :*:)
+ return (f <$> lb', f <$> x', f <$> rb')
+ in ((do Asc iA aL mL <- lb
+ fmap (onIndexA (iA +) . onKeyA (aL :*:)) (getLast pf s mL)) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, rb') <- First lookupX
+ rb') <|>
+ (do Asc iA aR mR <- rb
+ fmap (onIndexA (iA +) . onKeyA (aR :*:)) (getFirst pf s mR)))
+ where getLast pf s m = aboutT pf (\ k a -> return (Asc (sizeT pf s m - s a) k a)) m
+ getFirst pf s m = aboutT pf (\ k a -> return (Asc 0 k a)) m
+-- updateAtT pf s r f i (PMap m) = PMap (updateAtT pf (sizeT pf s) r g i m) where
+-- g iA a m
+-- | i >= iA && i <= iA + maxIx pf s m
+-- = (guardNullT pf . updateAtT pf s r (\ iB b -> f (iA + iB) (a :*: b)) (i - iA)) m
+-- | i < iA
+-- = guardNullT pf $
+-- alterMaxT pf s (\ b v -> f (iA + sizeT pf s m - s v) (a :*: b) v) m
+-- | otherwise
+-- = guardNullT pf $ alterMinT pf s (f iA . (a :*:)) m
+ alterT pf s f (a :*: b) (PMap m) = PMap (alterT pf (sizeT pf 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 pf 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 pf s1) (sizeT pf 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 pf 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 pf 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 pf 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 pf s) g m1 m2) where
+ g a = guardNullT pf .: diffT pf s (\ b -> f (a :*: b))
+ extractT pf s f (PMap m) = second PMap <$> extractT pf (sizeT pf s) g m where
+ g a = second (guardNullT pf) <.> extractT pf s (\ b -> f (a :*: b))
+-- extractMinT pf s f (PMap m) = second PMap <$> extractMinT pf (sizeT pf s) g m where
+-- g a m1 = fromJust $ getFirst $ second (guardNullT pf) <$> extractMinT pf s (f . (a :*:)) m1
+-- extractMaxT pf s f (PMap m) = second PMap <$> extractMaxT pf (sizeT pf s) g m where
+-- g a m1 = fromJust $ getLast $ second (guardNullT pf) <$> extractMaxT pf s (f . (a :*:)) m1
+-- alterMinT pf s f (PMap m) = PMap (alterMinT pf (sizeT pf 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 pf 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 pf s) (\ a -> fromListT pf s (\ b -> f (a :*: b)))
+ (fromListT pf (const 1) (\ _ (xs) (ys) -> (xs ++ ys))
+ [(a, ts) | (a, ts) <- breakFst pf xs]))
+ fromAscListT pf s f xs = PMap (fromDistAscListT pf (sizeT pf s)
+ [(a, fromAscListT pf s (\ b -> f (a :*: b)) ts) | (a, ts) <- breakFst pf xs])
+ fromDistAscListT pf s xs = PMap (fromDistAscListT pf (sizeT pf 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)] -> [(f r ix, [(g r ix, a)])]
+ 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)]
+ |]) \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/Sized.hs b/Data/TrieMap/MultiRec/Sized.hs
index 9850046..2d3216c 100644
--- a/Data/TrieMap/MultiRec/Sized.hs
+++ b/Data/TrieMap/MultiRec/Sized.hs
@@ -12,9 +12,9 @@ module Data.TrieMap.MultiRec.Sized where
-- 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
+type HSized (phi :: * -> *) a = a -> Int
newtype Elem a = Elem {getElem :: a}
-sizeElem :: HSized phi Elem
+sizeElem :: HSized phi (Elem a)
sizeElem _ = 1 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/TH.hs b/Data/TrieMap/MultiRec/TH.hs
new file mode 100644
index 0000000..95dc3cd
--- /dev/null
+++ b/Data/TrieMap/MultiRec/TH.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, QuasiQuotes, TemplateHaskell #-}
+
+module Data.TrieMap.MultiRec.TH where
+
+import Data.TrieMap.MultiRec.Class
+import Data.TrieMap.MultiRec.Ord
+import Language.Haskell.TH
+import Language.Haskell.TH.Ppr
+import Control.Monad
+import Debug.Trace
+
+data Scheme = Sch {empt, nul, siz, look, lookIx, assocAt, updateAt, alter, traverse, fold, foldl, mapE, splitL, union, isect, diff, extractMi, extractMa, alterMi, alterMa, isSub, fromL, fromAL, fromDAL :: String}
+
+htriekeyT :: Scheme
+htriekeyT = Sch "emptyT" "nullT" "sizeT" "lookupT" "lookupIxT" "assocAtT" "updateAtT" "alterT" "traverseWithKeyT" "foldWithKeyT" "foldlWithKeyT"
+ "mapEitherT" "splitLookupT" "unionT" "isectT" "diffT" "extractMinT" "extractMaxT" "alterMinT" "alterMaxT" "isSubmapT"
+ "fromListT" "fromAscListT" "fromDistAscListT"
+
+htriekey :: Scheme
+htriekey = Sch "emptyH" "nullH" "sizeH" "lookupH" "lookupIxH" "assocAtH" "updateAtH" "alterH" "traverseWithKeyH" "foldWithKeyH" "foldlWithKeyH"
+ "mapEitherH" "splitLookupH" "unionH" "isectH" "diffH" "extractHinH" "extractHaxH" "alterHinH" "alterHaxH" "isSubmapH"
+ "fromListH" "fromAscListH" "fromDistAscListH"
+
+{-inferNewtype :: Name -> Name -> Scheme -> Scheme -> Q [Dec] -> Q [Dec]
+inferNewtype kCon mCon sch1 sch2 decl = do
+ decs@(InstanceD cxt t _:_) <- decl
+ let fund = FunD . mkName
+ let mcon = ConE mCon
+ mapV <- newName "m"
+ let mapVar = VarE mapV
+ let mapPat = ConP mCon [VarP mapV]
+ pfV <- newName "pf"
+ let pfPat = VarP pfV
+ let pfVar = VarE pfV
+ szV <- newName "s"
+ let szPat = VarP szV
+ let szVar = VarE szV
+ let empty = fund (empt sch1) [pfPat] (AppE mcon (AppE (VarE (empt sch2)) pfVar))
+ let null = fund (nul sch1) [pfPat, mapPat] (VarE (nul sch2) `AppE` pfVar `AppE` mapVar)
+ let size = fund (siz sch1) [pfPat, szPat, mapPat] (VarE (siz sch2) `AppE` pfVar `AppE` szPat `AppE` mapVar
+ return [InstanceD cxt t [empty, null, size]]-}
+
+
+inferH :: Q [Dec] -> Q [Dec]
+inferH instanceT = do
+ iT@(InstanceD cxt0 (htriekeyt `AppT` phi `AppT` f `AppT` m) _:_) <- instanceT
+ (InstanceD _ _ decs:_) <- [d|
+ instance (HTrieKeyT phi f m, HTrieKey phi r mm, HOrd0 phi (f r)) => HTrieKey phi (f r) (m 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
+ extractH = extractT
+-- alterMinH = alterMinT
+-- alterMaxH = alterMaxT
+-- extractMinH = extractMinT
+-- extractMaxH = extractMaxT
+ isSubmapH = isSubmapT
+ fromListH = fromListT
+ fromAscListH = fromAscListT
+ fromDistAscListH = fromDistAscListT |]
+ let r = mkName "r"
+ let mm = mkName "mm"
+-- let phiT = varT phi
+ let rT = varT r
+ let mmT = varT mm
+-- let mT = varT m
+ let htriekey = conT ''HTrieKey
+ let hord = conT ''HOrd
+ let hord0 = conT ''HOrd0
+ let htriemap = conT ''HTrieMap
+ ans <- instanceD (cxt (map return cxt0 ++ [htriekey `appQ` phi `appT` rT `appT` (htriemap `appQ` phi `appT` rT)]))
+ (htriekey `appT` return phi `appT` (return f `appT` rT) `appT` (return m `appT` rT)) (map return decs)
+ return (ans:iT)
+
+appQ :: TypeQ -> Type -> TypeQ
+t1 `appQ` t2 = t1 `appT` return t2 \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/TagMap.hs b/Data/TrieMap/MultiRec/TagMap.hs
index f206b39..5d66bdc 100644
--- a/Data/TrieMap/MultiRec/TagMap.hs
+++ b/Data/TrieMap/MultiRec/TagMap.hs
@@ -1,12 +1,14 @@
-{-# LANGUAGE Rank2Types, TypeOperators, KindSignatures, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, GADTs, MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell, Rank2Types, TypeOperators, KindSignatures, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, GADTs, MultiParamTypeClasses #-}
-module Data.TrieMap.MultiRec.TagMap where
+module Data.TrieMap.MultiRec.TagMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Eq
import Data.TrieMap.MultiRec.Sized
+import Data.TrieMap.MultiRec.TH
import Data.TrieMap.Applicative
import Data.TrieMap.TrieKey
+-- import Data.TrieMap.Rep
import Control.Applicative
import Control.Arrow
@@ -17,88 +19,98 @@ import Data.Monoid
import Data.Foldable
import Generics.MultiRec
-data TagF a ix :: * -> * where
- TagF :: a ix -> TagF a ix ix
+data TagF a ix xi where
+ TagF :: a -> TagF a ix ix
-unTagF :: TagF a ix xi -> a xi
+unTagF :: TagF a ix xi -> a
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
+newtype TagMap (phi :: * -> *) f ix (r :: * -> *) xi a = TagMap (HTrieMapT phi f r xi (TagF a ix xi))
+type instance HTrieMapT phi (f :>: ix) = TagMap 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) ->
+-- type instance RepT (TagMap phi f ix r xi) = RepT (HTrieMapT phi f r xi)
+-- type instance Rep (TagMap phi f ix r xi a) = RepT (HTrieMapT phi f r xi) (Rep a)
+
+-- instance (ReprT (HTrieMapT phi f r xi), ix ~ xi) => ReprT (TagMap phi f ix r xi) where
+-- toRepT (TagMap m) = fmap unTagF (toRepT m)
+-- fromRepT = TagMap . fromRepT . fmap TagF
+--
+-- instance (ReprT (HTrieMapT phi f r xi), ix ~ xi, Repr a) => Repr (TagMap phi f ix r xi a) where
+-- toRep (TagMap m) = fmap (toRep . unTagF) (toRepT m)
+-- fromRep = TagMap . fromRepT . fmap (TagF . fromRep)
+
+combineTag :: IsectFunc ((f :>: ix) r xi) (a) (b) (c) ->
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 :: Functor t => ((f :>: ix) r xi -> a -> t (b)) -> 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 :: HSized phi a -> HSized phi (TagF a ix xi)
sizeTag s (TagF x) = s x
-instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f) => HTrieKeyT phi (f :>: ix) (TagMap phi m ix) where
+restructure :: HTrieKeyT phi f (HTrieMapT phi f) =>
+ ((f r ix, TagF a xi ix), HTrieMapT phi f r ix (TagF a xi ix)) -> (((f :>: xi) r ix, a), TagMap phi f xi r ix a)
+restructure ((k, TagF a), m) = ((Tag k, a), TagMap m)
+
+restructure' :: Applicative t => ((f :>: xi) r ix -> a -> t (x, Maybe a)) -> f r ix -> TagF a xi ix -> t (x, Maybe (TagF a xi ix))
+restructure' f k (TagF a) = second (fmap TagF) <$> f (Tag k) a
+
+retag :: (f r ix, TagF a xi ix) -> ((f :>: xi) r ix, a)
+retag (k, TagF a) = (Tag k, a)
+
+$(inferH [d|
+ instance (HTrieKeyT phi f (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
+ sizeT pf s (TagMap m) = sizeT pf (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
+ lookupIxT pf s (Tag k) (TagMap m) = onValue retag (lookupIxT pf (sizeTag s) k m)
+ assocAtT pf s i (TagMap m) = onValue retag (assocAtT pf (sizeTag s) i m)
+-- updateAtT pf s r f i (TagMap m) = TagMap (updateAtT pf (sizeTag s) r (f' f) i m) where
+-- f' :: (Int -> (f :>: xi) r ix -> a -> Maybe (a)) -> 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' :: Applicative t => ((f :>: ix) r xi -> a -> t (b )) -> 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 :>: ix) r xi -> a -> 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 :>: ix) r xi -> b -> a -> 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' :: EitherMap ((f :>: ix) r xi) (a ) (b) (c) -> 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' :: SplitMap (a) 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)
+-- extractMinT pf s f (TagMap m) = second TagMap <$> extractMinT pf (sizeTag s) (restructure' f) m
+-- extractMaxT pf s f (TagMap m) = second TagMap <$> extractMaxT pf (sizeTag s) (restructure' f) m
+ extractT pf s f (TagMap m) = second TagMap <$> extractT pf (sizeTag s) (restructure' f) m
+-- 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 :: LEq a b -> 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 :>: ix) r xi -> a -> a -> a) -> 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 :>: ix) r xi -> a -> a -> a ) -> 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 :: ((f :>: ix) r xi, a) -> (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
+ HTrieKey phi ((f :>: ix) r) (TagMap phi f ix r) where
emptyH = emptyT
nullH = nullT
sizeH = sizeT
@@ -122,4 +134,4 @@ instance (HTrieKeyT phi f m, m ~ HTrieMapT phi f, HTrieKey phi r (HTrieMap phi r
isSubmapH = isSubmapT
fromListH = fromListT
fromAscListH = fromAscListT
- fromDistAscListH = fromDistAscListT \ No newline at end of file
+ fromDistAscListH = fromDistAscListT-} \ No newline at end of file
diff --git a/Data/TrieMap/MultiRec/UnionMap.hs b/Data/TrieMap/MultiRec/UnionMap.hs
index e976db3..f07e4a3 100644
--- a/Data/TrieMap/MultiRec/UnionMap.hs
+++ b/Data/TrieMap/MultiRec/UnionMap.hs
@@ -1,46 +1,75 @@
-{-# LANGUAGE TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, MultiParamTypeClasses, TypeOperators #-}
+{-# LANGUAGE TemplateHaskell, TypeFamilies, KindSignatures, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, MultiParamTypeClasses, TypeOperators #-}
-module Data.TrieMap.MultiRec.UnionMap where
+module Data.TrieMap.MultiRec.UnionMap () where
import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Eq
+import Data.TrieMap.MultiRec.Base
import Data.TrieMap.Applicative
import Data.TrieMap.TrieKey
+-- import Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.TH
+import Data.TrieMap.MultiRec.TH
+import qualified Data.TrieMap.Regular.Base as Reg
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Maybe
+import Data.Monoid
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)
+data UnionMap (phi :: * -> *) f g (r :: * -> *) ix a = HTrieMapT phi f r ix a :&: HTrieMapT phi g r ix a
+type instance HTrieMapT phi (f :+: g) = UnionMap phi f 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
+-- type instance RepT (UnionMap phi f g r ix) = (Reg.:*:) (RepT (HTrieMapT phi f r ix)) (RepT (HTrieMapT phi g r ix))
+-- type instance Rep (UnionMap phi f g r ix a) = RepT (UnionMap phi f g r ix) (Rep a)
+
+-- -- $(genRepT [d|
+-- instance (ReprT (HTrieMapT phi f r ix), ReprT (HTrieMapT phi g r ix)) => ReprT (UnionMap phi f g r ix) where
+-- toRepT (m1 :&: m2) = (Reg.:*:) (toRepT m1) (toRepT m2)
+-- fromRepT ((Reg.:*:) m1 m2) = fromRepT m1 :&: fromRepT m2
+-- |])
+
+$(inferH [d|
+ instance (HTrieKeyT phi f (HTrieMapT phi f), HTrieKeyT phi g (HTrieMapT phi g)) => HTrieKeyT phi (f :+: g) (UnionMap phi f g) 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
+ sizeT pf s (m1 :&: m2) = sizeT pf s m1 + sizeT pf 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
+ | L k <- k = case onKey L (lookupIxT pf s k m1) of
+ (lb, x, ub) -> (lb, x, ub <|> ((onKeyA R . onIndexA (+ sizeT pf s m1)) <$> getMin pf s m2))
+ | R k <- k = case onIndex (sizeT pf s m1 +) (onKey R (lookupIxT pf s k m2)) of
+ (lb, x, ub) -> ((onKeyA L <$> getMax pf s m1) <|> lb, x, ub)
+ where getMin pf s m = aboutT pf (\ k a -> return $ Asc 0 k a) m
+ getMax pf s m = aboutT pf (\ k a -> return $ Asc (sizeT pf s m - s a) k a) m
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
+ | i < s1 = case onKey L (assocAtT pf s i m1) of
+ (lb, x, ub) -> (lb, x, ub <|> ((onKeyA R . onIndexA (+ s1)) <$> getMin pf s m2))
+ | otherwise = case onKey R (onIndex (s1 +) (assocAtT pf s (i - s1) m2)) of
+ (lb, x, ub) -> ((onKeyA L <$> getMax pf s m1) <|> lb, x, ub)
+ where getMin pf s m = aboutT pf (\ k a -> return $ Asc 0 k a) m
+ getMax pf s m = aboutT pf (\ k a -> return $ Asc (sizeT pf s m - s a) k a) m
+ s1 = sizeT pf s m1
+{- updateAtT pf s r f i (m1 :&: m2)
+ | not r && i >= lastIx m1
+ = m1 :&: updateAtT pf s r (\ i' -> f (i' + s1) . R) (i - s1) m2
+ | i < s1
+ = updateAtT pf s r (\ i' -> f i' . L) i m1 :&: m2
+ | otherwise
+ = m1 :&: updateAtT pf s r (\ i' -> f (i' + s1) . R) (i - s1) m2
+ where s1 = sizeT pf s m1
+ lastIx m = case extractMaxT pf s (\ _ v -> (v, Just v)) m of
+ Last (Just (v, _)) -> sizeT pf s m - s v
+ _ -> sizeT pf s m-}
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
@@ -63,22 +92,18 @@ instance (HTrieKeyT phi f m1, HTrieKeyT phi g m2) => HTrieKeyT phi (f :+: g) (Un
= 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
+ extractT pf s f (m1 :&: m2) = second (:&: m2) <$> extractT pf s (f . L) m1 <|>
+ second (m1 :&:) <$> extractT pf s (f . R) m2
+-- extractMinT pf s f (m1 :&: m2) = second (:&: m2) <$> extractMinT pf s (f . L) m1 <|>
+-- second (m1 :&:) <$> extractMinT pf s (f . R) m2
+-- extractMaxT pf s f (m1 :&: m2) = second (:&: m2) <$> extractMaxT pf s (f . L) m1 <|>
+-- second (m1 :&:) <$> extractMaxT pf s (f . R) 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
@@ -86,36 +111,4 @@ instance (HTrieKeyT phi f m1, HTrieKeyT phi g m2) => HTrieKeyT phi (f :+: g) (Un
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
+ (ys, zs) -> fromDistAscListT pf s ys :&: fromDistAscListT pf s zs |])
diff --git a/Data/TrieMap/MultiRec/UnitMap.hs b/Data/TrieMap/MultiRec/UnitMap.hs
index e4caa41..c78a570 100644
--- a/Data/TrieMap/MultiRec/UnitMap.hs
+++ b/Data/TrieMap/MultiRec/UnitMap.hs
@@ -1,11 +1,14 @@
-{-# LANGUAGE KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances, TemplateHaskell, KindSignatures, TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}
-module Data.TrieMap.MultiRec.UnitMap where
+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 Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.Instances
+-- import Data.TrieMap.Rep.TH
import Control.Applicative
import Control.Arrow
@@ -19,10 +22,18 @@ import Generics.MultiRec
import Prelude hiding (foldr, foldl)
-newtype UMap (phi :: * -> *) (r :: * -> *) a ix = UMap (Maybe (a ix))
+newtype UMap (phi :: * -> *) (r :: * -> *) ix a = UMap (Maybe a)
type instance HTrieMapT phi U = UMap phi
type instance HTrieMap phi (U r) = UMap phi r
+-- type instance RepT (UMap phi r ix) = RepT Maybe
+-- type instance Rep (UMap phi r ix a) = RepT Maybe (Rep a)
+--
+-- -- $(genRepT [d|
+-- instance ReprT (UMap phi r ix) where
+-- toRepT (UMap m) = toRepT m
+-- fromRepT = UMap . fromRepT |])
+
instance HTrieKeyT phi U (UMap phi) where
emptyT = emptyH
nullT = nullH
@@ -30,7 +41,7 @@ instance HTrieKeyT phi U (UMap phi) where
lookupT = lookupH
lookupIxT = lookupIxH
assocAtT = assocAtH
- updateAtT = updateAtH
+-- updateAtT = updateAtH
alterT = alterH
traverseWithKeyT = traverseWithKeyH
foldWithKeyT = foldWithKeyH
@@ -40,10 +51,11 @@ instance HTrieKeyT phi U (UMap phi) where
unionT = unionH
isectT = isectH
diffT = diffH
- extractMinT = extractMinH
- extractMaxT = extractMaxH
- alterMinT = alterMinH
- alterMaxT = alterMaxH
+ extractT = extractH
+-- extractMinT = extractMinH
+-- extractMaxT = extractMaxH
+-- alterMinT = alterMinH
+-- alterMaxT = alterMaxH
isSubmapT = isSubmapH
fromListT = fromListH
fromAscListT = fromAscListH
@@ -52,11 +64,15 @@ instance HTrieKeyT phi U (UMap phi) where
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
+ 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)
+ lookupIxH _ _ _ (UMap m) = (mempty, Asc 0 U <$> m, mempty)
+ assocAtH _ _ _ (UMap m) = (mempty, Asc 0 U <$> m, mempty)
+-- updateAtH _ s r f i (UMap m)
+-- | r == (i >= 0)
+-- = UMap (m >>= f 0 U)
+-- | otherwise
+-- = UMap m
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
@@ -66,12 +82,11 @@ instance HTrieKey phi (U r) (UMap phi r) where
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
+ extractH _ _ f (UMap m) = maybe empty (second UMap <.> f U) m
+-- extractMinH _ _ f (UMap m) = fmap (second UMap . f U) (First m)
+-- extractMaxH _ _ f (UMap m) = fmap (second UMap . f U) (Last m)
+-- alterMinH _ _ f (UMap m) = (UMap . f U) <$> (First m)
+-- alterMaxH _ _ f (UMap m) = (UMap . f U) <$> (Last m)
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)
diff --git a/Data/TrieMap/OrdMap.hs b/Data/TrieMap/OrdMap.hs
index 2e549cd..4888079 100644
--- a/Data/TrieMap/OrdMap.hs
+++ b/Data/TrieMap/OrdMap.hs
@@ -1,12 +1,16 @@
-{-# LANGUAGE Rank2Types, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances, TemplateHaskell, FlexibleContexts, TypeOperators, Rank2Types, PatternGuards, MultiParamTypeClasses, TypeFamilies #-}
-module Data.TrieMap.OrdMap (Ordered (..)) where
+module Data.TrieMap.OrdMap () where
import Data.TrieMap.TrieKey
import Data.TrieMap.Sized
import Data.TrieMap.Applicative
+import Data.TrieMap.Modifiers
+import Data.TrieMap.MultiRec.Base
+-- import Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.TH
-import Control.Applicative (Applicative(..), (<$>))
+import Control.Applicative (Applicative(..), Alternative(..), (<$>))
import Control.Arrow
import Control.Monad hiding (join)
@@ -18,33 +22,45 @@ 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)
+data OrdMap k a = Tip
+ | Bin {-# UNPACK #-} !Int k (a) !(OrdMap k a) !(OrdMap k a)
type instance TrieMap (Ordered k) = OrdMap k
+-- type instance RepT (OrdMap k) = FamT KeyFam (HFix (U :+: (K Int :*: K k :*: X :*: A0 :*: A0)))
+-- type instance Rep (OrdMap k a) = RepT (OrdMap k) (Rep a)
+
+-- -- $(genRepT [d|
+-- instance ReprT (OrdMap k) where
+-- toRepT = FamT . toFix where
+-- toFix Tip = HIn (L U)
+-- toFix (Bin s kx x l r) = HIn (R (K s :*: K kx :*: X x :*: A0 (toFix l) :*: A0 (toFix r)))
+-- fromRepT (FamT x) = fromFix x where
+-- fromFix (HIn L{}) = Tip
+-- fromFix (HIn (R (K s :*: K kx :*: X x :*: A0 l :*: A0 r)))
+-- = Bin s kx x (fromFix l) (fromFix r) |])
+
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)
+ lookupIxM s (Ord k) = onKey Ord . lookupIx s 0 k
+ assocAtM s i = onKey Ord . assocAt s 0 i
+-- updateAtM s r f = updateAt s 0 r (\ 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)
+ extractM s f m = extract s (f . Ord) m
+-- extractMinM _ _ Tip = mzero
+-- extractMinM s f m = return (deleteFindMin s (f . Ord) m)
+-- extractMaxM _ _ Tip = mzero
+-- extractMaxM s f m = return (deleteFindMax s (f . Ord) 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]
@@ -59,44 +75,70 @@ instance Ord k => TrieKey (Ordered k) (OrdMap k) where
(_, Tip) -> m1
_ -> hedgeDiffWithKey s (f . Ord) (const LT) (const GT) m1 m2
-lookup :: Ord k => k -> OrdMap k a ix -> Maybe (a ix)
+lookup :: Ord k => k -> OrdMap k a -> Maybe (a)
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
+lookupIx :: Ord k => Sized a -> Int -> k -> OrdMap k a -> IndexPos k a
+lookupIx _ i _ _ | i `seq` False = undefined
+lookupIx _ _ _ Tip = (mzero, mzero, mzero)
+lookupIx s i k (Bin sz kx x l r) = case compare k kx of
+ LT -> case lookupIx s i k l of
+ (lb, ans, ub) -> (lb, ans, ub <|> return (Asc (i + size l) kx x))
+ EQ -> (extractMax (\ k v -> Asc (i + size l - s v) k v) l,
+ return (Asc (i + size l) kx x),
+ extractMin (Asc (i + sz - size r)) r)
+ GT -> case lookupIx s (i + sz - size r) k r of
+ (lb, ans, ub) -> (return (Asc (i + size l) kx x) <|> lb, ans, ub)
+ where extractMin f Tip = mzero
+ extractMin f b = return (fst $ deleteFindMin s (\ k x -> (f k x, Just x)) b)
+ extractMax f Tip = mzero
+ extractMax f b = return (fst $ deleteFindMax s (\ k x -> (f k x, Just x)) b)
+
+assocAt :: Sized a -> Int -> Int -> OrdMap k a -> IndexPos k a
+assocAt _ i0 i _ | i0 `seq` i `seq` False = undefined
+assocAt _ _ _ Tip = (mzero, mzero, mzero)
+assocAt s i0 i (Bin sz k a l r)
+ | i < sL, (lb, ans, ub) <- assocAt s i0 i l
+ = (lb, ans, ub <|> return (Asc (i0 + size l) k a))
+ | i < sK = (extractMax (\ k v -> Asc (i0 + sL - s v) k v) l,
+ return (Asc (i0 + sL) k a),
+ extractMin (Asc sK) r)
+ | (lb, ans, ub) <- assocAt s (i0 + sK) (i - sK) r
+ = (return (Asc (i0 + sL) k a) <|> lb, ans, ub)
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
+ extractMin f Tip = mzero
+ extractMin f b = return (fst $ deleteFindMin s (\ k x -> (f k x, Just x)) b)
+ extractMax f Tip = mzero
+ extractMax f b = return (fst $ deleteFindMax s (\ k x -> (f k x, Just x)) b)
+
+updateAt :: Sized a -> Int -> Round -> (Int -> k -> a -> Maybe (a)) -> Int -> OrdMap k a -> OrdMap k a
+updateAt _ i0 _ _ i _ | i0 `seq` i `seq` False = undefined
+updateAt _ _ _ _ _ Tip = Tip
+updateAt s i0 True f i (Bin sz k a l r)
+ | i < sL = balance s k a (updateAt s i0 True f i l) r
+ | i < sK = case f (i0 + sL) 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)
+ | otherwise = balance s k a l (updateAt s (i0 + sK) True f (i - sK) r)
where sL = size l
sK = sz - size r
+updateAt s i0 False f i (Bin sz k a l r)
+ | i < maxIxL = balance s k a (updateAt s i0 False f i l) r
+ | i <= sL = case f (i0 + sL) k a of
+ Nothing -> glue s l r
+ Just a' -> bin s k a' l r
+ | otherwise = balance s k a l (updateAt s (i0 + sK) False f (i - sK) r)
+ where sL = size l
+ maxIxL = case l of Tip -> 0
+ _ -> fst (deleteFindMax s (\ _ a -> (size l - s a, Just a)) 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 :: Ord k => Sized a -> (Maybe (a) -> Maybe (a)) -> k -> OrdMap k a -> OrdMap k a
alter s f k Tip = case f Nothing of
Nothing -> Tip
Just x -> singleton s k x
@@ -107,30 +149,30 @@ alter s f k (Bin _ kx x l r) = case compare k kx of
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 :: Sized a -> k -> a -> OrdMap k a
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 :: Applicative f => Sized b -> (k -> a -> f (b)) -> OrdMap k a -> f (OrdMap k b)
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 :: (k -> a -> b -> b) -> OrdMap k a -> 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 :: (k -> b -> a -> b) -> OrdMap k a -> 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 :: Ord k => Sized b -> Sized c -> EitherMap k (a) (b) (c) ->
+ OrdMap k a -> (OrdMap k b, OrdMap k c)
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 :: Ord k => Sized a -> (k -> a -> Maybe (a)) -> OrdMap k a -> OrdMap k a
updateMin s f m = case m of
Tip -> Tip
Bin _ k a Tip r -> case f k a of
@@ -138,7 +180,7 @@ updateMin s f m = case m of
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 :: Ord k => Sized a -> (k -> a -> Maybe (a)) -> OrdMap k a -> OrdMap k a
updateMax s f m = case m of
Tip -> Tip
Bin _ k a l Tip -> case f k a of
@@ -146,7 +188,7 @@ updateMax s f m = case m of
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 :: Ord k => Sized a -> SplitMap (a) x -> k -> OrdMap k a -> (OrdMap k a, Maybe x, OrdMap k a)
splitLookup s f k m = case m of
Tip -> (Tip, Nothing, Tip)
Bin _ kx x l r -> case compare k kx of
@@ -158,7 +200,7 @@ splitLookup s f k m = case m of
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 :: Ord k => LEq (a) (b) -> LEq (OrdMap k a) (OrdMap k b)
isSubmap (<=) Tip _ = True
isSubmap (<=) _ Tip = False
isSubmap (<=) (Bin _ kx x l r) t = case found of
@@ -166,7 +208,7 @@ isSubmap (<=) (Bin _ kx x l r) t = case found of
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 :: Eq k => Sized a -> (k -> a -> a -> a) -> [(k, a)] -> OrdMap k a
fromAscList s f xs = fromDistinctAscList s (combineEq xs) where
combineEq (x:xs) = combineEq' x xs
combineEq [] = []
@@ -176,7 +218,7 @@ fromAscList s f xs = fromDistinctAscList s (combineEq xs) where
| 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 :: Sized a -> [(k, a)] -> OrdMap k a
fromDistinctAscList s xs = build const (length xs) xs
where
-- 1) use continutations so that we use heap space instead of stack space.
@@ -196,9 +238,9 @@ fromDistinctAscList s xs = build const (length xs) xs
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))
+ => Sized a -> (k -> a -> a -> Maybe (a))
-> (k -> Ordering) -> (k -> Ordering)
- -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+ -> OrdMap k a -> OrdMap k a -> OrdMap k a
hedgeUnionWithKey _ _ _ _ t1 Tip
= t1
hedgeUnionWithKey s _ cmplo cmphi Tip (Bin _ kx x l r)
@@ -214,7 +256,7 @@ hedgeUnionWithKey s f cmplo cmphi (Bin _ kx x l r) t2
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 :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a -> OrdMap k a
filterGt _ _ Tip = Tip
filterGt s cmp (Bin _ kx x l r)
= case cmp kx of
@@ -222,7 +264,7 @@ filterGt s cmp (Bin _ kx x 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 :: Ord k => Sized a -> (k -> Ordering) -> OrdMap k a -> OrdMap k a
filterLt _ _ Tip = Tip
filterLt s cmp (Bin _ kx x l r)
= case cmp kx of
@@ -230,7 +272,7 @@ filterLt s cmp (Bin _ kx x l r)
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 :: (k -> Ordering) -> (k -> Ordering) -> OrdMap k a -> OrdMap k a
trim _ _ Tip = Tip
trim cmplo cmphi t@(Bin _ kx _ l r)
= case cmplo kx of
@@ -239,7 +281,7 @@ trim cmplo cmphi t@(Bin _ kx _ l r)
_ -> 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 :: Ord k => k -> (k -> Ordering) -> OrdMap k a -> (Maybe (k,a), OrdMap k a)
trimLookupLo _ _ Tip = (Nothing,Tip)
trimLookupLo lo cmphi t@(Bin _ kx x l r)
= case compare lo kx of
@@ -249,7 +291,7 @@ trimLookupLo lo cmphi t@(Bin _ kx x l r)
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 :: Ord k => Sized c -> IsectFunc k (a) (b) (c) -> OrdMap k a -> OrdMap k b -> OrdMap k c
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) =
@@ -260,9 +302,9 @@ isect s f t1@(Bin _ k1 x1 l1 r1) t2@(Bin _ k2 x2 l2 r2) =
hedgeDiffWithKey :: Ord k
- => Sized a -> (k -> a ix -> b ix -> Maybe (a ix))
+ => Sized a -> (k -> a -> b -> Maybe (a))
-> (k -> Ordering) -> (k -> Ordering)
- -> OrdMap k a ix -> OrdMap k b ix -> OrdMap k a ix
+ -> OrdMap k a -> OrdMap k b -> OrdMap k a
hedgeDiffWithKey _ _ _ _ Tip _
= Tip
hedgeDiffWithKey s _ cmplo cmphi (Bin _ kx x l r) Tip
@@ -281,10 +323,10 @@ hedgeDiffWithKey s f cmplo cmphi t (Bin _ kx x l r)
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 :: Ord k => Sized a -> k -> Maybe (a) -> OrdMap k a -> OrdMap k a -> OrdMap k a
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 :: Ord k => Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
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)
@@ -294,7 +336,7 @@ join s kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
-- 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,insertMin :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a
insertMax s kx x t
= case t of
Tip -> singleton s kx x
@@ -310,7 +352,7 @@ insertMin s kx x t
{--------------------------------------------------------------------
[merge l r]: merges two trees.
--------------------------------------------------------------------}
-merge :: Sized a -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+merge :: Sized a -> OrdMap k a -> OrdMap k a -> OrdMap k a
merge _ Tip r = r
merge _ l Tip = l
merge s l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
@@ -322,36 +364,43 @@ merge s l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
[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 :: Sized a -> OrdMap k a -> OrdMap k a -> OrdMap k a
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
+ | size l > size r = let (f,l') = deleteFindMax s (\ k a -> (balance s k a, Nothing)) l in f l' r
+ | otherwise = let (f,r') = deleteFindMin s (\ k a -> (balance s k a, Nothing)) r in f l r'
+
+extract :: Alternative t => Sized a -> (k -> a -> t (z, Maybe a)) -> OrdMap k a -> t (z, OrdMap k a)
+extract s f t = case t of
+ Bin _ k x l r ->
+ second (\ l' -> balance s k x l' r) <$> extract s f l <|>
+ second (maybe (glue s l r) (\ x' -> balance s k x' l r)) <$> f k x <|>
+ second (balance s k x l) <$> extract s f r
+
+deleteFindMin :: Sized a -> (k -> a -> (x, Maybe a)) -> OrdMap k a -> (x, OrdMap k a)
+deleteFindMin s f 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)
+ Bin _ k x Tip r -> let (ans, x') = f k x in (ans, maybe r (\ y' -> bin s k y' Tip r) x')
+ Bin _ k x l r -> let (km,l') = deleteFindMin s f 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
+deleteFindMax :: Sized a -> (k -> a -> (x, Maybe a)) -> OrdMap k a -> (x, OrdMap k a)
+deleteFindMax s f 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')
+ Bin _ k x l Tip -> let (ans, x') = f k x in (ans, maybe l (\ y -> bin s k y l Tip) x')
+ Bin _ k x l r -> let (km,r') = deleteFindMax s f 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 :: OrdMap k a -> 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 :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
balance s k x l r
| sizeL + sizeR <= 1 = Bin sizeX k x l r
| sizeR >= delta*sizeL = rotateL s k x l r
@@ -363,31 +412,31 @@ balance s k x l 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 :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
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 :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
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, singleR :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
singleL s k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin s k2 x2 (bin s k1 x1 t1 t2) t3
singleL s k1 x1 t1 Tip = bin s k1 x1 t1 Tip
singleR s k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin s k2 x2 t1 (bin s k1 x1 t2 t3)
singleR s k1 x1 Tip t2 = bin s k1 x1 Tip t2
-doubleL, doubleR :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+doubleL, doubleR :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
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 s k1 x1 t1 t2 = singleL s k1 x1 t1 t2
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 s k1 x1 t1 t2 = singleR s k1 x1 t1 t2
-bin :: Sized a -> k -> a ix -> OrdMap k a ix -> OrdMap k a ix -> OrdMap k a ix
+bin :: Sized a -> k -> a -> OrdMap k a -> OrdMap k a -> OrdMap k a
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/Base.hs b/Data/TrieMap/Regular/Base.hs
index 25894d2..4234320 100644
--- a/Data/TrieMap/Regular/Base.hs
+++ b/Data/TrieMap/Regular/Base.hs
@@ -10,12 +10,16 @@ data U0 r = U0 deriving (Show)
data (f :*: g) r = f r :*: g r deriving (Show)
data (f :+: g) r = L (f r) | R (g r) deriving (Show)
newtype L f r = List [f r] deriving (Show)
+newtype (f `O` g) r = O (f (g r))
newtype Reg r = Reg {unReg :: r} deriving (Show)
newtype Fix f = In {out :: f (Fix f)}
type family PF a :: * -> *
+instance (Functor f, Functor g) => Functor (f `O` g) where
+ fmap f (O x) = O (fmap (fmap f) x)
+
class Regular a where
from :: a -> PF a a
to :: PF a a -> a
@@ -59,4 +63,9 @@ 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
+infixr 6 :+:
+
+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) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Class.hs b/Data/TrieMap/Regular/Class.hs
index 63af849..0931a90 100644
--- a/Data/TrieMap/Regular/Class.hs
+++ b/Data/TrieMap/Regular/Class.hs
@@ -12,58 +12,76 @@ import Data.Monoid
import Control.Applicative
-type family TrieMapT (f :: * -> *) :: * -> (* -> *) -> * -> *
+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
+class OrdT f => TrieKeyT (f :: * -> *) (m :: * -> * -> *) | m -> f, f -> m where
+ emptyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a
+ nullT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => m k a -> Bool
+ sizeT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> m k a -> Int
+ lookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => f k -> m k a -> Maybe (a)
+ lookupIxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> f k -> m k a -> IndexPos (f k) a
+ assocAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> Int -> m k a -> IndexPos (f k) a
+-- updateAtT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> Round -> (Int -> f k -> a -> Maybe (a)) -> Int -> m k a -> m k a
+ alterT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (Maybe (a) -> Maybe (a)) -> f k -> m k a -> m k a
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)
+ Sized b -> (f k -> a -> t (b)) -> m k a -> t (m k b)
foldWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>
- (f k -> a ix -> b -> b) -> m k a ix -> b -> b
+ (f k -> a -> b -> b) -> m k a -> b -> b
foldlWithKeyT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) =>
- (f k -> b -> a ix -> b) -> m k a ix -> b -> b
+ (f k -> b -> a -> b) -> m k a -> 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
+ Sized b -> Sized c -> EitherMap (f k) (a) (b) (c) -> m k a -> (m k b, m k c)
+ splitLookupT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> SplitMap (a) x -> f k ->
+ m k a -> (m k a, Maybe x, m k a)
+ unionT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> UnionFunc (f k) (a) ->
+ m k a -> m k a -> m k a
+ isectT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized c -> IsectFunc (f k) (a) (b) (c) ->
+ m k a -> m k b -> m k c
+ diffT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> DiffFunc (f k) (a) (b) ->
+ m k a -> m k b -> m k a
+ extractT :: (TrieMapT f ~ m, TrieKey k (TrieMap k), Alternative t) =>
+ Sized a -> ExtractFunc t (m k a) (f k) a x
+-- extractMinT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> ExtractFunc (f k) First a (m k a) x
+-- extractMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> ExtractFunc (f k) Last a (m k a) x
+-- alterMinT, alterMaxT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a -> Maybe (a)) ->
+-- m k a -> m k a
+ isSubmapT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => LEq (a) (b) -> LEq (m k a) (m k b)
+ fromListT, fromAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> (f k -> a -> a -> a) ->
+ [(f k, a)] -> m k a
+ fromDistAscListT :: (TrieMapT f ~ m, TrieKey k (TrieMap k)) => Sized a -> [(f k, a)] -> m k a
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
+-- 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)
+-- mapWithKeyT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+-- Sized b -> (f k -> a -> b) -> TrieMapT f k a -> TrieMapT f k b
+-- mapWithKeyT s f m = unId (traverseWithKeyT s (\ k a -> Id (f k a)) m)
+
+guardNullT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a -> Maybe (TrieMapT f k a)
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieMapT f k a -> [(f k, a)]
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> f k -> a -> TrieMapT f k a
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
+ Sized b -> (f k -> a -> b) -> TrieMapT f k a -> TrieMapT f k b
mapWithKeyT s f m = unId (traverseWithKeyT s (Id .: f) m)
+
+aboutT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) =>
+ (f k -> a -> t z) -> TrieMapT f k a -> t z
+aboutT f m = fst <$> extractT (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) m
+
+{-alterMinT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> (f k -> a -> Maybe a) -> TrieMapT f k a -> TrieMapT f k a
+alterMinT s f m = maybe m snd (getFirst (extractMinT s (\ k a -> ((), f k a)) m))
+
+alterMaxT :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+ Sized a -> (f k -> a -> Maybe a) -> TrieMapT f k a -> TrieMapT f k a-}
+-- alterMaxT s f m = maybe m snd (getLast (extractMaxT s (\ k a -> ((), f k a)) m)) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/CompMap.hs b/Data/TrieMap/Regular/CompMap.hs
new file mode 100644
index 0000000..db68f23
--- /dev/null
+++ b/Data/TrieMap/Regular/CompMap.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE TemplateHaskell, PatternGuards, UndecidableInstances, FlexibleContexts, TypeOperators, TypeFamilies, MultiParamTypeClasses #-}
+
+module Data.TrieMap.Regular.CompMap () where
+
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.Ord
+import Data.TrieMap.Regular.Eq
+import Data.TrieMap.Regular.TH
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.TH
+
+import Control.Applicative
+import Control.Arrow
+
+import Prelude hiding (lookup)
+
+newtype CompMap m g k a = CMap (m (App g k) a)
+newtype App f a = A {unA :: f a}
+newtype AppMap m k a = AMap (m k a)
+
+type instance TrieMapT (App f) = AppMap (TrieMapT f)
+type instance TrieMap (App f r) = AppMap (TrieMapT f) r
+type instance TrieMapT (f `O` g) = CompMap (TrieMapT f) g
+type instance TrieMap ((f `O` g) r) = CompMap (TrieMapT f) g r
+
+instance EqT f => EqT (App f) where
+ eqT0 (==) (A a) (A b) = eqT0 (==) a b
+
+instance OrdT f => OrdT (App f) where
+ compareT0 cmp (A a) (A b) = compareT0 cmp a b
+
+instance (EqT f, Eq r) => Eq (App f r) where
+ (==) = eqT
+
+instance (OrdT f, Ord g) => Ord (App f g) where
+ compare = compareT
+
+$(deriveM [d|
+ instance (TrieKeyT f m, Functor f, TrieKeyT g (TrieMapT g)) => TrieKeyT (f `O` g) (CompMap m g) where
+ emptyT = CMap emptyT
+ nullT (CMap m) = nullT m
+ sizeT s (CMap m) = sizeT s m
+ lookupT (O x) (CMap m) = lookupT (fmap A x) m
+ lookupIxT s (O x) (CMap m) = onKey (O . fmap unA) (lookupIxT s (fmap A x) m)
+ assocAtT s i (CMap m) = onKey (O . fmap unA) (assocAtT s i m)
+-- updateAtT s r f i (CMap m)
+-- = CMap (updateAtT s r (\ i' -> f i' . O . fmap unA) i m)
+ alterT s f (O x) (CMap m) = CMap (alterT s f (fmap A x) m)
+ traverseWithKeyT s f (CMap m) = CMap <$> traverseWithKeyT s (f . O . fmap unA) m
+ foldWithKeyT f (CMap m) = foldWithKeyT (f . O . fmap unA) m
+ foldlWithKeyT f (CMap m) = foldlWithKeyT (f . O . fmap unA) m
+ mapEitherT s1 s2 f (CMap m) = (CMap *** CMap) (mapEitherT s1 s2 (f . O . fmap unA) m)
+ splitLookupT s f (O k) (CMap m) = CMap `sides` splitLookupT s f (fmap A k) m
+ isSubmapT (<=) (CMap m1) (CMap m2) = isSubmapT (<=) m1 m2
+ extractT s f (CMap m) = second CMap <$> extractT s (f . O . fmap unA) m
+-- extractMinT s f (CMap m) = second CMap <$> extractMinT s (f . O . fmap unA) m
+-- extractMaxT s f (CMap m) = second CMap <$> extractMaxT s (f . O . fmap unA) m
+-- alterMinT s f (CMap m) = CMap (alterMinT s (f . O . fmap unA) m)
+-- alterMaxT s f (CMap m) = CMap (alterMaxT s (f . O . fmap unA) m)
+ unionT s f (CMap m1) (CMap m2) = CMap (unionT s (f . O . fmap unA) m1 m2)
+ isectT s f (CMap m1) (CMap m2) = CMap (isectT s (f . O . fmap unA) m1 m2)
+ diffT s f (CMap m1) (CMap m2) = CMap (diffT s (f . O . fmap unA) m1 m2) |])
+
+$(deriveM [d|
+ instance TrieKeyT f m => TrieKeyT (App f) (AppMap m) where
+ emptyT = AMap emptyT
+ nullT (AMap m) = nullT m
+ sizeT s (AMap m) = sizeT s m
+ lookupT (A k) (AMap m) = lookupT k m
+ lookupIxT s (A k) (AMap m) = onKey A (lookupIxT s k m)
+ assocAtT s i (AMap m) = onKey A (assocAtT s i m)
+-- updateAtT s r f i (AMap m) = AMap (updateAtT s r (\ i' -> f i' . A) i m)
+ alterT s f (A k) (AMap m) = AMap (alterT s f k m)
+ traverseWithKeyT s f (AMap m) = AMap <$> traverseWithKeyT s (f . A) m
+ foldWithKeyT f (AMap m) = foldWithKeyT (f . A) m
+ foldlWithKeyT f (AMap m) = foldlWithKeyT (f . A) m
+ mapEitherT s1 s2 f (AMap m) = (AMap *** AMap) (mapEitherT s1 s2 (f . A) m)
+ splitLookupT s f (A k) (AMap m) = AMap `sides` splitLookupT s f k m
+ extractT s f (AMap m) = second AMap <$> extractT s (f . A) m
+-- extractMinT s f (AMap m) = second AMap <$> extractMinT s (f . A) m
+-- extractMaxT s f (AMap m) = second AMap <$> extractMaxT s (f . A) m
+-- alterMinT s f (AMap m) = AMap (alterMinT s (f . A) m)
+-- alterMaxT s f (AMap m) = AMap (alterMaxT s (f . A) m)
+ unionT s f (AMap m1) (AMap m2) = AMap (unionT s (f . A) m1 m2)
+ isectT s f (AMap m1) (AMap m2) = AMap (isectT s (f . A) m1 m2)
+ diffT s f (AMap m1) (AMap m2) = AMap (diffT s (f . A) m1 m2)
+ isSubmapT (<=) (AMap m1) (AMap m2) = isSubmapT (<=) m1 m2 |]) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/ConstMap.hs b/Data/TrieMap/Regular/ConstMap.hs
index fdb38ef..3a1993a 100644
--- a/Data/TrieMap/Regular/ConstMap.hs
+++ b/Data/TrieMap/Regular/ConstMap.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-}
-module Data.TrieMap.Regular.ConstMap where
+module Data.TrieMap.Regular.ConstMap() where
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
@@ -12,24 +12,18 @@ import Control.Monad
-- import Data.Monoid
-newtype KMap m k (a :: * -> *) ix = KMap (m a ix)
+newtype KMap m k a = KMap (m a)
type instance TrieMapT (K0 a) = KMap (TrieMap a)
type instance TrieMap (K0 a r) = TrieMapT (K0 a) r
-type instance PF (KMap m k a ix) = PF (m a ix)
-
-instance (Regular (m a ix), Functor (PF (m a ix))) => Regular (KMap m k a ix) where
- from (KMap m) = fmap KMap (from m)
- to = KMap . to . fmap (\ (KMap m) -> m)
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)
+ lookupIxM s (K0 k) (KMap m) = onKey K0 (lookupIxM s k m)
+ assocAtM s i (KMap m) = onKey K0 (assocAtM s i m)
+-- updateAtM s r f i (KMap m) = KMap (updateAtM s r (\ 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
@@ -39,10 +33,11 @@ instance (TrieKey k m, m ~ TrieMap k) => TrieKey (K0 k r) (KMap m r) where
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)
+ extractM s f (KMap m) = second KMap <$> extractM s (f . K0) m
+-- extractMinM s f (KMap m) = second KMap <$> extractMinM s (f . K0) m
+-- extractMaxM s f (KMap m) = second KMap <$> extractMaxM s (f . K0) 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])
@@ -55,7 +50,7 @@ instance (TrieKey k m, m ~ TrieMap k) => TrieKeyT (K0 k) (KMap m) where
lookupT = lookupM
lookupIxT = lookupIxM
assocAtT = assocAtM
- updateAtT = updateAtM
+-- updateAtT = updateAtM
alterT = alterM
traverseWithKeyT = traverseWithKeyM
foldWithKeyT = foldWithKeyM
@@ -65,10 +60,11 @@ instance (TrieKey k m, m ~ TrieMap k) => TrieKeyT (K0 k) (KMap m) where
unionT = unionM
isectT = isectM
diffT = diffM
- extractMinT = extractMinM
- extractMaxT = extractMaxM
- alterMinT = alterMinM
- alterMaxT = alterMaxM
+ extractT = extractM
+-- extractMinT = extractMinM
+-- extractMaxT = extractMaxM
+-- alterMinT = alterMinM
+-- alterMaxT = alterMaxM
isSubmapT = isSubmapM
fromListT = fromListM
fromAscListT = fromAscListM
diff --git a/Data/TrieMap/Regular/Eq.hs b/Data/TrieMap/Regular/Eq.hs
index 83411ab..1f7640f 100644
--- a/Data/TrieMap/Regular/Eq.hs
+++ b/Data/TrieMap/Regular/Eq.hs
@@ -1,8 +1,11 @@
-{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeOperators #-}
module Data.TrieMap.Regular.Eq where
import Data.TrieMap.Regular.Base
+import Data.TrieMap.MultiRec.Base(FamT(..), KeyFam(..))
+import Data.TrieMap.MultiRec.Eq(HEq0(..))
+import Data.TrieMap.Modifiers
class EqT f where
eqT0 :: (a -> a -> Bool) -> f a -> f a -> Bool
@@ -54,6 +57,12 @@ instance (EqT f, EqT g, Eq r) => Eq ((f :*: g) r) where
instance (EqT f, EqT g, Eq r) => Eq ((f :+: g) r) where
(==) = eqT
+instance (EqT f, EqT g) => EqT (f `O` g) where
+ eqT0 (==) (O x) (O y) = eqT0 (eqT0 (==)) x y
+
+instance (EqT f, EqT g, Eq r) => Eq ((f `O` g) r) where
+ (==) = eqT
+
instance Eq a => Eq (K0 a r) where
K0 a == K0 b = a == b
@@ -61,4 +70,18 @@ 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
+ _ == _ = True
+
+instance Eq a => EqT ((,) a) where
+ eqT0 (=#=) (a, b) (c, d) = a == c && b =#= d
+
+instance Eq a => EqT (Either a) where
+ eqT0 _ (Left a) (Left b) = a == b
+ eqT0 (==) (Right a) (Right b) = a == b
+ eqT0 _ _ _ = False
+
+instance EqT Ordered where
+ eqT0 (==) (Ord x) (Ord y) = x == y
+
+instance EqT Rev where
+ eqT0 (==) (Rev x) (Rev y) = y == x \ No newline at end of file
diff --git a/Data/TrieMap/Regular/IdMap.hs b/Data/TrieMap/Regular/IdMap.hs
index 7c78574..b8a305b 100644
--- a/Data/TrieMap/Regular/IdMap.hs
+++ b/Data/TrieMap/Regular/IdMap.hs
@@ -10,7 +10,7 @@ import Control.Applicative
import Control.Arrow
import Control.Monad
-newtype IMap k a ix = IMap (TrieMap k a ix)
+newtype IMap k a = IMap (TrieMap k a)
type instance TrieMapT I0 = IMap
type instance TrieMap (I0 k) = IMap k
@@ -19,10 +19,9 @@ instance TrieKeyT I0 IMap where
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)
+ lookupIxT s (I0 k) (IMap m) = onKey I0 (lookupIxM s k m)
+ assocAtT s i (IMap m) = onKey I0 (assocAtM s i m)
+-- updateAtT s r f i (IMap m) = IMap (updateAtM s r (\ 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
@@ -32,10 +31,11 @@ instance TrieKeyT I0 IMap where
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)
+ extractT s f (IMap m) = second IMap <$> extractM s (f . I0) m
+-- extractMinT s f (IMap m) = second IMap <$> extractMinM s (f . I0) m
+-- extractMaxT s f (IMap m) = second IMap <$> extractMaxM s (f . I0) 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])
@@ -48,7 +48,7 @@ instance TrieKey k (TrieMap k) => TrieKey (I0 k) (IMap k) where
lookupM = lookupT
lookupIxM = lookupIxT
assocAtM = assocAtT
- updateAtM = updateAtT
+-- updateAtM = updateAtT
alterM = alterT
traverseWithKeyM = traverseWithKeyT
foldWithKeyM = foldWithKeyT
@@ -58,10 +58,11 @@ instance TrieKey k (TrieMap k) => TrieKey (I0 k) (IMap k) where
unionM = unionT
isectM = isectT
diffM = diffT
- extractMinM = extractMinT
- extractMaxM = extractMaxT
- alterMinM = alterMinT
- alterMaxM = alterMaxT
+ extractM = extractT
+-- extractMinM = extractMinT
+-- extractMaxM = extractMaxT
+-- alterMinM = alterMinT
+-- alterMaxM = alterMaxT
isSubmapM = isSubmapT
fromListM = fromListT
fromAscListM = fromAscListT
diff --git a/Data/TrieMap/Regular/Instances.hs b/Data/TrieMap/Regular/Instances.hs
index 43f0365..bcd61df 100644
--- a/Data/TrieMap/Regular/Instances.hs
+++ b/Data/TrieMap/Regular/Instances.hs
@@ -6,4 +6,6 @@ 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
+import Data.TrieMap.Regular.RegMap
+import Data.TrieMap.Regular.CompMap
+import Data.TrieMap.Regular.Rep \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Ord.hs b/Data/TrieMap/Regular/Ord.hs
index 677a005..82fbf7a 100644
--- a/Data/TrieMap/Regular/Ord.hs
+++ b/Data/TrieMap/Regular/Ord.hs
@@ -1,10 +1,13 @@
-{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeOperators #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts, TypeOperators #-}
module Data.TrieMap.Regular.Ord where
import Data.TrieMap.Regular.Base
import Data.TrieMap.Regular.Eq
-
+import Data.TrieMap.MultiRec.Base(FamT(..), KeyFam(..))
+import Data.TrieMap.MultiRec.Ord(HOrd0(..))
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Modifiers
import Data.Monoid
type Comparator a = a -> a -> Ordering
@@ -15,6 +18,9 @@ class EqT f => OrdT f where
compareT :: (OrdT f, Ord a) => Comparator (f a)
compareT = compareT0 compare
+-- instance HOrd0 KeyFam r => OrdT (FamT KeyFam r) where
+
+
instance Ord a => OrdT (K0 a) where
compareT0 _ (K0 a) (K0 b) = compare a b
@@ -33,6 +39,12 @@ instance (OrdT f, OrdT g) => OrdT (f :*: g) where
instance (OrdT f, OrdT g, Ord r) => Ord ((f :*: g) r) where
compare = compareT
+instance (OrdT f, OrdT g) => OrdT (f `O` g) where
+ compareT0 cmp (O x) (O y) = compareT0 (compareT0 cmp) x y
+
+instance (OrdT f, OrdT g, Ord r) => Ord ((f `O` 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
@@ -68,4 +80,20 @@ instance OrdT [] where
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
+ compare a b = compareT (from' a) (from' b)
+
+instance Ord a => OrdT ((,) a) where
+ compareT0 cmp (a, b) (c, d) = compare a c `mappend` cmp b d
+
+instance Ord a => OrdT (Either a) where
+ compareT0 cmp x y = case (x, y) of
+ (Left a, Left b) -> compare a b
+ (Right a, Right b) -> cmp a b
+ (Left{}, Right{}) -> LT
+ (Right{}, Left{}) -> GT
+
+instance OrdT Rev where
+ compareT0 cmp (Rev x) (Rev y) = cmp y x
+
+instance OrdT Ordered where
+ compareT0 cmp (Ord x) (Ord y) = cmp x y \ No newline at end of file
diff --git a/Data/TrieMap/Regular/ProdMap.hs b/Data/TrieMap/Regular/ProdMap.hs
index 513083d..5806355 100644
--- a/Data/TrieMap/Regular/ProdMap.hs
+++ b/Data/TrieMap/Regular/ProdMap.hs
@@ -1,41 +1,81 @@
-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell, PatternGuards, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, TypeOperators, UndecidableInstances #-}
module Data.TrieMap.Regular.ProdMap() where
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.Eq
import Data.TrieMap.TrieKey
import Data.TrieMap.Applicative
+import Data.TrieMap.Sized
+import Data.TrieMap.Regular.TH
import Control.Applicative
import Control.Arrow
import Data.Maybe
+import Data.Monoid
+import Data.Sequence (Seq, (|>))
+import qualified Data.Sequence as Seq
+import Data.Foldable
-newtype PMap m1 (m2 :: * -> (* -> *) -> * -> *) k (a :: * -> *) ix = PMap (m1 k (m2 k a) ix)
+newtype PMap m1 (m2 :: * -> * -> *) k a = PMap (m1 k (m2 k a))
type instance TrieMapT (f :*: g) = PMap (TrieMapT f) (TrieMapT g)
type instance TrieMap ((f :*: g) r) = TrieMapT (f :*: g) r
-type instance PF (PMap m1 m2 k a ix) = PF (m1 k (m2 k a) ix)
+lastIx :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> TrieMapT f k a -> Int
+lastIx s m = fromMaybe (sizeT s m) (getLast (aboutT (\ _ a -> return $ sizeT s m - s a) m))
-instance (Regular (m1 k (m2 k a) ix), Functor (PF (m1 k (m2 k a) ix))) => Regular (PMap m1 m2 k a ix) where
- from (PMap m) = fmap PMap (from m)
- to = PMap . to . fmap (\ (PMap m) -> m)
+--maybe (sizeT s m) fst (getLast (extractMaxT s (\ _ a -> (sizeT s m - s a, Just a)) m))
-instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :*: g) (PMap m1 m2) where
+$(deriveM [d|
+ 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)
+ lookupIxT s (a :*: b) (PMap m) = case lookupIxT (sizeT s) a m of
+ (lb, x, ub) -> let lookupX = do Asc i' a' m' <- x
+ let (lb', x', ub') = lookupIxT s b m'
+ let f = onKeyA (a' :*:) . onIndexA (i' +)
+ return (f <$> lb', f <$> x', f <$> ub')
+ in ((do Asc iL aL mL <- lb
+ fmap (onKeyA (aL :*:) . onIndexA (iL +)) (getMax s mL)) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, ub') <- First lookupX
+ ub') <|>
+ (do Asc iR aR mR <- ub
+ fmap (onKeyA (aR :*:) . onIndexA (iR +)) (getMin s mR)))
+ where getMin s m = aboutT (\ k a -> return (Asc 0 k a)) m
+ getMax s m = aboutT (\ k a -> return (Asc (sizeT s m - s a) k a)) m
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)
+ (lb, x, ub) -> let lookupX = do Asc i' a' m' <- x
+ let (lb', x', ub') = assocAtT s (i - i') m'
+ let f = onKeyA (a' :*:) . onIndexA (i' +)
+ return (f <$> lb', f <$> x', f <$> ub')
+ in ((do Asc iL aL mL <- lb
+ fmap (onKeyA (aL :*:) . onIndexA (iL +)) (getMax mL)) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, ub') <- First lookupX
+ ub') <|>
+ (do Asc iR aR mR <- ub
+ fmap (onKeyA (aR :*:) . onIndexA (iR +)) (getMin mR)))
+ where getMin m = aboutT (\ k a -> return (Asc 0 k a)) m
+ getMax m = aboutT (\ k a -> return (Asc (sizeT s m - s a) k a)) m
+-- updateAtT s r f i (PMap m) = PMap (updateAtT (sizeT s) r g i m) where
+-- g iA a m'
+-- | not r && i < iA
+-- = guardNullT (alterMinT s (f iA . (a :*:)) m')
+-- | r && i >= iA + lastIx s m'
+-- = guardNullT (alterMaxT s (f (lastIx s m') . (a :*:)) m')
+-- | otherwise
+-- = guardNullT (updateAtT s r (\ i' -> f (iA + i') . (a :*:)) (i - iA) m')
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
@@ -51,40 +91,25 @@ instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :*: g) (PMap m1 m2) where
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
+ extractT s f (PMap m) = second PMap <$> extractT (sizeT s) g m where
+ g a = second guardNullT <.> extractT s (\ b -> f (a :*: b))
+-- extractMinT s f (PMap m) = second PMap <$> extractMinT (sizeT s) g m where
+-- g a = second guardNullT . fromJust . getFirst . extractMinT s (f . (a :*:))
+-- extractMaxT s f (PMap m) = second PMap <$> extractMaxT (sizeT s) g m where
+-- g a = second guardNullT . fromJust . getLast . extractMaxT s (f . (a :*:))
+-- 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
+ fromListT s f xs = PMap (mapWithKeyT (sizeT s) (\ a -> fromListT s (\ b -> f (a :*: b)))
+ (fromListT (const 1) (const (++)) (breakFst xs)))
+ fromAscListT s f xs = PMap (fromDistAscListT (sizeT s)
+ [(a, fromAscListT s (\ b -> f (a :*: b)) ys) | (a, ys) <- breakFst xs])
+
+ breakFst :: (EqT f, Eq k) => [((f :*: g) k, a)] -> [(f k, [(g k, a)])]
+ breakFst [] = []
+ breakFst ((a :*: b, v):xs) = breakFst' a (Seq.singleton (b, v)) xs where
+ breakFst' a vs ((a' :*: b', v):xs)
+ | a `eqT` a' = breakFst' a (vs |> (b', v)) xs
+ | otherwise = (a, toList vs):breakFst' a' (Seq.singleton (b', v)) xs
+ breakFst' a vs [] = [(a, toList vs)]
+ |]) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/RadixTrie.hs b/Data/TrieMap/Regular/RadixTrie.hs
index 4db446a..b211da9 100644
--- a/Data/TrieMap/Regular/RadixTrie.hs
+++ b/Data/TrieMap/Regular/RadixTrie.hs
@@ -1,14 +1,18 @@
-{-# LANGUAGE Rank2Types, PatternGuards, FlexibleContexts, TypeFamilies, UndecidableInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell, Rank2Types, PatternGuards, FlexibleContexts, TypeFamilies, UndecidableInstances, MultiParamTypeClasses #-}
-module Data.TrieMap.Regular.RadixTrie where
+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.Regular.TH
import Data.TrieMap.Sized
import Data.TrieMap.TrieKey
import Data.TrieMap.Applicative
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.TH
+import qualified Data.TrieMap.MultiRec.Base as MR
import Control.Arrow
import Control.Applicative
@@ -21,28 +25,27 @@ 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)
+data Edge f (m :: * -> * -> *) k a = Edge {-# UNPACK #-} !Int [f k] (Maybe (a)) (m k (Edge f m k a))
+type Edge' f k a = Edge f (TrieMapT f) k a
+type MEdge f k m a = Maybe (Edge f m k a)
+type MEdge' f k a = Maybe (Edge' f k a)
--- type instance PF (Edge f m k a ix) = (K0 (L f k) :*: K0 (Maybe (a ix)) :*: L (K0 k :*: I0) :*: K0 Int)
--- type instance (RadixTrie f k a ix) = U0 :+: PF (Edge f m k a ix)
+-- type instance PF (Edge f m k a) = (K0 (L f k) :*: K0 (Maybe (a)) :*: L (K0 k :*: I0) :*: K0 Int)
+-- type instance (RadixTrie f k a) = U0 :+: PF (Edge f m k a)
--- instance (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Regular (Edge f m k a ix) where
+-- instance (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Regular (Edge f m k a) where
-- from (Edge n ks v ts) = K0 (List ks) :*: K0 v :*:
-newtype RadixTrie f k a ix = Radix (MEdge' f k a ix)
+newtype RadixTrie f k a = Radix (MEdge' f k a)
-- 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 :: (TrieKeyT f m, m ~ TrieMapT f, TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a) -> m k (Edge f m k a) -> Edge f m k a
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
@@ -50,10 +53,9 @@ instance (OrdT f, TrieKeyT f m, m ~ TrieMapT f) => TrieKeyT (L f) (RadixTrie f)
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)
+ lookupIxT s (List ks) (Radix m) = maybe (mzero, mzero, mzero) (onKey List . lookupIxE s 0 ks) m
+ assocAtT s i (Radix m) = maybe (mzero, mzero, mzero) (onKey List . assocAtE s 0 i) m
+-- updateAtT s r f i (Radix m) = Radix (m >>= updateAtE s r (\ 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
@@ -63,10 +65,11 @@ instance (OrdT f, TrieKeyT f m, m ~ TrieMapT f) => TrieKeyT (L f) (RadixTrie f)
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))
+ extractT s f (Radix m) = maybe empty (second Radix <.> extractE s (f . List)) m
+-- -- extractMinT s f (Radix m) = First m >>= fmap (second Radix) . extractMinE s (f . List)
+-- extractMaxT s f (Radix m) = Last m >>= fmap (second Radix) . extractMaxE s (f . List)
+-- 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])
@@ -78,7 +81,7 @@ instance (OrdT f, TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieKey (L
lookupM = lookupT
lookupIxM = lookupIxT
assocAtM = assocAtT
- updateAtM = updateAtT
+-- updateAtM = updateAtT
alterM = alterT
traverseWithKeyM = traverseWithKeyT
foldWithKeyM = foldWithKeyT
@@ -88,10 +91,11 @@ instance (OrdT f, TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieKey (L
unionM = unionT
isectM = isectT
diffM = diffT
- extractMinM = extractMinT
- extractMaxM = extractMaxT
- alterMinM = alterMinT
- alterMaxM = alterMaxT
+ extractM = extractT
+-- extractMinM = extractMinT
+-- extractMaxM = extractMaxT
+-- alterMinM = alterMinT
+-- alterMaxM = alterMaxT
isSubmapM = isSubmapT
fromListM = fromListT
fromAscListM = fromAscListT
@@ -117,7 +121,7 @@ instance (OrdT f, TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => TrieKey (L
-- 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Edge' f k a -> MEdge' f k a
compact e@(Edge s ks Nothing ts) = case assocsT ts of
[] -> Nothing
[~(k, e'@(Edge s' ls v ts'))]
@@ -125,16 +129,16 @@ compact e@(Edge s ks Nothing ts) = case assocsT ts of
_ -> Just e
compact e = Just e
-cons :: f k -> Edge' f k a ix -> Edge' f k a ix
+cons :: f k -> Edge' f k a -> Edge' f k a
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
+cat :: [f k] -> Edge' f k a -> Edge' f k a
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> [f k] -> Maybe (a) -> MEdge' f k a
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => [f k] -> Edge' f k a -> Maybe (a)
lookupE ks (Edge _ ls v ts) = match ks ls where
match (k:ks) (l:ls)
| k `eqT` l = match ks ls
@@ -144,7 +148,7 @@ lookupE ks (Edge _ ls v ts) = match ks ls where
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
+ Sized a -> (Maybe (a) -> Maybe (a)) -> [f k] -> Edge' f k a -> MEdge' f k a
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)
@@ -162,23 +166,23 @@ alterE s f ks0 e@(Edge sz ls0 v0 ts0) = match 0 ks0 ls0 where
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)
+ Sized b -> ([f k] -> a -> t (b)) -> Edge' f k a -> t (Edge' f k b)
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> a -> b -> b) -> Edge' f k a -> 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => ([f k] -> b -> a -> b) -> Edge' f k a -> 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)
+ EitherMap (EitherMap [f k] (a) (b) (c)) (Edge' f k a) (Edge' f k b) (Edge' f k c)
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> SplitMap (a) x -> [f k] -> SplitMap (Edge' f k a) 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)
@@ -193,7 +197,7 @@ splitLookupE s f ks e@(Edge _ ls v ts) = match ks ls where
(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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> UnionFunc (UnionFunc [f k] (a)) (Edge' f k a)
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)
@@ -209,34 +213,37 @@ unionE s f (Edge szK ks0 vK tsK) (Edge szL ls0 vL tsL) = match 0 ks0 ls0 where
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))
+extractE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) => Sized a -> ([f k] -> a -> t (x, Maybe a)) ->
+ Edge' f k a -> t (x, MEdge' f k a)
+extractE s f (Edge _ ks v ts) = (maybe empty (second (\ v' -> compact (edge s ks v' ts)) <.> f ks) v) <|>
+ (second (compact . edge s ks Nothing) <$> extractT edgeSize g ts)
+ where g l = extractE s (\ ls -> f (ks ++ l:ls))
+
+aboutE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k), Alternative t) => ([f k] -> a -> t x) ->
+ Edge' f k a -> t x
+aboutE f = fst <.> extractE (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a))
+
+-- extractMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> ([f k] -> a -> (x, Maybe a)) ->
+-- Edge' f k a -> Last (x, MEdge' f k a)
+-- extractMaxE s f (Edge _ ks v ts) = (do
+-- v <- Last v
+-- let (x, v') = f ks v
+-- return (x, compact (edge s ks v' ts))) <|>
+-- (second (compact . edge s ks v) <.> extractMaxT edgeSize g ts)
+-- where g x = fromJust . getLast . extractMaxE s (\ xs -> f (ks ++ x:xs))
+
+-- alterMinE, alterMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a ->
+-- ([f k] -> a -> Maybe (a)) -> Edge' f k a -> MEdge' f k a
+-- 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)
+ IsectFunc (IsectFunc [f k] (a) (b) (c)) (Edge' f k a) (Edge' f k b) (Edge' f k c)
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
@@ -248,7 +255,7 @@ isectE s f (Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls 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)
+ DiffFunc (DiffFunc [f k] (a) (b)) (Edge' f k a) (Edge' f k b)
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
@@ -260,7 +267,7 @@ diffE s f e@(Edge szK ks vK tsK) (Edge szL ls vL tsL) = match ks ls where
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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => LEq (a) (b) -> LEq (Edge' f k a) (Edge' f k b)
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
@@ -281,7 +288,7 @@ filterer (==) f = filterer' where
| 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 :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) => Sized a -> ([f k] -> a -> a -> a) -> [([f k], a)] -> MEdge' f k a
fromListE _ _ [] = Nothing
fromListE s f xs = case filterer eqT (f []) xs of
(Nothing, [(k, xs)]) -> cons k <$> fromListE s (f . (k:)) xs
@@ -289,42 +296,101 @@ fromListE s f xs = case filterer eqT (f []) xs of
(fromListT (const 1) (\ _ (K0 xs) (K0 ys) -> K0 (ys ++ xs)) [(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
+ Sized a -> ([f k] -> a -> a -> a) -> [([f k], a)] -> MEdge' f k a
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)
+ Sized a -> Int -> [f k] -> Edge' f k a -> IndexPos [f k] a
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
+lookupIxE s i ks e@(Edge _ ls v ts) = match ks ls where
+ match (k:ks) (l:ls) = case compareT k l of
+ LT -> (mzero, mzero, getMin (Asc i) e)
+ EQ -> match ks ls
+ GT -> (getMax (Asc i) e, mzero, mzero)
+ match (k:ks) [] = case lookupIxT edgeSize k ts of
+ (lb, x, ub) -> let lookupX = do Asc iK k' e' <- x
+ let (lb', x', ub') = lookupIxE s (i + iK) ks e'
+ let f = onKeyA ((ls ++) . (k' :))
+ return (f <$> lb', f <$> x', f <$> ub')
+ in ((do Asc iL kL eL <- lb
+ getMax (\ ksL -> Asc (i + iL) (ls ++ kL:ksL)) eL) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, ub') <- First lookupX
+ ub') <|>
+ (do Asc iR kR eR <- ub
+ getMin (\ ksR -> Asc (i + iR) (ls ++ kR:ksR)) eR))
+ match [] [] = (mzero, Asc i ls <$> v, aboutT
+ (\ x -> aboutE (\ xs v' -> return (Asc (i + maybe 0 s v) (ls ++ x:xs) v'))) ts)
+ match [] _ = (mzero, mzero, getMin (Asc i) e)
+ getMin f = aboutE (return .: f)
+ getMax f = aboutE (return .: f)
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
+ Sized a -> Int -> Int -> Edge' f k a -> IndexPos [f k] a
+assocAtE s i0 i (Edge _ ks Nothing ts) = case assocAtT edgeSize i ts of
+ (lb, x, ub) -> let lookupX = do Asc i' l e' <- x
+ return (onKey ((ks ++) . (l:)) (assocAtE s (i0 + i') (i - i') e'))
+ in ((do Asc iL lL eL <- lb
+ getMax (\ ls -> Asc (i0 + iL) (ks ++ lL:ls)) eL) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, ub') <- First lookupX
+ ub') <|>
+ (do Asc iR lR eR <- ub
+ getMin (\ ls -> Asc (i0 + iR) (ks ++ lR:ls)) eR))
+ where getMin f e = aboutE (return .: f) e
+ getMax f e = aboutE (return .: f) e
+assocAtE s i0 i (Edge _ ks (Just v) ts)
+ | i < sv = (mzero, return (Asc i ks v), aboutT (\ l -> aboutE (\ ls v' -> return (Asc (i0 + sv) (ks ++ l:ls) v'))) ts)
+ | (lb, x, ub) <- assocAtT edgeSize (i - sv) ts
+ = let lookupX = do Asc i' l e' <- x
+ return (onKey ((ks ++) . (l:)) (assocAtE s (i0 + i' + sv) (i - sv - i') e'))
+ in ((do Asc iL lL eL <- lb
+ getMax (\ ls -> Asc (i0 + iL + sv) (ks ++ lL:ls)) eL) <|>
+ (do (lb', _, _) <- Last lookupX
+ lb'),
+ (do (_, x', _) <- lookupX
+ x'),
+ (do (_, _, ub') <- First lookupX
+ ub') <|>
+ (do Asc iR lR eR <- ub
+ getMin (\ ls -> Asc (i0 + iR + sv) (ks ++ lR:ls)) eR))
+ where getMin f = aboutE (return .: f)
+ getMax f = aboutE (return .: f)
+ sv = s v
+
+-- alterMinE, alterMaxE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+-- Sized a -> ([f k] -> a -> Maybe a) -> Edge' f k a -> MEdge' f k a
+-- alterMinE s f e = maybe (Just e) snd $ getFirst (extractMinE s (\ k a -> ((), f k a)) e)
+-- alterMaxE s f e = maybe (Just e) snd $ getLast (extractMaxE s (\ k a -> ((), f k a)) e)
+
+-- updateAtE :: (TrieKeyT f (TrieMapT f), TrieKey k (TrieMap k)) =>
+-- Sized a -> Round -> (Int -> [f k] -> a -> Maybe (a)) -> Int -> Edge' f k a -> MEdge' f k a
+-- updateAtE s r f i (Edge sz ks Nothing ts) = compact (edge s ks Nothing (updateAtT edgeSize r g i ts)) where
+-- g iT l e
+-- | not r, i < iT
+-- = alterMinE s (f iT . (ks++) . (l:)) e
+-- | r, i >= iT + edgeSize e
+-- = alterMaxE s (\ ls a -> f (edgeSize e + iT - s a) (ks ++ l:ls) a) e
+-- | otherwise
+-- = updateAtE s r (\ i' ls -> f (i' + iT) (ks ++ l:ls)) (i - iT) e
+-- updateAtE s r 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 r g i1 ts))
+-- where sv = s v
+-- i1 = i - sv
+-- g iT l e
+-- | not r, i1 < iT
+-- = alterMinE s (f (iT + sv) . (ks ++) . (l:)) e
+-- | r, i1 >= iT + edgeSize e
+-- = alterMaxE s (\ ls a -> f (iT + sv + edgeSize e + iT - s a) (ks ++ l:ls) a) e
+-- | otherwise
+-- = updateAtE s r (\ i' ls -> f (sv + iT + i') (ks ++ l:ls)) (i - sv - iT) e \ No newline at end of file
diff --git a/Data/TrieMap/Regular/RegMap.hs b/Data/TrieMap/Regular/RegMap.hs
index 589432f..5933b9c 100644
--- a/Data/TrieMap/Regular/RegMap.hs
+++ b/Data/TrieMap/Regular/RegMap.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, MultiParamTypeClasses #-}
-module Data.TrieMap.Regular.RegMap where
+module Data.TrieMap.Regular.RegMap() where
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
@@ -10,17 +10,16 @@ import Control.Applicative
import Control.Arrow
import Control.Monad
-newtype RegMap k m (a :: * -> *) ix = RegMap (m (Reg k) a ix)
+newtype RegMap k m a = RegMap (m (Reg k) a)
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)
+ lookupIxM s k (RegMap m) = onKey to' (lookupIxT s (from' k) m)
+ assocAtM s i (RegMap m) = onKey to' (assocAtT s i m)
+-- updateAtM s r f i (RegMap m) = RegMap (updateAtT s r (\ 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
@@ -30,10 +29,11 @@ instance (Regular k, Functor (PF k), TrieKeyT (PF k) m, m ~ TrieMapT (PF k)) =>
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)
+ extractM s f (RegMap m) = second RegMap <$> extractT s (f . to') m
+-- extractMinM s f (RegMap m) = second RegMap <$> extractMinT s (f . to') m
+-- extractMaxM s f (RegMap m) = second RegMap <$> extractMaxT s (f . to') 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])
diff --git a/Data/TrieMap/Regular/Rep.hs b/Data/TrieMap/Regular/Rep.hs
new file mode 100644
index 0000000..96145e8
--- /dev/null
+++ b/Data/TrieMap/Regular/Rep.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE UndecidableInstances, TypeOperators, TypeFamilies, TemplateHaskell #-}
+
+module Data.TrieMap.Regular.Rep where
+
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.TH
+import Data.TrieMap.Regular.Base
+
+type instance RepT (K0 a) = K0 (Rep a)
+type instance RepT I0 = I0
+type instance RepT U0 = U0
+type instance RepT (L f) = L (RepT f)
+type instance RepT (f :*: g) = RepT f :*: RepT g
+type instance RepT (f :+: g) = RepT f :+: RepT g
+type instance RepT (f `O` g) = RepT f `O` RepT g
+
+type instance Rep (K0 a b) = RepT (K0 a) b
+type instance Rep (I0 a) = I0 (Rep a)
+type instance Rep (U0 a) = U0 a
+type instance Rep (L f a) = L (RepT f) (Rep a)
+type instance Rep ((f :*: g) a) = RepT (f :*: g) (Rep a)
+type instance Rep ((f :+: g) a) = RepT (f :+: g) (Rep a)
+type instance Rep ((f `O` g) a) = RepT (f `O` g) (Rep a)
+type instance Rep (Fix f) = Fix (RepT f)
+
+instance Repr a => ReprT (K0 a) where
+ toRepTMap _ (K0 a) = K0 (toRep a)
+ fromRepTMap _ (K0 a) = K0 (fromRep a)
+
+instance Repr a => Repr (K0 a b) where
+ toRep = toRepT
+ fromRep = fromRepT
+
+$(genRepT [d|
+ instance ReprT I0 where
+ toRepTMap = fmap
+ fromRepTMap = fmap |])
+
+instance ReprT U0 where
+ toRepTMap _ _ = U0
+ fromRepTMap _ _ = U0
+
+instance Repr (U0 a) where
+ toRep _ = U0
+ fromRep _ = U0
+
+$(genRepT [d|
+ instance ReprT f => ReprT (L f) where
+ toRepTMap f (List xs) = List (map (toRepTMap f) xs)
+ fromRepTMap f (List xs) = List (map (fromRepTMap f) xs) |])
+
+$(genRepT [d|
+ instance (ReprT f, ReprT g) => ReprT (f :*: g) where
+ toRepTMap f (x :*: y) = toRepTMap f x :*: toRepTMap f y
+ fromRepTMap f (x :*: y) = fromRepTMap f x :*: fromRepTMap f y |])
+
+$(genRepT [d|
+ instance (ReprT f, ReprT g) => ReprT (f :+: g) where
+ toRepTMap f (L a) = L (toRepTMap f a)
+ toRepTMap f (R b) = R (toRepTMap f b)
+ fromRepTMap f (L a) = L (fromRepTMap f a)
+ fromRepTMap f (R b) = R (fromRepTMap f b) |])
+
+$(genRepT [d|
+ instance (ReprT f, ReprT g) => ReprT (f `O` g) where
+ toRepTMap f (O x) = O (toRepTMap (toRepTMap f) x)
+ fromRepTMap f (O x) = O (fromRepTMap (fromRepTMap f) x) |])
+
+instance ReprT f => Repr (Fix f) where
+ toRep (In x) = In (toRepTMap toRep x)
+ fromRep (In x) = In (fromRepTMap fromRep x) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/Sized.hs b/Data/TrieMap/Regular/Sized.hs
index 443755c..53ac840 100644
--- a/Data/TrieMap/Regular/Sized.hs
+++ b/Data/TrieMap/Regular/Sized.hs
@@ -5,5 +5,5 @@ module Data.TrieMap.Regular.Sized where
import Data.TrieMap.Regular.Base
import Data.TrieMap.Sized
-sizeK0 :: Sized (K0 a)
+sizeK0 :: Sized (K0 a b)
sizeK0 _ = 1 \ No newline at end of file
diff --git a/Data/TrieMap/Regular/TH.hs b/Data/TrieMap/Regular/TH.hs
new file mode 100644
index 0000000..85e5d55
--- /dev/null
+++ b/Data/TrieMap/Regular/TH.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE UndecidableInstances, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, QuasiQuotes #-}
+
+module Data.TrieMap.Regular.TH where
+
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.TrieKey
+import Language.Haskell.TH
+
+deriveM :: Q [Dec] -> Q [Dec]
+deriveM decs = do
+ iT@(InstanceD cxt (triekeyt `AppT` f `AppT` m) _:_) <- decs
+ (InstanceD _ _ myDecs:_) <- [d|
+ instance (TrieKeyT f m, Ord (f k), TrieKey k mm) => TrieKey (f k) (m 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
+ extractM = extractT
+-- extractMinM = extractMinT
+-- extractMaxM = extractMaxT
+-- alterMinM = alterMinT
+-- alterMaxM = alterMaxT
+ isSubmapM = isSubmapT
+ fromListM = fromListT
+ fromAscListM = fromAscListT
+ fromDistAscListM = fromDistAscListT |]
+ k <- mkVar "k"
+ let triekey = ConT ''TrieKey
+ let triemap = ConT ''TrieMap
+ let ordT = ConT ''Ord
+ return (InstanceD (triekey `AppT` k `AppT` (triemap `AppT` k):ordT `AppT` (f `AppT` k):cxt)
+ (triekey `AppT` (f `AppT` k) `AppT` (m `AppT` k)) myDecs:iT)
+
+mkVar :: String -> TypeQ
+mkVar x = varT =<< newName x \ No newline at end of file
diff --git a/Data/TrieMap/Regular/UnionMap.hs b/Data/TrieMap/Regular/UnionMap.hs
index 631ede7..f1c3d21 100644
--- a/Data/TrieMap/Regular/UnionMap.hs
+++ b/Data/TrieMap/Regular/UnionMap.hs
@@ -1,24 +1,38 @@
-{-# LANGUAGE TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE PatternGuards, FlexibleInstances, TemplateHaskell, TypeOperators, TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
module Data.TrieMap.Regular.UnionMap() where
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
+import Data.TrieMap.Regular.TH
import Data.TrieMap.TrieKey
+import Data.TrieMap.Applicative
+-- import Data.TrieMap.Rep
+-- import Data.TrieMap.Rep.TH
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Either
+import Data.Monoid
-- import Generics.MultiRec.Base
-data UnionMap m1 m2 k (a :: * -> *) ix = m1 k a ix :&: m2 k a ix
+data UnionMap m1 m2 k a = m1 k a :&: m2 k a
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
+-- type instance RepT (UnionMap m1 m2 k) = RepT (m1 k) :*: RepT (m2 k)
+-- type instance Rep (UnionMap f g k a) = RepT (UnionMap f g k) (Rep a)
+--
+-- -- $(genRepT [d|
+-- instance (ReprT (m1 k), ReprT (m2 k)) => ReprT (UnionMap m1 m2 k) where
+-- toRepT (m1 :&: m2) = toRepT m1 :*: toRepT m2
+-- fromRepT (m1 :*: m2) = fromRepT m1 :&: fromRepT m2 |])
+
+$(deriveM [d|
+ 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
@@ -26,18 +40,23 @@ instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :+: g) (UnionMap m1 m2) w
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
+ L k | (lb, x, ub) <- onKey L (lookupIxT s k m1)
+ -> (lb, x, ub <|> fmap (onKeyA R . onIndexA (sizeT s m1 +)) (getMin m2))
+ R k | (lb, x, ub) <- onIndex (sizeT s m1 +) (onKey R (lookupIxT s k m2))
+ -> (fmap (onKeyA L) (getMax m1) <|> lb, x, ub)
+ where getMin = aboutT (return .: Asc 0)
+ getMax m = aboutT (\ k a -> return (Asc (sizeT s m - s a) k a)) m
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
+ | i < s1 = onKey L (assocAtT s i m1)
+ | otherwise = onKey R (onIndex (s1 +) (assocAtT s (i - s1) m2))
where s1 = sizeT s m1
+{- updateAtT s r f i (m1 :&: m2)
+ | not r, i >= maxIx m1
+ = m1 :&: updateAtT s r (\ i' -> f (i' + s1) . R) (i - s1) m2
+ | i < s1 = updateAtT s r (\ i' -> f i' . L) i m1 :&: m2
+ | otherwise = m1 :&: updateAtT s r (\ i' -> f (i' + s1) . R) (i - s1) m2
+ where s1 = sizeT s m1
+ maxIx m = maybe (sizeT s m) fst $ getLast (extractMaxT s (\ _ v -> (sizeT s m - s v, Just v)) m)-}
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
@@ -54,56 +73,22 @@ instance (TrieKeyT f m1, TrieKeyT g m2) => TrieKeyT (f :+: g) (UnionMap m1 m2) w
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
+ extractT s f (m1 :&: m2) = second (:&: m2) <$> extractT s (f . L) m1 <|>
+ second (m1 :&:) <$> extractT s (f . R) m2
+-- extractMinT s f (m1 :&: m2) = second (:&: m2) <$> extractMinT s (f . L) m1 <|>
+-- second (m1 :&:) <$> extractMinT s (f . R) m2
+-- extractMaxT s f (m1 :&: m2) = second (:&: m2) <$> extractMaxT s (f . L) m1 <|>
+-- second (m1 :&:) <$> extractMaxT s (f . R) 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
+ (ys, zs) -> fromDistAscListT s ys :&: fromDistAscListT s zs |]) \ No newline at end of file
diff --git a/Data/TrieMap/Regular/UnitMap.hs b/Data/TrieMap/Regular/UnitMap.hs
index e5a62eb..38c0f95 100644
--- a/Data/TrieMap/Regular/UnitMap.hs
+++ b/Data/TrieMap/Regular/UnitMap.hs
@@ -1,13 +1,18 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances, TemplateHaskell, MultiParamTypeClasses, TypeFamilies #-}
module Data.TrieMap.Regular.UnitMap() where
import Data.TrieMap.Regular.Class
import Data.TrieMap.Regular.Base
import Data.TrieMap.TrieKey
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.Instances
+import Data.TrieMap.Rep.TH
+import Data.TrieMap.Applicative
import Control.Applicative
import Control.Arrow
+import Control.Monad
import Data.Foldable
import Data.Maybe
@@ -16,18 +21,34 @@ import Data.Traversable
import Prelude hiding (foldr, foldl)
-newtype M k a ix = M (Maybe (a ix))
+newtype M k a = M (Maybe a)
type instance TrieMapT U0 = M
type instance TrieMap (U0 r) = M r
+type instance RepT (M k) = RepT Maybe
+type instance Rep (M k a) = RepT Maybe (Rep a)
+
+$(genRepT [d|
+ instance ReprT (M k) where
+ toRepT (M a) = toRepT a
+ fromRepT = M . fromRepT |])
+
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)
+ lookupIxM s _ (M a) = (mzero, Asc 0 U0 <$> a, mzero)
+ assocAtM s i (M a)
+ | i < 0 = (mzero, mzero, Asc 0 U0 <$> First a)
+ | i > maybe 0 s a
+ = (Asc 0 U0 <$> Last a, mzero, mzero)
+ | otherwise
+ = (mzero, Asc 0 U0 <$> a, mzero)
+-- updateAtM s r f i (M v) = case v of
+-- Just a | not r && i <= 0 -> M (v >>= f 0 U0)
+-- | r && i >= 0 -> M (v >>= f 0 U0)
+-- _ -> M v
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
@@ -38,12 +59,11 @@ instance TrieKey (U0 r) (M r) where
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
+ extractM _ f (M a) = maybe empty (second M <.> f U0) a
+-- extractMinM _ f (M a) = fmap (second M . f U0) (First a)
+-- extractMaxM _ f (M a) = fmap (second M . f U0) (Last a)
+-- 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
@@ -55,7 +75,7 @@ instance TrieKeyT U0 M where
lookupT = lookupM
lookupIxT = lookupIxM
assocAtT = assocAtM
- updateAtT = updateAtM
+-- updateAtT = updateAtM
alterT = alterM
traverseWithKeyT = traverseWithKeyM
foldWithKeyT = foldWithKeyM
@@ -65,10 +85,11 @@ instance TrieKeyT U0 M where
unionT = unionM
isectT = isectM
diffT = diffM
- extractMinT = extractMinM
- extractMaxT = extractMaxM
- alterMinT = alterMinM
- alterMaxT = alterMaxM
+ extractT = extractM
+-- extractMinT = extractMinM
+-- extractMaxT = extractMaxM
+-- alterMinT = alterMinM
+-- alterMaxT = alterMaxM
isSubmapT = isSubmapM
fromListT = fromListM
fromAscListT = fromAscListM
diff --git a/Data/TrieMap/Rep.hs b/Data/TrieMap/Rep.hs
new file mode 100644
index 0000000..0116ad4
--- /dev/null
+++ b/Data/TrieMap/Rep.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE UndecidableInstances, FlexibleContexts, TypeFamilies, KindSignatures #-}
+
+module Data.TrieMap.Rep where
+
+type family Rep a
+type family RepT (f :: * -> *) :: * -> *
+
+class Repr a where
+ toRep :: a -> Rep a
+ fromRep :: Rep a -> a
+
+class Functor (RepT f) => ReprT f where
+ toRepT :: f a -> RepT f a
+ fromRepT :: RepT f a -> f a
+ toRepTMap :: (a -> b) -> f a -> RepT f b
+ fromRepTMap :: (b -> a) -> RepT f b -> f a
+
+ toRepT = toRepTMap id
+ fromRepT = fromRepTMap id
+ toRepTMap f = fmap f . toRepT
+ fromRepTMap f = fromRepT . fmap f
+
+{-# RULES
+ "toRep/fromRep" forall x . toRep (fromRep x) = x;
+-- "fromRep/toRep" forall x . fromRep (toRep x) = x;
+ #-} \ No newline at end of file
diff --git a/Data/TrieMap/Rep/Instances.hs b/Data/TrieMap/Rep/Instances.hs
new file mode 100644
index 0000000..7d7b441
--- /dev/null
+++ b/Data/TrieMap/Rep/Instances.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, TypeOperators, TemplateHaskell #-}
+
+module Data.TrieMap.Rep.Instances() where
+
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.TH
+import Data.TrieMap.Regular.Base
+import Data.TrieMap.OrdMap
+import Data.TrieMap.Modifiers
+-- import Language.Haskell.TH
+
+import Control.Arrow
+
+import Data.Char
+import Data.Int
+import Data.Word
+import Data.Foldable (toList)
+import Data.Bits
+import Data.Array.IArray
+import Data.ByteString hiding (map)
+import qualified Data.ByteString as BS
+
+import Data.Sequence (Seq, (|>))
+import qualified Data.Sequence as Seq
+import qualified Data.Foldable as Fold
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Prelude hiding (concat, take, length)
+
+type Pair a = (,) a
+type Sum a = Either a
+
+type instance RepT Maybe = U0 :+: I0
+type instance Rep (Maybe a) = RepT Maybe (Rep a)
+
+$(genRepT [d|
+ instance ReprT Maybe where
+ toRepTMap f = maybe (L U0) (R . I0 . f)
+ fromRepTMap _ L{} = Nothing
+ fromRepTMap f (R (I0 a)) = Just (f a) |])
+
+type instance RepT [] = L I0
+type instance Rep [a] = L I0 (Rep a)
+
+$(genRepT [d|
+ instance ReprT [] where
+ toRepTMap f = List . map (I0 . f)
+ fromRepTMap f (List xs) = map (f . unI0) xs |])
+
+type instance RepT ((,) a) = Pair (Rep a)
+type instance Rep (a, b) = RepT ((,) a) (Rep b)
+
+$(genRepT [d|
+ instance Repr a => ReprT ((,) a) where
+ toRepTMap f = toRep *** f
+ fromRepTMap f = fromRep *** f |])
+
+-- instance (ReprT ((,) a), Repr b) => Repr ((,) a b) where
+
+-- instance (Repr a, Repr b) => Repr (a, b) where
+-- toRep = fmap toRep . toRepT
+-- fromRep = fromRepT . fmap fromRep
+
+type instance RepT ((,,) a b) = K0 (Rep a) :*: K0 (Rep b) :*: I0
+type instance Rep (a, b, c) = RepT ((,,) a b) (Rep c)
+
+$(genRepT [d|
+ instance (Repr a, Repr b) => ReprT ((,,) a b) where
+ toRepTMap f (a, b, c) = K0 (toRep a) :*: K0 (toRep b) :*: I0 (f c)
+ fromRepTMap f (K0 a :*: K0 b :*: I0 c) = (fromRep a, fromRep b, f c) |])
+
+type instance RepT ((,,,) a b c) = K0 (Rep a) :*: K0 (Rep b) :*: K0 (Rep c) :*: I0
+type instance Rep (a, b, c, d) = RepT ((,,,) a b c) (Rep d)
+
+$(genRepT [d|
+ instance (Repr a, Repr b, Repr c) => ReprT ((,,,) a b c) where
+ toRepTMap f (a, b, c, d) = K0 (toRep a) :*: K0 (toRep b) :*: K0 (toRep c) :*: I0 (f d)
+ fromRepTMap f (K0 a :*: K0 b :*: K0 c :*: I0 d) = (fromRep a, fromRep b, fromRep c, f d) |])
+
+type instance RepT (Either a) = Sum (Rep a)
+type instance Rep (Either a b) = RepT (Either a) (Rep b)
+
+$(genRepT [d|
+ instance Repr a => ReprT (Either a) where
+ toRepTMap f = either (Left . toRep) (Right . f)
+ fromRepTMap f = either (Left . fromRep) (Right . f) |])
+
+type instance Rep Bool = (U0 :+: U0) (U0 ())
+instance Repr Bool where
+ toRep False = L U0
+ toRep True = R U0
+ fromRep L{} = False
+ fromRep R{} = True
+
+type instance Rep Char = Word32
+instance Repr Char where
+ toRep = fromIntegral . ord
+ fromRep = chr . fromIntegral
+
+type instance Rep () = U0 ()
+instance Repr () where
+ toRep _ = U0
+ fromRep _ = ()
+
+type instance Rep Double = Ordered Double
+instance Repr Double where
+ toRep = Ord
+ fromRep = unOrd
+
+type instance Rep Int = Rep Int32
+instance Repr Int where
+ toRep = toSigned
+ fromRep = fromSigned
+
+type instance Rep Word8 = Word32
+instance Repr Word8 where
+ toRep = fromIntegral
+ fromRep = fromIntegral
+
+type instance Rep Word16 = Word32
+instance Repr Word16 where
+ toRep = fromIntegral
+ fromRep = fromIntegral
+
+type instance Rep Word = Word32
+instance Repr Word where
+ toRep = fromIntegral
+ fromRep = fromIntegral
+
+type instance Rep Int8 = Rep Int32
+
+instance Repr Int8 where
+ toRep = toSigned
+ fromRep = fromSigned
+
+type instance Rep Int16 = Rep Int32
+instance Repr Int16 where
+ toRep = toSigned
+ fromRep = fromSigned
+
+type instance Rep Int32 = Sum (Rev Word32) Word32
+instance Repr Int32 where
+ toRep = toSigned
+ fromRep = fromSigned
+
+type instance Rep Word64 = Pair Word32 Word32
+instance Repr Word64 where
+ toRep x = (fromIntegral (x `shiftR` 32), fromIntegral x)
+ fromRep (x, y) = fromIntegral x `shiftL` 32 .|. fromIntegral y
+
+type instance Rep Int64 = Sum (Rev (Rep Word64)) (Rep Word64)
+instance Repr Int64 where
+ toRep x | x < 0 = Left (Rev (toRep' (fromIntegral (-x))))
+ | otherwise = Right (toRep' (fromIntegral x))
+ where toRep' = toRep :: Word64 -> Rep Word64
+ fromRep (Left (Rev x)) = - fromIntegral ((fromRep :: Rep Word64 -> Word64) x)
+ fromRep (Right x) = fromIntegral ((fromRep :: Rep Word64 -> Word64) x)
+
+{-# INLINE toSigned #-}
+toSigned :: Integral a => a -> Sum (Rev Word32) Word32
+toSigned x
+ | x < 0 = Left (Rev (fromIntegral (-x)))
+ | otherwise = Right (fromIntegral x)
+
+{-# INLINE fromSigned #-}
+fromSigned :: Integral a => Sum (Rev Word32) Word32 -> a
+fromSigned = either (\ (Rev x) -> - fromIntegral x) fromIntegral
+
+type instance Rep Word32 = Word32
+instance Repr Word32 where
+ toRep = id
+ fromRep = id
+
+type instance Rep ByteString = (L I0 :*: I0) Word32
+instance Repr ByteString where
+ toRep xs = List (toList64 xs) :*: I0 (fromIntegral (length xs))
+ fromRep (List xs :*: I0 n) = case xs of
+ [] -> BS.empty
+ (I0 x:xs) -> fst (unfoldrN (fromIntegral n) toBlock (W (Words 3 x) xs))
+
+data Words = Words {ix :: {-# UNPACK #-} !Int, word32 :: {-# UNPACK #-} !Word32}
+data Words' = W {-# UNPACK #-} !Words [I0 Word32]
+
+toList64 :: ByteString -> [I0 Word32]
+toList64 xs = case BS.foldl c (Words 4 0, Seq.empty) xs of
+ (Words i w32, ys) -> toList ys ++ [I0 w32]
+ where fS :: Word8 -> Int -> Word32
+ fS w x = fromIntegral w `shiftL` x
+ (Words 0 w, xs) `c` w8
+ = (Words 3 (w .|. sL w8 24), xs |> I0 w)
+ (Words (i+1) w, xs) `c` w8
+ = (Words i (w .|. sL w8 (8 * i)), xs)
+ sL :: Word8 -> Int -> Word32
+ w `sL` x = fromIntegral w `shiftL` x
+
+toBlock :: Words' -> Maybe (Word8, Words')
+toBlock (W (Words i0@(i+1) w) xs) = Just (extract w (8 * i0), (W (Words i w) xs))
+ where extract :: Word32 -> Int -> Word8
+ extract w x = fromIntegral (w `shiftR` x)
+toBlock (W (Words 0 w) (I0 x:xs)) = Just (fromIntegral w, (W (Words 3 x) xs))
+toBlock _ = Nothing
+
+type instance RepT (Array i) = L (Pair (Rep i)) :*: K0 (Pair (Rep i) (Rep i))
+type instance Rep (Array i e) = RepT (Array i) (Rep e)
+
+$(genRepT [d|
+ instance (Repr i, Ix i) => ReprT (Array i) where
+ toRepTMap f arr = List [(toRep i, f a) | (i, a) <- assocs arr] :*: K0 (toRep l, toRep u)
+ where (l, u) = bounds arr
+ fromRepTMap f (List xs :*: K0 (l, r))
+ = array (fromRep l, fromRep r) [(fromRep k, f a) | (k, a) <- xs] |])
+
+type instance RepT Set.Set = L I0
+type instance RepT (Map.Map k) = L (Pair (Rep k))
+type instance Rep (Set.Set a) = L I0 (Rep a)
+type instance Rep (Map.Map k a) = RepT (Map.Map k) (Rep a)
+
+$(genRepT [d|
+ instance ReprT Set.Set where
+ toRepTMap f s = List (Fold.foldr (\ a xs -> I0 (f a):xs) [] s)
+ fromRepTMap f (List xs) = Set.fromDistinctAscList [f x | I0 x <- xs] |])
+
+$(genRepT [d|
+ instance Repr k => ReprT (Map.Map k) where
+ toRepTMap f m = List (Map.foldWithKey (\ k a xs -> (toRep k, f a):xs) [] m)
+ fromRepTMap f (List xs) = Map.fromDistinctAscList [(fromRep k, f x) | (k, x) <- xs] |])
+
+type instance RepT Rev = Rev
+type instance Rep (Rev a) = Rev (Rep a)
+
+$(genRepT [d|
+ instance ReprT Rev where
+ toRepTMap f (Rev m) = Rev (f m)
+ fromRepTMap f (Rev m) = Rev (f m) |]) \ No newline at end of file
diff --git a/Data/TrieMap/Rep/TH.hs b/Data/TrieMap/Rep/TH.hs
new file mode 100644
index 0000000..0f2b8b4
--- /dev/null
+++ b/Data/TrieMap/Rep/TH.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, QuasiQuotes #-}
+
+module Data.TrieMap.Rep.TH (genRepT, mkCon, conT, mkVar, appT, Type(..)) where
+
+import Language.Haskell.TH
+import Data.TrieMap.Rep
+import Language.Haskell.TH.Ppr
+import Debug.Trace
+{-
+genRepT :: TypeQ -> Q [Dec]
+genRepT ff = do
+ f <- ff
+ a <- newName "a"
+ b <- newName "b"
+ g <- newName "g"
+ let reprt = ConT (mkName "ReprT")
+ let repr = ConT (mkName "Repr")
+ let rept = ConT (mkName "RepT")
+ let rep = ConT (mkName "Rep")
+ torep <- [| fmap toRep . toRepT |]
+ fromrep <- [| fromRepT . fmap fromRep |]
+ let toRepType = ForallT [g, b] [AppT reprt (VarT g), AppT repr (VarT b)]
+ (AppT (VarT g) (VarT b) ~> AppT (AppT rept (VarT g)) (AppT rep (VarT b)))
+ let fromRepType = ForallT [g, b] [AppT reprt (VarT g), AppT repr (VarT b)]
+ (AppT (AppT rept (VarT g)) (AppT rep (VarT b)) ~> AppT (VarT g) (VarT b))
+ let ans = [InstanceD [AppT reprt f, AppT repr (VarT a)] (AppT repr (AppT f (VarT a)))
+ [FunD (mkName "toRep") [Clause [] (NormalB ( torep )) []],
+ FunD (mkName "fromRep") [Clause [] (NormalB ( fromrep )) []]]]
+ return ans-}
+
+genRepT :: Q [Dec] -> Q [Dec]
+genRepT decs = do
+ iT@(InstanceD cxt (reprt `AppT` f) _:_) <- decs
+ (InstanceD _ _ myDecs:_) <- [d|
+ instance (ReprT f, Repr a) => Repr (f a) where
+ toRep = toRepTMap toRep
+ fromRep = fromRepTMap fromRep
+ |]
+ a <- mkVar "a"
+ repr <- conT ''Repr
+ return (InstanceD (repr `AppT` a:cxt) (repr `AppT` (f `AppT` a)) myDecs :iT)
+
+(~>) :: Type -> Type -> Type
+a ~> b = AppT (AppT ArrowT a) b
+
+mkCon :: String -> TypeQ
+mkCon = conT . mkName
+
+mkVar :: String -> TypeQ
+mkVar x = varT =<< newName x
+
+-- f :: Q [Dec]
+-- f = do ans <- [d| instance (ReprT ((,) a), Repr b) => Repr (a, b) where |]
+-- traceShow ans $ return ans \ No newline at end of file
diff --git a/Data/TrieMap/Representation.hs b/Data/TrieMap/Representation.hs
new file mode 100644
index 0000000..7f1d221
--- /dev/null
+++ b/Data/TrieMap/Representation.hs
@@ -0,0 +1,6 @@
+module Data.TrieMap.Representation (Repr(..), ReprT(..), Rep, RepT) where
+
+import Data.TrieMap.Rep
+import Data.TrieMap.Rep.Instances
+import Data.TrieMap.Regular.Rep
+
diff --git a/Data/TrieMap/Representation/TH.hs b/Data/TrieMap/Representation/TH.hs
new file mode 100644
index 0000000..5c1243e
--- /dev/null
+++ b/Data/TrieMap/Representation/TH.hs
@@ -0,0 +1,3 @@
+module Data.TrieMap.Representation.TH (module Data.TrieMap.Rep.TH) where
+
+import Data.TrieMap.Rep.TH \ No newline at end of file
diff --git a/Data/TrieMap/ReverseMap.hs b/Data/TrieMap/ReverseMap.hs
new file mode 100644
index 0000000..c3929e0
--- /dev/null
+++ b/Data/TrieMap/ReverseMap.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TemplateHaskell, UndecidableInstances, TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}
+
+module Data.TrieMap.ReverseMap() where
+
+import Data.TrieMap.TrieKey
+import Data.TrieMap.Modifiers
+import Data.TrieMap.Applicative
+import Data.TrieMap.Regular.Class
+import Data.TrieMap.Regular.TH
+
+import Control.Applicative
+import Control.Arrow
+
+import Data.Monoid hiding (Dual)
+
+newtype ReverseMap k a = RMap (TrieMap k a)
+
+type instance TrieMapT Rev = ReverseMap
+type instance TrieMap (Rev k) = ReverseMap k
+
+$(deriveM [d|
+ instance TrieKeyT Rev ReverseMap where
+ emptyT = RMap emptyM
+ nullT (RMap m) = nullM m
+ sizeT s (RMap m) = sizeM s m
+ lookupT (Rev k) (RMap m) = lookupM k m
+ lookupIxT s (Rev k) (RMap m) = case lookupIxM s k m of
+ (Last lb, x, First ub) -> onKey Rev (onIndex (sizeM s m - 1 -) (Last ub, x, First lb))
+ assocAtT s i (RMap m) = case assocAtM s (sz - 1 - i) m of
+ (Last lb, x, First ub) -> onKey Rev (onIndex (sz -) (Last ub, x, First lb))
+ where sz = sizeM s m
+-- updateAtM s r f i (RMap m) = RMap (updateAtM s r' f' (sz - i) m) where
+-- r' = not r
+-- f' i = f (sz - 1 - i) . Rev
+-- sz = sizeM s m
+ traverseWithKeyT s f (RMap m) = RMap <$> runDual (traverseWithKeyM s (\ k a -> Dual (f (Rev k) a)) m)
+ alterT s f (Rev k) (RMap m) = RMap (alterM s f k m)
+ splitLookupT s f (Rev k) (RMap m) = case splitLookupM s f' k m of
+ (mL, x, mR) -> (RMap mR, x, RMap mL)
+ where f' x = case f x of
+ (xL, ans, xR) -> (xR, ans, xL)
+ mapEitherT s1 s2 f (RMap m) = (RMap *** RMap) (mapEitherM s1 s2 (f . Rev) m)
+ foldWithKeyT f (RMap m) = foldlWithKeyM (flip . f . Rev) m
+ foldlWithKeyT f (RMap m) = foldWithKeyM (flip . f . Rev) m
+ unionT s f (RMap m1) (RMap m2) = RMap (unionM s (f . Rev) m1 m2)
+ isectT s f (RMap m1) (RMap m2) = RMap (isectM s (f . Rev) m1 m2)
+ diffT s f (RMap m1) (RMap m2) = RMap (diffM s (f . Rev) m1 m2)
+ extractT s f (RMap m) = second RMap <$> runDual (extractM s (\ k a -> Dual (f (Rev k) a)) m)
+-- extractMinM s f (RMap m) = second RMap <$> First (getLast (extractMaxM s (f . Rev) m))
+-- extractMaxM s f (RMap m) = second RMap <$> Last (getFirst (extractMinM s (f . Rev) m))
+-- alterMinM s f (RMap m) = RMap (alterMaxM s (f . Rev) m)
+-- alterMaxM s f (RMap m) = RMap (alterMinM s (f . Rev) m)
+ isSubmapT (<=) (RMap m1) (RMap m2) = isSubmapM (<=) m1 m2
+
+ reverse :: TrieMap k a -> TrieMap (Rev k) a
+ reverse = RMap |])
+
+unreverse :: TrieMap (Rev k) a -> TrieMap k a
+unreverse (RMap m) = m \ No newline at end of file
diff --git a/Data/TrieMap/Sized.hs b/Data/TrieMap/Sized.hs
index 153ec6d..fa45189 100644
--- a/Data/TrieMap/Sized.hs
+++ b/Data/TrieMap/Sized.hs
@@ -10,9 +10,9 @@ module Data.TrieMap.Sized where
-- instance Sized Elem where
-- getSize _ = 1
-type Sized f = forall ix . f ix -> Int
+type Sized a = a -> Int
newtype Elem a = Elem {getElem :: a}
-elemSize :: Sized Elem
+elemSize :: Sized (Elem a)
elemSize _ = 1 \ No newline at end of file
diff --git a/Data/TrieMap/TrieKey.hs b/Data/TrieMap/TrieKey.hs
index de2f58a..799dd99 100644
--- a/Data/TrieMap/TrieKey.hs
+++ b/Data/TrieMap/TrieKey.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE Rank2Types, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, KindSignatures #-}
+{-# LANGUAGE PatternGuards, Rank2Types, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, KindSignatures #-}
module Data.TrieMap.TrieKey where
@@ -6,13 +6,14 @@ import Data.TrieMap.Applicative
import Data.TrieMap.Sized
import Control.Applicative
+import Control.Arrow
import Data.Monoid
import Data.List
-type family TrieMap k :: (* -> *) -> * -> *
+type family TrieMap k :: * -> *
-type family MapPF (m :: (* -> *) -> * -> *) ix :: (* -> *) -> *
+-- type family MapPF (m :: (* -> *) -> * -> *) ix :: (* -> *) -> *
-- data Fixer f
type EitherMap k a b c = k -> a -> (Maybe b, Maybe c)
@@ -20,47 +21,81 @@ 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 ExtractFunc f m k a x = (k -> a -> f (x, Maybe a)) -> m -> f (x, m)
type LEq a b = a -> b -> Bool
+
+data Assoc k a = Asc {-# UNPACK #-} !Int k a
+-- data IndexPos k a = Between {-# UNPACK #-} !(Assoc k a) {-# UNPACK #-} !(Assoc k a)
+-- | Exact {-# UNPACK #-} !(Assoc k a) (Last (Assoc k a)) (First (Assoc k a))
+-- | Above {-# UNPACK #-} !(Assoc k a) | Below {-# UNPACK #-} !(Assoc k a) | Nada
+type IndexPos k a = (Last (Assoc k a), Maybe (Assoc k a), First (Assoc k a))
+
+onIndexA :: (Int -> Int) -> Assoc k a -> Assoc k a
+onIndexA f (Asc i k a) = Asc (f i) k a
+
+onIndex :: (Int -> Int) -> IndexPos k a -> IndexPos k a
+onIndex f (l, x, r) = (onIndexA f <$> l, onIndexA f <$> x, onIndexA f <$> r)
+
+onKey :: (k -> k') -> IndexPos k a -> IndexPos k' a
+onKey = onValue . first
+
+onVal :: (a -> a') -> IndexPos k a -> IndexPos k a'
+onVal = onValue . second
+
+onKeyA :: (k -> k') -> Assoc k a -> Assoc k' a
+onKeyA = onValueA . first
+
+onValA :: (a -> a') -> Assoc k a -> Assoc k a'
+onValA = onValueA . second
+
+{-# INLINE onValueA #-}
+onValueA :: ((k, a) -> (k', a')) -> Assoc k a -> Assoc k' a'
+onValueA f (Asc i k a) = uncurry (Asc i) (f (k, a))
+
+{-# INLINE onValue #-}
+onValue :: ((k, a) -> (k', a')) -> IndexPos k a -> IndexPos k' a'
+onValue f (l, x, r) = (onValueA f <$> l, onValueA f <$> x, onValueA f <$> r)
+
+type Round = Bool
-- type Sized f = forall ix . f ix -> Int
-- toFixer :: a -> Fixer a
-- toFixer _ = undefined
class Ord k => TrieKey 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
+ emptyM :: TrieMap k ~ m => m a
+ nullM :: TrieMap k ~ m => m a -> Bool
+ sizeM :: (TrieMap k ~ m) => Sized a -> m a -> Int
+ lookupM :: TrieMap k ~ m => k -> m a -> Maybe (a)
+ lookupIxM :: TrieMap k ~ m => Sized a -> k -> m a -> IndexPos k a
+ assocAtM :: TrieMap k ~ m => Sized a -> Int -> m a -> IndexPos k a
+-- updateAtM :: TrieMap k ~ m => Sized a -> Round -> (Int -> k -> a -> Maybe (a)) -> Int -> m a -> m a
+ alterM :: (TrieMap k ~ m) => Sized a -> (Maybe (a) -> Maybe (a)) -> k -> m a -> m a
+ {-# SPECIALIZE traverseWithKeyM :: (k -> a -> Id (b)) -> m a -> Id (m b) #-}
+ traverseWithKeyM :: (TrieMap k ~ m, Applicative f) => Sized b ->
+ (k -> a -> f (b)) -> m a -> f (m b)
+ foldWithKeyM :: TrieMap k ~ m => (k -> a -> b -> b) -> m a -> b -> b
+ foldlWithKeyM :: TrieMap k ~ m => (k -> b -> a -> b) -> m a -> b -> b
+ mapEitherM :: (TrieMap k ~ m) => Sized b -> Sized c -> EitherMap k (a) (b) (c) -> m a -> (m b, m c)
+ splitLookupM :: (TrieMap k ~ m) => Sized a -> SplitMap (a) x -> k -> m a -> (m a, Maybe x, m a)
+ unionM :: (TrieMap k ~ m) => Sized a -> UnionFunc k (a) -> m a -> m a -> m a
+ isectM :: (TrieMap k ~ m) => Sized c -> IsectFunc k (a) (b) (c) -> m a -> m b -> m c
+ diffM :: (TrieMap k ~ m) => Sized a -> DiffFunc k (a) (b) -> m a -> m b -> m a
+ extractM :: (TrieMap k ~ m, Alternative f) => Sized a -> ExtractFunc f (m a) k a x
+-- extractMinM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k First (a) (m a) x
+-- extractMaxM :: (TrieMap k ~ m) => Sized a -> ExtractFunc k Last (a) (m a) x
+-- alterMinM :: (TrieMap k ~ m) => Sized a -> (k -> a -> Maybe a) -> m a -> First (m a)
+-- alterMaxM :: (TrieMap k ~ m) => Sized a -> (k -> a -> Maybe a) -> m a -> Last (m a)
+ isSubmapM :: TrieMap k ~ m => LEq (a) (b) -> LEq (m a) (m b)
+ fromListM, fromAscListM :: (TrieMap k ~ m) => Sized a -> (k -> a -> a -> a) -> [(k, a)] -> m a
+ fromDistAscListM :: (TrieMap k ~ m) => Sized a -> [(k, a)] -> m a
sizeM s m = foldWithKeyM (\ _ a n -> s a + n) m 0
fromListM s f = foldl' (flip (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 :: (TrieKey k m, m ~ TrieMap k) => m a -> Maybe (m a)
guardNullM m
| nullM m = Nothing
| otherwise = Just m
@@ -68,29 +103,29 @@ guardNullM 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 :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a -> Maybe (b)) -> m a -> m b
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 :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (k -> a -> b) -> m a -> m b
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 :: (TrieKey k m, m ~ TrieMap k) => Sized b -> (a -> b) -> m a -> m b
mapM s = mapWithKeyM s . const
-assocsM :: (TrieKey k m, m ~ TrieMap k) => m a ix -> [(k, a ix)]
+assocsM :: (TrieKey k m, m ~ TrieMap k) => m a -> [(k, a)]
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 :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a -> m a -> m a
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 :: (TrieKey k m, m ~ TrieMap k) => Sized a -> (k -> a -> a -> a) -> k -> a -> m a -> m a
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 :: (TrieKey k m, m ~ TrieMap k) => Sized a -> k -> a -> m a
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' :: (TrieKey k m, m ~ TrieMap k) => Sized a -> [(k, a)] -> m a
fromListM' s = fromListM s (const const) --xs = foldr (uncurry insertM) emptyM xs
unionMaybe :: (a -> a -> Maybe a) -> Maybe a -> Maybe a -> Maybe a
@@ -109,4 +144,7 @@ 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
+subMaybe _ _ _ = False
+
+aboutM :: (TrieKey k (TrieMap k), Alternative t) => (k -> a -> t z) -> TrieMap k a -> t z
+aboutM f = fst <.> extractM (const 0) (\ k a -> fmap (flip (,) Nothing) (f k a)) \ No newline at end of file
diff --git a/Data/TrieSet.hs b/Data/TrieSet.hs
new file mode 100644
index 0000000..7029830
--- /dev/null
+++ b/Data/TrieSet.hs
@@ -0,0 +1,173 @@
+module Data.TrieSet (
+ -- * Set type
+ TSet,
+ -- * Operators
+ (\\),
+ -- * Query
+ null,
+ size,
+ member,
+ notMember,
+ isSubsetOf,
+ isProperSubsetOf,
+ -- * Construction
+ empty,
+ singleton,
+ insert,
+ delete,
+ -- * Combine
+ union,
+ symmetricDifference,
+ intersection,
+ difference,
+ -- * Filter
+ filter,
+ partition,
+ split,
+ splitMember,
+ -- * Map
+ map,
+ mapMonotonic,
+ -- * Fold
+ fold,
+ foldl,
+ foldr,
+ -- * Min/Max
+ findMin,
+ findMax,
+ deleteMin,
+ deleteMax,
+ deleteFindMin,
+ deleteFindMax,
+ minView,
+ maxView,
+ -- * Conversion
+ -- ** List
+ elems,
+ toList,
+ fromList,
+ -- ** Ordered lists
+ toAscList,
+ fromAscList,
+ fromDistinctAscList)
+ where
+
+import qualified Data.TrieMap as M
+import Data.TrieMap.Class
+
+import Control.Applicative hiding (empty)
+import Control.Arrow
+
+import Data.Maybe
+import Data.Monoid
+
+import Prelude hiding (foldr, foldl, map, filter, null)
+
+instance TKey a => Eq (TSet a) where
+ s1 == s2 = s1 `isSubsetOf` s2 && size s1 == size s2
+
+instance (TKey a, Ord a) => Ord (TSet a) where
+ s1 `compare` s2 = elems s1 `compare` elems s2
+
+instance (TKey a, Show a) => Show (TSet a) where
+ show s = "fromList " ++ show (elems s)
+
+instance TKey a => Monoid (TSet a) where
+ mempty = empty
+ mappend = union
+
+empty :: TKey a => TSet a
+empty = TSet M.empty
+
+insert :: TKey a => a -> TSet a -> TSet a
+insert a (TSet s) = TSet (M.insert a () s)
+
+delete :: TKey a => a -> TSet a -> TSet a
+delete a (TSet s) = TSet (M.delete a s)
+
+singleton :: TKey a => a -> TSet a
+singleton a = insert a empty
+
+union :: TKey a => TSet a -> TSet a -> TSet a
+TSet s1 `union` TSet s2 = TSet (s1 `M.union` s2)
+
+symmetricDifference :: TKey a => TSet a -> TSet a -> TSet a
+TSet s1 `symmetricDifference` TSet s2 = TSet (M.unionMaybeWith (\ _ _ -> Nothing) s1 s2)
+
+difference :: TKey a => TSet a -> TSet a -> TSet a
+TSet s1 `difference` TSet s2 = TSet (s1 `M.difference` s2)
+
+intersection :: TKey a => TSet a -> TSet a -> TSet a
+TSet s1 `intersection` TSet s2 = TSet (s1 `M.intersection` s2)
+
+filter :: TKey a => (a -> Bool) -> TSet a -> TSet a
+filter p (TSet s) = TSet (M.filterWithKey (\ k _ -> p k) s)
+
+partition :: TKey a => (a -> Bool) -> TSet a -> (TSet a, TSet a)
+partition p (TSet s) = (TSet *** TSet) (M.partitionWithKey (\ k _ -> p k) s)
+
+split :: TKey a => a -> TSet a -> (TSet a, TSet a)
+split a s = case splitMember a s of
+ (sL, _, sR) -> (sL, sR)
+
+splitMember :: TKey a => a -> TSet a -> (TSet a, Bool, TSet a)
+splitMember a (TSet s) = case M.splitLookup a s of
+ (sL, x, sR) -> (TSet sL, isJust x, TSet sR)
+
+map :: (TKey a, TKey b) => (a -> b) -> TSet a -> TSet b
+map f (TSet s) = TSet (M.mapKeys f s)
+
+mapMonotonic :: (TKey a, TKey b) => (a -> b) -> TSet a -> TSet b
+mapMonotonic f (TSet s) = TSet (M.mapKeysMonotonic f s)
+
+fold, foldr :: TKey a => (a -> b -> b) -> b -> TSet a -> b
+fold = foldr
+foldr f z (TSet s) = M.foldrWithKey (const . f) z s
+
+foldl :: TKey b => (a -> b -> a) -> a -> TSet b -> a
+foldl f z (TSet s) = M.foldlWithKey (\ z a _ -> f z a) z s
+
+findMin, findMax :: TKey a => TSet a -> a
+findMin = fst . deleteFindMin
+findMax = fst . deleteFindMax
+
+deleteMin, deleteMax :: TKey a => TSet a -> TSet a
+deleteMin s = maybe s snd (minView s)
+deleteMax s = maybe s snd (maxView s)
+
+deleteFindMin, deleteFindMax :: TKey a => TSet a -> (a, TSet a)
+deleteFindMin = fromJust . minView
+deleteFindMax = fromJust . maxView
+
+minView, maxView :: TKey a => TSet a -> Maybe (a, TSet a)
+minView (TSet s) = (fst *** TSet) <$> M.minViewWithKey s
+maxView (TSet s) = (fst *** TSet) <$> M.maxViewWithKey s
+
+elems, toList, toAscList :: TKey a => TSet a -> [a]
+elems (TSet s) = M.keys s
+toList = elems
+toAscList = toList
+
+fromList, fromAscList, fromDistinctAscList :: TKey a => [a] -> TSet a
+fromList xs = TSet (M.fromList [(x, ()) | x <- xs])
+fromAscList xs = TSet (M.fromAscList [(x, ()) | x <- xs])
+fromDistinctAscList xs = TSet (M.fromDistinctAscList [(x, ()) | x <- xs])
+
+null :: TKey a => TSet a -> Bool
+null (TSet s) = M.null s
+
+size :: TKey a => TSet a -> Int
+size (TSet s) = M.size s
+
+member :: TKey a => a -> TSet a -> Bool
+member a (TSet s) = a `M.member` s
+
+notMember :: TKey a => a -> TSet a -> Bool
+notMember a = not . member a
+
+isSubsetOf, isProperSubsetOf :: TKey a => TSet a -> TSet a -> Bool
+TSet s1 `isSubsetOf` TSet s2 = M.isSubmapOfBy (\ _ _ -> True) s1 s2
+s1 `isProperSubsetOf` s2 = size s1 < size s2 && s1 `isSubsetOf` s2
+
+(\\) :: TKey a => TSet a -> TSet a -> TSet a
+(\\) = difference \ No newline at end of file
diff --git a/TrieMap.cabal b/TrieMap.cabal
index f40c7f7..81ac265 100644
--- a/TrieMap.cabal
+++ b/TrieMap.cabal
@@ -1,5 +1,5 @@
name: TrieMap
-version: 0.5.1
+version: 0.5.2
tested-with: GHC
category: Algorithms
synopsis: Automatic type inference of generalized tries.
@@ -8,24 +8,36 @@ license: BSD3
license-file: LICENSE
author: Louis Wasserman
maintainer: wasserman.louis@gmail.com
-build-Depends: base < 5.0.0.0, containers, multirec
+build-Depends: base < 5.0.0.0, containers, multirec, template-haskell, bytestring, array
build-type: Simple
exposed-modules:
Data.TrieMap,
+ Data.TrieSet,
Data.TrieMap.Class,
Data.TrieMap.Regular,
- Data.TrieMap.MultiRec
+ Data.TrieMap.MultiRec,
+ Data.TrieMap.Representation,
+ Data.TrieMap.Representation.TH,
+ Data.TrieMap.Modifiers
-- Data.TrieMap.TrieKey
other-modules:
Data.TrieMap.Class.Instances,
Data.TrieMap.TrieKey,
Data.TrieMap.Applicative,
+ Data.TrieMap.Rep,
+ Data.TrieMap.Rep.Instances,
+ Data.TrieMap.Rep.TH,
+ Data.TrieMap.MultiRec.TH,
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.Base,
+ -- Data.TrieMap.MultiRec.XMap,
+ Data.TrieMap.MultiRec.FixMap,
+ -- Data.TrieMap.MultiRec.AppMap,
Data.TrieMap.MultiRec.Instances,
Data.TrieMap.MultiRec.ProdMap,
Data.TrieMap.MultiRec.TagMap,
@@ -43,9 +55,13 @@ other-modules:
Data.TrieMap.Regular.RadixTrie,
Data.TrieMap.Regular.UnitMap,
Data.TrieMap.Regular.RegMap,
+ Data.TrieMap.Regular.CompMap,
Data.TrieMap.Regular.UnionMap,
+ Data.TrieMap.Regular.TH,
Data.TrieMap.Regular.Sized,
+ Data.TrieMap.Regular.Rep,
Data.TrieMap.IntMap,
Data.TrieMap.OrdMap,
+ Data.TrieMap.ReverseMap,
Data.TrieMap.Sized,
Data.TrieMap.Applicative