diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,58 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.6.3.1 + +### Bug fixes + +* Fix `traverse` and `traverseWithKey` for `IntMap`, which would + previously produce invalid `IntMap`s when the input contained + negative keys (Thanks, Felix Paulusma). + +* Fix the traversal order of various functions for `Data.IntMap`: + `traverseWithKey`, `traverseMaybeWithKey`, `filterWithKeyA`, + `minimum`, `maximum`, `mapAccum`, `mapAccumWithKey`, `mapAccumL`, + `mapAccumRWithKey`, `mergeA` (Thanks, Felix Paulusma, Simon Jakobi). + +### Additions + +* Add `compose` for `Map` and `IntMap` (Thanks, Alexandre Esteves). + +* Add `alterF` for `Set` and `IntSet` (Thanks, Simon Jakobi). + +* Add `Data.IntSet.mapMonotonic` (Thanks, Javran Cheng). + +* Add `instance Bifoldable Map` (Thanks, Joseph C. Sible). + +### Performance improvements + +* Make `(<*)` for `Data.Sequence` incrementally asymptotically optimal. + This finally completes the task, begun in December 2014, of making all + the `Applicative` methods for sequences asymptotically optimal + even when their results are consumed incrementally. Many thanks to + Li-Yao Xia and Bertram Felgenhauer for helping to clean up and begin + to document this rather tricky code. + +* Speed up `fromList` and related functions in `Data.IntSet`, `Data.IntMap` + and `Data.IntMap.Strict` (Thanks, Bertram Felgenhauer). + +* Use `count{Leading,Trailing}Zeros` in `Data.IntSet` internals (Thanks, Alex + Biehl). + +### Other changes + +* Reduce usage of the `Forest` type synonym in `Data.Tree` (Thanks, David + Feuer). + +* Address a Core lint warning for `foldToMaybeTree` (Thanks, Matthew Pickering). + +* Improve documentation (Thanks to Daniel Wagner, Johannes Waldmann, Steve Mao, + Gabriel Greif, Jean-Baptiste Mazon, Ziyang Liu, Matt Renaud, Li-Yao Xia). + +* Improvements to the testsuite and benchmarks (Thanks, Bertram Felgenhauer, + Simon Jakobi, Johannes Waldmann). + +* Canonicalise `Seq`'s `Monoid` instance (Thanks, Fumiaki Kinoshita). + ## 0.6.2.1 * Add `disjoint` for `Map` and `IntMap` (Thanks, Simon Jakobi). diff --git a/containers.cabal b/containers.cabal --- a/containers.cabal +++ b/containers.cabal @@ -1,5 +1,5 @@ name: containers -version: 0.6.2.1 +version: 0.6.3.1 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -20,18 +20,19 @@ remains valid even if structures are shared. build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 extra-source-files: include/containers.h changelog.md -tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 +tested-with: GHC==8.8.2, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 source-repository head type: git location: http://github.com/haskell/containers.git Library + default-language: Haskell2010 build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5 hs-source-dirs: src ghc-options: -O2 -Wall diff --git a/src/Data/Containers/ListUtils.hs b/src/Data/Containers/ListUtils.hs --- a/src/Data/Containers/ListUtils.hs +++ b/src/Data/Containers/ListUtils.hs @@ -17,6 +17,8 @@ -- In the documentation, \(n\) is the number of elements in the list while -- \(d\) is the number of distinct elements in the list. \(W\) is the number -- of bits in an 'Int'. +-- +-- @since 0.6.0.1 ----------------------------------------------------------------------------- module Data.Containers.ListUtils ( @@ -53,6 +55,8 @@ -- pathological cases. For example, to nub a list of characters, use -- -- @ nubIntOn fromEnum xs @ +-- +-- @since 0.6.0.1 nubOrd :: Ord a => [a] -> [a] nubOrd = nubOrdOn id {-# INLINE nubOrd #-} @@ -65,6 +69,8 @@ -- -- @nubOrdOn@ is strict in the values of the function applied to the -- elements of the list. +-- +-- @since 0.6.0.1 nubOrdOn :: Ord b => (a -> b) -> [a] -> [a] -- For some reason we need to write an explicit lambda here to allow this -- to inline when only applied to a function. @@ -129,6 +135,8 @@ -- ==== Strictness -- -- @nubInt@ is strict in the elements of the list. +-- +-- @since 0.6.0.1 nubInt :: [Int] -> [Int] nubInt = nubIntOn id {-# INLINE nubInt #-} @@ -142,6 +150,8 @@ -- -- @nubIntOn@ is strict in the values of the function applied to the -- elements of the list. +-- +-- @since 0.6.0.1 nubIntOn :: (a -> Int) -> [a] -> [a] -- For some reason we need to write an explicit lambda here to allow this -- to inline when only applied to a function. diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -383,7 +383,7 @@ -- type @key@ labeled by values of type @node@ and produces a @Graph@-based -- representation of that list. The @Graph@ result represents the /shape/ of the -- graph, and the functions describe a) how to retrieve the label and adjacent --- vertices of a given vertex, and b) how to retrive a vertex given a key. +-- vertices of a given vertex, and b) how to retrieve a vertex given a key. -- -- @(graph, nodeFromVertex, vertexFromKey) = graphFromEdges edgeList@ -- diff --git a/src/Data/IntMap/Internal.hs b/src/Data/IntMap/Internal.hs --- a/src/Data/IntMap/Internal.hs +++ b/src/Data/IntMap/Internal.hs @@ -131,6 +131,9 @@ , intersectionWith , intersectionWithKey + -- ** Compose + , compose + -- ** General combining function , SimpleWhenMissing , SimpleWhenMatched @@ -266,6 +269,7 @@ , natFromInt , intFromNat , link + , linkWithMask , bin , binCheckLeft , binCheckRight @@ -478,7 +482,9 @@ maximum = start where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map" start (Tip _ y) = y - start (Bin _ _ l r) = go (start l) r + start (Bin _ m l r) + | m < 0 = go (start r) l + | otherwise = go (start l) r go !m Nil = m go m (Tip _ y) = max m y @@ -487,7 +493,9 @@ minimum = start where start Nil = error "Data.Foldable.minimum (for Data.IntMap): empty map" start (Tip _ y) = y - start (Bin _ _ l r) = go (start l) r + start (Bin _ m l r) + | m < 0 = go (start r) l + | otherwise = go (start l) r go !m Nil = m go m (Tip _ y) = min m y @@ -761,6 +769,27 @@ | otherwise = disjoint t1 r2 {-------------------------------------------------------------------- + Compose +--------------------------------------------------------------------} +-- | Relate the keys of one map to the values of +-- the other, by using the values of the former as keys for lookups +-- in the latter. +-- +-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument +-- +-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")] +-- +-- @ +-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?') +-- @ +-- +-- @since 0.6.3.1 +compose :: IntMap c -> IntMap Int -> IntMap c +compose bc !ab + | null bc = empty + | otherwise = mapMaybe (bc !?) ab + +{-------------------------------------------------------------------- Construction --------------------------------------------------------------------} -- | /O(1)/. The empty map. @@ -1825,8 +1854,9 @@ :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a) filterWithKeyA _ Nil = pure Nil filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x -filterWithKeyA f (Bin p m l r) = - liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r) +filterWithKeyA f (Bin p m l r) + | m < 0 = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l) + | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r) -- | This wasn't in Data.Bool until 4.7.0, so we define it here bool :: a -> a -> Bool -> a @@ -1867,7 +1897,9 @@ where go Nil = pure Nil go (Tip k x) = maybe Nil (Tip k) <$> f k x - go (Bin p m l r) = liftA2 (bin p m) (go l) (go r) + go (Bin p m l r) + | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) + | otherwise = liftA2 (bin p m) (go l) (go r) -- | Merge two maps. @@ -2039,8 +2071,8 @@ where merge2 t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2) - | zero k1 m2 = liftA2 (bin p2 m2) (merge2 l2) (g2t r2) - | otherwise = liftA2 (bin p2 m2) (g2t l2) (merge2 r2) + | zero k1 m2 = binA p2 m2 (merge2 l2) (g2t r2) + | otherwise = binA p2 m2 (g2t l2) (merge2 r2) merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2 merge2 Nil = subsingletonBy g1k k1 x1 @@ -2048,23 +2080,23 @@ where merge1 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2) - | zero k2 m1 = liftA2 (bin p1 m1) (merge1 l1) (g1t r1) - | otherwise = liftA2 (bin p1 m1) (g1t l1) (merge1 r1) + | zero k2 m1 = binA p1 m1 (merge1 l1) (g1t r1) + | otherwise = binA p1 m1 (g1t l1) (merge1 r1) merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2 merge1 Nil = subsingletonBy g2k k2 x2 go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | shorter m1 m2 = merge1 | shorter m2 m1 = merge2 - | p1 == p2 = liftA2 (bin p1 m1) (go l1 l2) (go r1 r2) - | otherwise = liftA2 (link_ p1 p2) (g1t t1) (g2t t2) + | p1 == p2 = binA p1 m1 (go l1 l2) (go r1 r2) + | otherwise = linkA p1 (g1t t1) p2 (g2t t2) where - merge1 | nomatch p2 p1 m1 = liftA2 (link_ p1 p2) (g1t t1) (g2t t2) - | zero p2 m1 = liftA2 (bin p1 m1) (go l1 t2) (g1t r1) - | otherwise = liftA2 (bin p1 m1) (g1t l1) (go r1 t2) - merge2 | nomatch p1 p2 m2 = liftA2 (link_ p1 p2) (g1t t1) (g2t t2) - | zero p1 m2 = liftA2 (bin p2 m2) (go t1 l2) (g2t r2) - | otherwise = liftA2 (bin p2 m2) (g2t l2) (go t1 r2) + merge1 | nomatch p2 p1 m1 = linkA p1 (g1t t1) p2 (g2t t2) + | zero p2 m1 = binA p1 m1 (go l1 t2) (g1t r1) + | otherwise = binA p1 m1 (g1t l1) (go r1 t2) + merge2 | nomatch p1 p2 m2 = linkA p1 (g1t t1) p2 (g2t t2) + | zero p1 m2 = binA p2 m2 (go t1 l2) (g2t r2) + | otherwise = binA p2 m2 (g2t l2) (go t1 r2) subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x {-# INLINE subsingletonBy #-} @@ -2084,11 +2116,6 @@ subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2) {-# INLINE subdoubleton #-} - link_ _ _ Nil t2 = t2 - link_ _ _ t1 Nil = t1 - link_ p1 p2 t1 t2 = link p1 t1 p2 t2 - {-# INLINE link_ #-} - -- | A variant of 'link_' which makes sure to execute side-effects -- in the right order. linkA @@ -2097,12 +2124,26 @@ -> Prefix -> f (IntMap a) -> f (IntMap a) linkA p1 t1 p2 t2 - | zero p1 m = liftA2 (bin p m) t1 t2 - | otherwise = liftA2 (bin p m) t2 t1 + | zero p1 m = binA p m t1 t2 + | otherwise = binA p m t2 t1 where m = branchMask p1 p2 p = mask p1 m {-# INLINE linkA #-} + + -- A variant of 'bin' that ensures that effects for negative keys are executed + -- first. + binA + :: Applicative f + => Prefix + -> Mask + -> f (IntMap a) + -> f (IntMap a) + -> f (IntMap a) + binA p m a b + | m < 0 = liftA2 (flip (bin p m)) b a + | otherwise = liftA2 (bin p m) a b + {-# INLINE binA #-} {-# INLINE mergeA #-} @@ -2309,7 +2350,7 @@ {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when - @m1@ and @m2@ are not equal, + @keys m1@ and @keys m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': @@ -2456,7 +2497,7 @@ go Nil = pure Nil go (Tip k v) = Tip k <$> f k v go (Bin p m l r) - | m < 0 = liftA2 (Bin p m) (go r) (go l) + | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l) | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} @@ -2484,20 +2525,32 @@ mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumL f a t = case t of - Bin p m l r -> let (a1,l') = mapAccumL f a l - (a2,r') = mapAccumL f a1 r - in (a2,Bin p m l' r') + Bin p m l r + | m < 0 -> + let (a1,r') = mapAccumL f a r + (a2,l') = mapAccumL f a1 l + in (a2,Bin p m l' r') + | otherwise -> + let (a1,l') = mapAccumL f a l + (a2,r') = mapAccumL f a1 r + in (a2,Bin p m l' r') Tip k x -> let (a',x') = f a k x in (a',Tip k x') Nil -> (a,Nil) --- | /O(n)/. The function @'mapAccumR'@ threads an accumulating +-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey f a t = case t of - Bin p m l r -> let (a1,r') = mapAccumRWithKey f a r - (a2,l') = mapAccumRWithKey f a1 l - in (a2,Bin p m l' r') + Bin p m l r + | m < 0 -> + let (a1,l') = mapAccumRWithKey f a l + (a2,r') = mapAccumRWithKey f a1 r + in (a2,Bin p m l' r') + | otherwise -> + let (a1,r') = mapAccumRWithKey f a r + (a2,l') = mapAccumRWithKey f a1 l + in (a2,Bin p m l' r') Tip k x -> let (a',x') = f a k x in (a',Tip k x') Nil -> (a,Nil) @@ -3111,8 +3164,8 @@ -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscList :: [(Key,a)] -> IntMap a -fromAscList xs - = fromAscListWithKey (\_ x _ -> x) xs +fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) +{-# NOINLINE fromAscList #-} -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -3121,8 +3174,8 @@ -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWith f xs - = fromAscListWithKey (\_ x y -> f x y) xs +fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) +{-# NOINLINE fromAscListWith #-} -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -3132,14 +3185,8 @@ -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")] fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWithKey _ [] = Nil -fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq z [] = [z] - combineEq z@(kz,zz) (x@(kx,xx):xs) - | kx==kz = let yy = f kx xx zz in combineEq (kx,yy) xs - | otherwise = z:combineEq x xs +fromAscListWithKey f = fromMonoListWithKey Nondistinct f +{-# NOINLINE fromAscListWithKey #-} -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. @@ -3147,36 +3194,72 @@ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -#if __GLASGOW_HASKELL__ -fromDistinctAscList :: forall a. [(Key,a)] -> IntMap a -#else -fromDistinctAscList :: [(Key,a)] -> IntMap a -#endif -fromDistinctAscList [] = Nil -fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada +fromDistinctAscList :: [(Key,a)] -> IntMap a +fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) +{-# NOINLINE fromDistinctAscList #-} + +-- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys +-- and a combining function. +-- +-- The precise conditions under which this function works are subtle: +-- For any branch mask, keys with the same prefix w.r.t. the branch +-- mask must occur consecutively in the list. + +fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromMonoListWithKey distinct f = go where - work (kx,vx) [] stk = finish kx (Tip kx vx) stk - work (kx,vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk + go [] = Nil + go ((kx,vx) : zs1) = addAll' kx vx zs1 -#if __GLASGOW_HASKELL__ - reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a -#endif - reduce z zs _ px tx Nada = work z zs (Push px tx Nada) - reduce z zs m px tx stk@(Push py ty stk') = - let mxy = branchMask px py - pxy = mask px mxy - in if shorter m mxy - then reduce z zs m pxy (Bin pxy mxy ty tx) stk' - else work z zs (Push px tx stk) + -- `addAll'` collects all keys equal to `kx` into a single value, + -- and then proceeds with `addAll`. + addAll' !kx vx [] + = Tip kx vx + addAll' !kx vx ((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let v = f kx vy vx in addAll' ky v zs + -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs' - finish _ t Nada = t - finish px tx (Push py ty stk) = finish p (link py ty px tx) stk - where m = branchMask px py - p = mask px m + -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` + -- `addAll` consumes the rest of the list, adding to the tree `tx` + addAll !_kx !tx [] + = tx + addAll !kx !tx ((ky,vy) : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' -data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada + -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. + addMany' !_m !kx vx [] + = Inserted (Tip kx vx) [] + addMany' !m !kx vx zs0@((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let v = f kx vy vx in addMany' m ky v zs + -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs) + | mask kx m /= mask ky m + = Inserted (Tip kx vx) zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs' + -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. + addMany !_m !_kx tx [] + = Inserted tx [] + addMany !m !kx tx zs0@((ky,vy) : zs) + | mask kx m /= mask ky m + = Inserted tx zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs' +{-# INLINE fromMonoListWithKey #-} +data Inserted a = Inserted !(IntMap a) ![(Key,a)] + +data Distinct = Distinct | Nondistinct + {-------------------------------------------------------------------- Eq --------------------------------------------------------------------} @@ -3297,13 +3380,17 @@ Link --------------------------------------------------------------------} link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a -link p1 t1 p2 t2 +link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2 +{-# INLINE link #-} + +-- `linkWithMask` is useful when the `branchMask` has already been computed +linkWithMask :: Mask -> Prefix -> IntMap a -> IntMap a -> IntMap a +linkWithMask m p1 t1 {-p2-} t2 | zero p1 m = Bin p m t1 t2 | otherwise = Bin p m t2 t1 where - m = branchMask p1 p2 p = mask p1 m -{-# INLINE link #-} +{-# INLINE linkWithMask #-} {-------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree. diff --git a/src/Data/IntMap/Lazy.hs b/src/Data/IntMap/Lazy.hs --- a/src/Data/IntMap/Lazy.hs +++ b/src/Data/IntMap/Lazy.hs @@ -58,7 +58,7 @@ -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, --- +-- -- -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), @@ -145,6 +145,9 @@ -- ** Disjoint , disjoint + + -- ** Compose + , compose -- ** Universal combining function , mergeWithKey diff --git a/src/Data/IntMap/Strict.hs b/src/Data/IntMap/Strict.hs --- a/src/Data/IntMap/Strict.hs +++ b/src/Data/IntMap/Strict.hs @@ -75,7 +75,7 @@ -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, --- +-- -- -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), @@ -164,6 +164,9 @@ -- ** Disjoint , disjoint + + -- ** Compose + , compose -- ** Universal combining function , mergeWithKey diff --git a/src/Data/IntMap/Strict/Internal.hs b/src/Data/IntMap/Strict/Internal.hs --- a/src/Data/IntMap/Strict/Internal.hs +++ b/src/Data/IntMap/Strict/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} #include "containers.h" @@ -72,7 +73,7 @@ -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, --- +-- -- -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), @@ -162,6 +163,9 @@ -- ** Disjoint , disjoint + -- ** Compose + , compose + -- ** Universal combining function , mergeWithKey @@ -257,11 +261,8 @@ import Data.IntMap.Internal ( IntMap (..) , Key - , Prefix - , Mask , mask , branchMask - , shorter , nomatch , zero , natFromInt @@ -270,6 +271,7 @@ , binCheckLeft , binCheckRight , link + , linkWithMask , (\\) , (!) @@ -717,6 +719,27 @@ = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2 {-------------------------------------------------------------------- + Compose +--------------------------------------------------------------------} +-- | Relate the keys of one map to the values of +-- the other, by using the values of the former as keys for lookups +-- in the latter. +-- +-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument +-- +-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")] +-- +-- @ +-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?') +-- @ +-- +-- @since 0.6.3.1 +compose :: IntMap c -> IntMap Int -> IntMap c +compose bc !ab + | null bc = empty + | otherwise = mapMaybe (bc !?) ab + +{-------------------------------------------------------------------- MergeWithKey --------------------------------------------------------------------} @@ -894,7 +917,9 @@ where go Nil = pure Nil go (Tip k v) = (\ !v' -> Tip k v') <$> f k v - go (Bin p m l r) = liftA2 (Bin p m) (go l) (go r) + go (Bin p m l r) + | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l) + | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} -- | /O(n)/. Traverse keys\/values and collect the 'Just' results. @@ -904,7 +929,9 @@ where go Nil = pure Nil go (Tip k x) = maybe Nil (Tip k $!) <$> f k x - go (Bin p m l r) = liftA2 (bin p m) (go l) (go r) + go (Bin p m l r) + | m < 0 = liftA2 (flip (bin p m)) (go r) (go l) + | otherwise = liftA2 (bin p m) (go l) (go r) -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. @@ -934,22 +961,34 @@ where go f a t = case t of - Bin p m l r -> let (a1 :*: l') = go f a l - (a2 :*: r') = go f a1 r - in (a2 :*: Bin p m l' r') + Bin p m l r + | m < 0 -> + let (a1 :*: r') = go f a r + (a2 :*: l') = go f a1 l + in (a2 :*: Bin p m l' r') + | otherwise -> + let (a1 :*: l') = go f a l + (a2 :*: r') = go f a1 r + in (a2 :*: Bin p m l' r') Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') Nil -> (a :*: Nil) --- | /O(n)/. The function @'mapAccumR'@ threads an accumulating +-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0 where go f a t = case t of - Bin p m l r -> let (a1 :*: r') = go f a r - (a2 :*: l') = go f a1 l - in (a2 :*: Bin p m l' r') + Bin p m l r + | m < 0 -> + let (a1 :*: l') = go f a l + (a2 :*: r') = go f a1 r + in (a2 :*: Bin p m l' r') + | otherwise -> + let (a1 :*: r') = go f a r + (a2 :*: l') = go f a1 l + in (a2 :*: Bin p m l' r') Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') Nil -> (a :*: Nil) @@ -1098,8 +1137,8 @@ -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] fromAscList :: [(Key,a)] -> IntMap a -fromAscList xs - = fromAscListWithKey (\_ x _ -> x) xs +fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) +{-# NOINLINE fromAscList #-} -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -1108,8 +1147,8 @@ -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWith f xs - = fromAscListWithKey (\_ x y -> f x y) xs +fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) +{-# NOINLINE fromAscListWith #-} -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys. @@ -1118,14 +1157,8 @@ -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a -fromAscListWithKey _ [] = Nil -fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq z [] = [z] - combineEq z@(kz,zz) (x@(kx,xx):xs) - | kx==kz = let !yy = f kx xx zz in combineEq (kx,yy) xs - | otherwise = z:combineEq x xs +fromAscListWithKey f = fromMonoListWithKey Nondistinct f +{-# NOINLINE fromAscListWithKey #-} -- | /O(n)/. Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct. @@ -1134,24 +1167,67 @@ -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] fromDistinctAscList :: [(Key,a)] -> IntMap a -fromDistinctAscList [] = Nil -fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada +fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) +{-# NOINLINE fromDistinctAscList #-} + +-- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys +-- and a combining function. +-- +-- The precise conditions under which this function works are subtle: +-- For any branch mask, keys with the same prefix w.r.t. the branch +-- mask must occur consecutively in the list. + +fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a +fromMonoListWithKey distinct f = go where - work (kx,!vx) [] stk = finish kx (Tip kx vx) stk - work (kx,!vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk + go [] = Nil + go ((kx,vx) : zs1) = addAll' kx vx zs1 - reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a - reduce z zs _ px tx Nada = work z zs (Push px tx Nada) - reduce z zs m px tx stk@(Push py ty stk') = - let mxy = branchMask px py - pxy = mask px mxy - in if shorter m mxy - then reduce z zs m pxy (Bin pxy mxy ty tx) stk' - else work z zs (Push px tx stk) + -- `addAll'` collects all keys equal to `kx` into a single value, + -- and then proceeds with `addAll`. + addAll' !kx vx [] + = Tip kx $! vx + addAll' !kx vx ((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let !v = f kx vy vx in addAll' ky v zs + -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs' - finish _ t Nada = t - finish px tx (Push py ty stk) = finish p (link py ty px tx) stk - where m = branchMask px py - p = mask px m + -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` + -- `addAll` consumes the rest of the list, adding to the tree `tx` + addAll !_kx !tx [] + = tx + addAll !kx !tx ((ky,vy) : zs) + | m <- branchMask kx ky + , Inserted ty zs' <- addMany' m ky vy zs + = addAll kx (linkWithMask m ky ty {-kx-} tx) zs' -data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada + -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. + addMany' !_m !kx vx [] + = Inserted (Tip kx $! vx) [] + addMany' !m !kx vx zs0@((ky,vy) : zs) + | Nondistinct <- distinct, kx == ky + = let !v = f kx vy vx in addMany' m ky v zs + -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs) + | mask kx m /= mask ky m + = Inserted (Tip kx $! vx) zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs' + + -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. + addMany !_m !_kx tx [] + = Inserted tx [] + addMany !m !kx tx zs0@((ky,vy) : zs) + | mask kx m /= mask ky m + = Inserted tx zs0 + | mxy <- branchMask kx ky + , Inserted ty zs' <- addMany' mxy ky vy zs + = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs' +{-# INLINE fromMonoListWithKey #-} + +data Inserted a = Inserted !(IntMap a) ![(Key,a)] + +data Distinct = Distinct | Nondistinct diff --git a/src/Data/IntSet.hs b/src/Data/IntSet.hs --- a/src/Data/IntSet.hs +++ b/src/Data/IntSet.hs @@ -47,7 +47,7 @@ -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, --- +-- -- -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), @@ -86,6 +86,9 @@ -- * Deletion , delete + -- * Generalized insertion/deletion + , alterF + -- * Query , member , notMember @@ -115,6 +118,7 @@ -- * Map , IS.map + , mapMonotonic -- * Folds , IS.foldr diff --git a/src/Data/IntSet/Internal.hs b/src/Data/IntSet/Internal.hs --- a/src/Data/IntSet/Internal.hs +++ b/src/Data/IntSet/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} #endif @@ -53,7 +54,7 @@ -- -- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86, --- +-- -- -- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve -- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), @@ -125,6 +126,7 @@ , singleton , insert , delete + , alterF -- * Combine , union @@ -141,6 +143,7 @@ -- * Map , map + , mapMonotonic -- * Folds , foldr @@ -186,6 +189,7 @@ , zero ) where +import Control.Applicative (Const(..)) import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.List as List @@ -210,20 +214,19 @@ import Utils.Containers.Internal.StrictPair #if __GLASGOW_HASKELL__ -import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType) +import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType) +import qualified Data.Data import Text.Read #endif #if __GLASGOW_HASKELL__ -import GHC.Exts (Int(..), build) -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as GHCExts -#endif -import GHC.Exts (indexInt8OffAddr#) +import qualified GHC.Exts #endif import qualified Data.Foldable as Foldable -#if !MIN_VERSION_base(4,8,0) +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (Identity(..)) +#else import Data.Foldable (Foldable()) #endif @@ -310,7 +313,7 @@ dataTypeOf _ = intSetDataType fromListConstr :: Constr -fromListConstr = mkConstr intSetDataType "fromList" [] Prefix +fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix intSetDataType :: DataType intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr] @@ -503,7 +506,43 @@ | otherwise = t deleteBM _ _ Nil = Nil +-- | /O(min(n,W))/. @('alterF' f x s)@ can delete or insert @x@ in @s@ depending +-- on whether it is already present in @s@. +-- +-- In short: +-- +-- @ +-- 'member' x \<$\> 'alterF' f x s = f ('member' x s) +-- @ +-- +-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At". +-- +-- @since 0.6.3.1 +alterF :: Functor f => (Bool -> f Bool) -> Key -> IntSet -> f IntSet +alterF f k s = fmap choose (f member_) + where + member_ = member k s + (inserted, deleted) + | member_ = (s , delete k s) + | otherwise = (insert k s, s ) + + choose True = inserted + choose False = deleted +#ifndef __GLASGOW_HASKELL__ +{-# INLINE alterF #-} +#else +{-# INLINABLE [2] alterF #-} + +{-# RULES +"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s + #-} +#endif + +#if MIN_VERSION_base(4,8,0) +{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> IntSet -> Identity IntSet #-} +#endif + {-------------------------------------------------------------------- Union --------------------------------------------------------------------} @@ -911,6 +950,23 @@ map :: (Key -> Key) -> IntSet -> IntSet map f = fromList . List.map f . toList +-- | /O(n)/. The +-- +-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapMonotonic f s == map f s +-- > where ls = toList s +-- +-- @since 0.6.3.1 + +-- Note that for now the test is insufficient to support any fancier implementation. +mapMonotonic :: (Key -> Key) -> IntSet -> IntSet +mapMonotonic f = fromDistinctAscList . List.map f . toAscList + + {-------------------------------------------------------------------- Fold --------------------------------------------------------------------} @@ -999,7 +1055,7 @@ --------------------------------------------------------------------} #if __GLASGOW_HASKELL__ >= 708 -- | @since 0.5.6.2 -instance GHCExts.IsList IntSet where +instance GHC.Exts.IsList IntSet where type Item IntSet = Key fromList = fromList toList = toList @@ -1043,9 +1099,9 @@ -- before phase 0, otherwise the fusion rules would not fire at all. {-# NOINLINE[0] toAscList #-} {-# NOINLINE[0] toDescList #-} -{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-} +{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-} {-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-} -{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} +{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} {-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} #endif @@ -1060,41 +1116,74 @@ -- | /O(n)/. Build a set from an ascending list of elements. -- /The precondition (input list is ascending) is not checked./ fromAscList :: [Key] -> IntSet -fromAscList [] = Nil -fromAscList (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0) - where - combineEq x' [] = [x'] - combineEq x' (x:xs) - | x==x' = combineEq x' xs - | otherwise = x' : combineEq x xs +fromAscList = fromMonoList +{-# NOINLINE fromAscList #-} -- | /O(n)/. Build a set from an ascending list of distinct elements. -- /The precondition (input list is strictly ascending) is not checked./ fromDistinctAscList :: [Key] -> IntSet -fromDistinctAscList [] = Nil -fromDistinctAscList (z0 : zs0) = work (prefixOf z0) (bitmapOf z0) zs0 Nada +fromDistinctAscList = fromAscList +{-# INLINE fromDistinctAscList #-} + +-- | /O(n)/. Build a set from a monotonic list of elements. +-- +-- The precise conditions under which this function works are subtle: +-- For any branch mask, keys with the same prefix w.r.t. the branch +-- mask must occur consecutively in the list. +fromMonoList :: [Key] -> IntSet +fromMonoList [] = Nil +fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1 where - -- 'work' accumulates all values that go into one tip, before passing this Tip - -- to 'reduce' - work kx bm [] stk = finish kx (Tip kx bm) stk - work kx bm (z:zs) stk | kx == prefixOf z = work kx (bm .|. bitmapOf z) zs stk - work kx bm (z:zs) stk = reduce z zs (branchMask z kx) kx (Tip kx bm) stk + -- `addAll'` collects all keys with the prefix `px` into a single + -- bitmap, and then proceeds with `addAll`. + addAll' !px !bm [] + = Tip px bm + addAll' !px !bm (ky : zs) + | px == prefixOf ky + = addAll' px (bm .|. bitmapOf ky) zs + -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs) + | py <- prefixOf ky + , m <- branchMask px py + , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs + = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs' - reduce z zs _ px tx Nada = work (prefixOf z) (bitmapOf z) zs (Push px tx Nada) - reduce z zs m px tx stk@(Push py ty stk') = - let mxy = branchMask px py - pxy = mask px mxy - in if shorter m mxy - then reduce z zs m pxy (Bin pxy mxy ty tx) stk' - else work (prefixOf z) (bitmapOf z) zs (Push px tx stk) + -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx` + -- `addAll` consumes the rest of the list, adding to the tree `tx` + addAll !_px !tx [] + = tx + addAll !px !tx (ky : zs) + | py <- prefixOf ky + , m <- branchMask px py + , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs + = addAll px (linkWithMask m py ty {-px-} tx) zs' - finish _ t Nada = t - finish px tx (Push py ty stk) = finish p (link py ty px tx) stk - where m = branchMask px py - p = mask px m + -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`. + addMany' !_m !px !bm [] + = Inserted (Tip px bm) [] + addMany' !m !px !bm zs0@(ky : zs) + | px == prefixOf ky + = addMany' m px (bm .|. bitmapOf ky) zs + -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs) + | mask px m /= mask ky m + = Inserted (Tip (prefixOf px) bm) zs0 + | py <- prefixOf ky + , mxy <- branchMask px py + , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs + = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs' -data Stack = Push {-# UNPACK #-} !Prefix !IntSet !Stack | Nada + -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`. + addMany !_m !_px tx [] + = Inserted tx [] + addMany !m !px tx zs0@(ky : zs) + | mask px m /= mask ky m + = Inserted tx zs0 + | py <- prefixOf ky + , mxy <- branchMask px py + , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs + = addMany m px (linkWithMask mxy py ty {-px-} tx) zs' +{-# INLINE fromMonoList #-} +data Inserted = Inserted !IntSet ![Key] {-------------------------------------------------------------------- Eq @@ -1124,9 +1213,157 @@ --------------------------------------------------------------------} instance Ord IntSet where - compare s1 s2 = compare (toAscList s1) (toAscList s2) - -- tentative implementation. See if more efficient exists. + compare Nil Nil = EQ + compare Nil _ = LT + compare _ Nil = GT + compare t1@(Tip _ _) t2@(Tip _ _) + = orderingOf $ relateTipTip t1 t2 + compare xs ys + | (xsNeg, xsNonNeg) <- splitSign xs + , (ysNeg, ysNonNeg) <- splitSign ys + = case relate xsNeg ysNeg of + Less -> LT + Prefix -> if null xsNonNeg then LT else GT + Equals -> orderingOf (relate xsNonNeg ysNonNeg) + FlipPrefix -> if null ysNonNeg then GT else LT + Greater -> GT +-- | detailed outcome of lexicographic comparison of lists. +-- w.r.t. Ordering, there are two extra cases, +-- since (++) is not monotonic w.r.t. lex. order on lists +-- (which is used by definition): +-- consider comparison of (Bin [0,3,4] [ 6] ) to (Bin [0,3] [7] ) +-- where [0,3,4] > [0,3] but [0,3,4,6] < [0,3,7]. + +data Relation + = Less -- ^ holds for [0,3,4] [0,3,5,1] + | Prefix -- ^ holds for [0,3,4] [0,3,4,5] + | Equals -- ^ holds for [0,3,4] [0,3,4] + | FlipPrefix -- ^ holds for [0,3,4] [0,3] + | Greater -- ^ holds for [0,3,4] [0,2,5] + deriving (Show, Eq) + +orderingOf :: Relation -> Ordering +{-# INLINE orderingOf #-} +orderingOf r = case r of + Less -> LT + Prefix -> LT + Equals -> EQ + FlipPrefix -> GT + Greater -> GT + +-- | precondition: each argument is non-mixed +relate :: IntSet -> IntSet -> Relation +relate Nil Nil = Equals +relate Nil _t2 = Prefix +relate _t1 Nil = FlipPrefix +relate t1@Tip{} t2@Tip{} = relateTipTip t1 t2 +relate t1@(Bin _p1 m1 l1 r1) t2@(Bin _p2 m2 l2 r2) + | succUpperbound t1 <= lowerbound t2 = Less + | lowerbound t1 >= succUpperbound t2 = Greater + | otherwise = case compare (natFromInt m1) (natFromInt m2) of + GT -> combine_left (relate l1 t2) + EQ -> combine (relate l1 l2) (relate r1 r2) + LT -> combine_right (relate t1 l2) +relate t1@(Bin _p1 m1 l1 _r1) t2@(Tip p2 _bm2) + | succUpperbound t1 <= lowerbound t2 = Less + | lowerbound t1 >= succUpperbound t2 = Greater + | 0 == (m1 .&. p2) = combine_left (relate l1 t2) + | otherwise = Less +relate t1@(Tip p1 _bm1) t2@(Bin _p2 m2 l2 _r2) + | succUpperbound t1 <= lowerbound t2 = Less + | lowerbound t1 >= succUpperbound t2 = Greater + | 0 == (p1 .&. m2) = combine_right (relate t1 l2) + | otherwise = Greater + +relateTipTip :: IntSet -> IntSet -> Relation +{-# INLINE relateTipTip #-} +relateTipTip (Tip p1 bm1) (Tip p2 bm2) = case compare p1 p2 of + LT -> Less + EQ -> relateBM bm1 bm2 + GT -> Greater +relateTipTip _ _ = error "relateTipTip" + +relateBM :: BitMap -> BitMap -> Relation +{-# inline relateBM #-} +relateBM w1 w2 | w1 == w2 = Equals +relateBM w1 w2 = + let delta = xor w1 w2 + lowest_diff_mask = delta .&. complement (delta-1) + prefix = (complement lowest_diff_mask + 1) + .&. (complement lowest_diff_mask) + in if 0 == lowest_diff_mask .&. w1 + then if 0 == w1 .&. prefix + then Prefix else Greater + else if 0 == w2 .&. prefix + then FlipPrefix else Less + +-- | This function has the property +-- relate t1@(Bin p m l1 r1) t2@(Bin p m l2 r2) = combine (relate l1 l2) (relate r1 r2) +-- It is important that `combine` is lazy in the second argument (achieved by inlining) +combine :: Relation -> Relation -> Relation +{-# inline combine #-} +combine r eq = case r of + Less -> Less + Prefix -> Greater + Equals -> eq + FlipPrefix -> Less + Greater -> Greater + +-- | This function has the property +-- relate t1@(Bin p1 m1 l1 r1) t2 = combine_left (relate l1 t2) +-- under the precondition that the range of l1 contains the range of t2, +-- and r1 is non-empty +combine_left :: Relation -> Relation +{-# inline combine_left #-} +combine_left r = case r of + Less -> Less + Prefix -> Greater + Equals -> FlipPrefix + FlipPrefix -> FlipPrefix + Greater -> Greater + +-- | This function has the property +-- relate t1 t2@(Bin p2 m2 l2 r2) = combine_right (relate t1 l2) +-- under the precondition that the range of t1 is included in the range of l2, +-- and r2 is non-empty +combine_right :: Relation -> Relation +{-# inline combine_right #-} +combine_right r = case r of + Less -> Less + Prefix -> Prefix + Equals -> Prefix + FlipPrefix -> Less + Greater -> Greater + +-- | shall only be applied to non-mixed non-Nil trees +lowerbound :: IntSet -> Int +{-# INLINE lowerbound #-} +lowerbound Nil = error "lowerbound: Nil" +lowerbound (Tip p _) = p +lowerbound (Bin p _ _ _) = p + +-- | this is one more than the actual upper bound (to save one operation) +-- shall only be applied to non-mixed non-Nil trees +succUpperbound :: IntSet -> Int +{-# INLINE succUpperbound #-} +succUpperbound Nil = error "succUpperbound: Nil" +succUpperbound (Tip p _) = p + wordSize +succUpperbound (Bin p m _ _) = p + shiftR m 1 + +-- | split a set into subsets of negative and non-negative elements +splitSign :: IntSet -> (IntSet,IntSet) +{-# INLINE splitSign #-} +splitSign t@(Tip kx _) + | kx >= 0 = (Nil, t) + | otherwise = (t, Nil) +splitSign t@(Bin p m l r) + -- m < 0 is the usual way to find out if we have positives and negatives (see findMax) + | m < 0 = (r, l) + | p < 0 = (t, Nil) + | otherwise = (Nil, t) +splitSign Nil = (Nil, Nil) + {-------------------------------------------------------------------- Show --------------------------------------------------------------------} @@ -1249,13 +1486,17 @@ Link --------------------------------------------------------------------} link :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet -link p1 t1 p2 t2 +link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2 +{-# INLINE link #-} + +-- `linkWithMask` is useful when the `branchMask` has already been computed +linkWithMask :: Mask -> Prefix -> IntSet -> IntSet -> IntSet +linkWithMask m p1 t1 {-p2-} t2 | zero p1 m = Bin p m t1 t2 | otherwise = Bin p m t2 t1 where - m = branchMask p1 p2 p = mask p1 m -{-# INLINE link #-} +{-# INLINE linkWithMask #-} {-------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree. @@ -1377,6 +1618,16 @@ {-# INLINE foldr'Bits #-} #if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64) +indexOfTheOnlyBit :: Nat -> Int +{-# INLINE indexOfTheOnlyBit #-} +#if MIN_VERSION_base(4,8,0) && (WORD_SIZE_IN_BITS==64) +indexOfTheOnlyBit bitmask = countTrailingZeros bitmask + +lowestBitSet x = countTrailingZeros x + +highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x + +#else {---------------------------------------------------------------------- For lowestBitSet we use wordsize-dependant implementation based on multiplication and DeBrujn indeces, which was proposed by Edward Kmett @@ -1390,11 +1641,9 @@ before changing this code. ----------------------------------------------------------------------} -indexOfTheOnlyBit :: Nat -> Int -{-# INLINE indexOfTheOnlyBit #-} indexOfTheOnlyBit bitmask = - I# (lsbArray `indexInt8OffAddr#` unboxInt (intFromNat ((bitmask * magic) `shiftRL` offset))) - where unboxInt (I# i) = i + GHC.Exts.I# (lsbArray `GHC.Exts.indexInt8OffAddr#` unboxInt (intFromNat ((bitmask * magic) `shiftRL` offset))) + where unboxInt (GHC.Exts.I# i) = i #if WORD_SIZE_IN_BITS==32 magic = 0x077CB531 offset = 27 @@ -1411,6 +1660,12 @@ -- is 48B on 32-bit and 56B on 64-bit architectures -- so the 32B and 64B array -- is actually improvement on 32-bit and only a 8B size increase on 64-bit. +lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x) + +highestBitSet x = indexOfTheOnlyBit (highestBitMask x) + +#endif + lowestBitMask :: Nat -> Nat lowestBitMask x = x .&. negate x {-# INLINE lowestBitMask #-} @@ -1431,10 +1686,6 @@ x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32); #endif - -lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x) - -highestBitSet x = indexOfTheOnlyBit (highestBitMask x) foldlBits prefix f z bitmap = go bitmap z where go 0 acc = acc diff --git a/src/Data/Map/Internal.hs b/src/Data/Map/Internal.hs --- a/src/Data/Map/Internal.hs +++ b/src/Data/Map/Internal.hs @@ -192,6 +192,9 @@ -- ** Disjoint , disjoint + -- ** Compose + , compose + -- ** General combining function , SimpleWhenMissing , SimpleWhenMatched @@ -391,6 +394,9 @@ #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable()) #endif +#if MIN_VERSION_base(4,10,0) +import Data.Bifoldable +#endif import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop) @@ -1628,7 +1634,7 @@ -- | /O(log n)/. The minimal key of the map. Returns 'Nothing' if the map is empty. -- -- > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b") --- > findMin empty = Nothing +-- > lookupMin empty = Nothing -- -- @since 0.5.9 @@ -2085,6 +2091,27 @@ where (lt,found,gt) = splitMember k t +{-------------------------------------------------------------------- + Compose +--------------------------------------------------------------------} +-- | Relate the keys of one map to the values of +-- the other, by using the values of the former as keys for lookups +-- in the latter. +-- +-- Complexity: \( O (n * \log(m)) \), where \(m\) is the size of the first argument +-- +-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")] +-- +-- @ +-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?') +-- @ +-- +-- @since 0.6.3.1 +compose :: Ord b => Map b c -> Map a b -> Map a c +compose bc !ab + | null bc = empty + | otherwise = mapMaybe (bc !?) ab + #if !MIN_VERSION_base (4,8,0) -- | The identity type. newtype Identity a = Identity { runIdentity :: a } @@ -2830,7 +2857,7 @@ {- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when - @m1@ and @m2@ are not equal, + @keys m1@ and @keys m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when applied to their respective values. For example, the following expressions are all 'True': @@ -3147,7 +3174,7 @@ (a3,r') = mapAccumL f a2 r in (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumR' threads an accumulating +-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip) @@ -3949,7 +3976,7 @@ -- | /O(log n)/. Delete and find the minimal element. -- -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) --- > deleteFindMin Error: can not return the minimal element of an empty map +-- > deleteFindMin empty Error: can not return the minimal element of an empty map deleteFindMin :: Map k a -> ((k,a),Map k a) deleteFindMin t = case minViewWithKey t of @@ -4254,6 +4281,29 @@ {-# INLINABLE sum #-} product = foldl' (*) 1 {-# INLINABLE product #-} +#endif + +#if MIN_VERSION_base(4,10,0) +-- | @since 0.6.3.1 +instance Bifoldable Map where + bifold = go + where go Tip = mempty + go (Bin 1 k v _ _) = k `mappend` v + go (Bin _ k v l r) = go l `mappend` (k `mappend` (v `mappend` go r)) + {-# INLINABLE bifold #-} + bifoldr f g z = go z + where go z' Tip = z' + go z' (Bin _ k v l r) = go (f k (g v (go z' r))) l + {-# INLINE bifoldr #-} + bifoldl f g z = go z + where go z' Tip = z' + go z' (Bin _ k v l r) = go (g (f (go z' l) k) v) r + {-# INLINE bifoldl #-} + bifoldMap f g t = go t + where go Tip = mempty + go (Bin 1 k v _ _) = f k `mappend` g v + go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r)) + {-# INLINE bifoldMap #-} #endif instance (NFData k, NFData a) => NFData (Map k a) where diff --git a/src/Data/Map/Lazy.hs b/src/Data/Map/Lazy.hs --- a/src/Data/Map/Lazy.hs +++ b/src/Data/Map/Lazy.hs @@ -166,6 +166,9 @@ -- ** Disjoint , disjoint + -- ** Compose + , compose + -- ** General combining functions -- | See "Data.Map.Merge.Lazy" diff --git a/src/Data/Map/Strict.hs b/src/Data/Map/Strict.hs --- a/src/Data/Map/Strict.hs +++ b/src/Data/Map/Strict.hs @@ -182,6 +182,9 @@ -- ** Disjoint , disjoint + -- ** Compose + , compose + -- ** General combining functions -- | See "Data.Map.Merge.Strict" diff --git a/src/Data/Map/Strict/Internal.hs b/src/Data/Map/Strict/Internal.hs --- a/src/Data/Map/Strict/Internal.hs +++ b/src/Data/Map/Strict/Internal.hs @@ -145,6 +145,9 @@ -- ** Disjoint , disjoint + -- ** Compose + , compose + -- ** General combining function , SimpleWhenMissing , SimpleWhenMatched @@ -1201,6 +1204,27 @@ {-# INLINE forceMaybe #-} {-------------------------------------------------------------------- + Compose +--------------------------------------------------------------------} +-- | Relate the keys of one map to the values of +-- the other, by using the values of the former as keys for lookups +-- in the latter. +-- +-- Complexity: \( O (n * \log(m)) \), where \(m\) is the size of the first argument +-- +-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")] +-- +-- @ +-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?') +-- @ +-- +-- @since 0.6.3.1 +compose :: Ord b => Map b c -> Map a b -> Map a c +compose bc !ab + | null bc = empty + | otherwise = mapMaybe (bc !?) ab + +{-------------------------------------------------------------------- MergeWithKey --------------------------------------------------------------------} @@ -1432,7 +1456,7 @@ (a3,r') = mapAccumL f a2 r in x' `seq` (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumR' threads an accumulating +-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip) diff --git a/src/Data/Sequence.hs b/src/Data/Sequence.hs --- a/src/Data/Sequence.hs +++ b/src/Data/Sequence.hs @@ -102,9 +102,15 @@ -- -- Several functions take special advantage of sharing to produce -- results using much less time and memory than one might expect. These --- are documented individually for functions, but also include the --- methods '<$' and '*>', each of which take time and space proportional --- to the logarithm of the size of the result. +-- are documented individually for functions, but also include certain +-- class methods: +-- +-- '<$' and '*>' each take time and space proportional +-- to the logarithm of the size of their result. +-- +-- '<*' takes time and space proportional to the product of the length +-- of its first argument and the logarithm of the length of its second +-- argument. -- -- == Warning -- diff --git a/src/Data/Sequence/Internal.hs b/src/Data/Sequence/Internal.hs --- a/src/Data/Sequence/Internal.hs +++ b/src/Data/Sequence/Internal.hs @@ -514,6 +514,7 @@ #if MIN_VERSION_base(4,10,0) liftA2 = liftA2Seq #endif + xs <* ys = beforeSeq xs ys apSeq :: Seq (a -> b) -> Seq a -> Seq b apSeq fs xs@(Seq xsFT) = case viewl fs of @@ -530,7 +531,7 @@ RigidFull r@(Rigid s pr _m sf) -> Seq $ Deep (s * length fs) (fmap (fmap firstf) (nodeToDigit pr)) - (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r) + (liftA2Middle (fmap firstf) (fmap lastf) fmap fs''FT r) (fmap (fmap lastf) (nodeToDigit sf)) {-# NOINLINE [1] apSeq #-} @@ -590,7 +591,7 @@ RigidFull r@(Rigid s pr _m sf) -> Seq $ Deep (s * length xs) (fmap (fmap (f firstx)) (nodeToDigit pr)) - (aptyMiddle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r) + (liftA2Middle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r) (fmap (fmap (f lastx)) (nodeToDigit sf)) where lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c @@ -637,65 +638,128 @@ -- digit of a 'Rigid' tree. type Digit23 a = Node a --- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@. It +-- | 'liftA2Middle' does most of the hard work of computing @liftA2 f xs ys@. It -- produces the center part of a finger tree, with a prefix corresponding to --- the prefix of @xs@ and a suffix corresponding to the suffix of @xs@ omitted; +-- the first element of @xs@ and a suffix corresponding to its last element omitted; -- the missing suffix and prefix are added by the caller. For the recursive -- call, it squashes the prefix and the suffix into the center tree. Once it -- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to -- produce the main body, and glues all the pieces together. -- --- @map23@ itself is a bit horrifying because of the nested types involved. Its +-- @f@ itself is a bit horrifying because of the nested types involved. Its -- job is to map over the *elements* of a 2-3 tree, rather than the subtrees. -- If we used a higher-order nested type with MPTC, we could probably use a --- class, but as it is we have to build up @map23@ explicitly through the +-- class, but as it is we have to build up @f@ explicitly through the -- recursion. -aptyMiddle - :: (b -> c) - -> (b -> c) - -> (a -> b -> c) - -> FingerTree (Elem a) - -> Rigid b - -> FingerTree (Node c) +-- +-- === Description of parameters +-- +-- ==== Types +-- +-- @a@ remains constant through recursive calls (in the @DeepTh@ case), +-- while @b@ and @c@ do not: 'liftAMiddle' calls itself at types @Node b@ and +-- @Node c@. +-- +-- ==== Values +-- +-- 'liftA2Middle' is used when the original @xs :: Sequence a@ has at +-- least two elements, so it can be decomposed by taking off the first and last +-- elements: +-- +-- > xs = firstx <: midxs :> lastx +-- +-- - the first two arguments @ffirstx, flastx :: b -> c@ are equal to +-- @f firstx@ and @f lastx@, where @f :: a -> b -> c@ is the third argument. +-- This ensures sharing when @f@ computes some data upon being partially +-- applied to its first argument. The way @f@ gets accumulated also ensures +-- sharing for the middle section. +-- +-- - the fourth argument is the middle part @midxs@, always constant. +-- +-- - the last argument, a tuple of type @Rigid b@, holds all the elements of +-- @ys@, in three parts: a middle part around which the recursion is +-- structured, surrounded by a prefix and a suffix that accumulate +-- elements on the side as we walk down the middle. +-- +-- === Invariants +-- +-- > 1. Viewing the various trees as the lists they represent +-- > (the types of the toList functions are given a few paragraphs below): +-- > +-- > toListFTN result +-- > = (ffirstx <$> (toListThinN m ++ toListD sf)) +-- > ++ (f <$> toListFTE midxs <*> (toListD pr ++ toListThinN m ++ toListD sf)) +-- > ++ (flastx <$> (toListD pr ++ toListThinN m)) +-- > +-- > 2. s = size m + size pr + size sf +-- > +-- > 3. size (ffirstx y) = size (flastx y) = size (f x y) = size y +-- > for any (x :: a) (y :: b) +-- +-- Projecting invariant 1 on sizes, using 2 and 3 to simplify, we have the +-- following corollary. +-- It is weaker than invariant 1, but it may be easier to keep track of. +-- +-- > 1a. size result = s * (size midxs + 1) + size m +-- +-- In invariant 1, the types of the auxiliary functions are as follows +-- for reference: +-- +-- > toListFTE :: FingerTree (Elem a) -> [a] +-- > toListFTN :: FingerTree (Node c) -> [c] +-- > toListThinN :: Thin (Node b) -> [b] +-- > toListD :: Digit12 b -> [b] +liftA2Middle + :: (b -> c) -- ^ @ffirstx@ + -> (b -> c) -- ^ @flastx@ + -> (a -> b -> c) -- ^ @f@ + -> FingerTree (Elem a) -- ^ @midxs@ + -> Rigid b -- ^ @Rigid s pr m sf@ (@pr@: prefix, @sf@: suffix) + -> FingerTree (Node c) -- Not at the bottom yet -aptyMiddle firstf - lastf - map23 - fs - (Rigid s pr (DeepTh sm prm mm sfm) sf) - = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf - (fmap (fmap firstf) (digit12ToDigit prm)) - (aptyMiddle (fmap firstf) - (fmap lastf) - (fmap . map23) - fs - (Rigid s (squashL pr prm) mm (squashR sfm sf))) - (fmap (fmap lastf) (digit12ToDigit sfm)) +liftA2Middle + ffirstx + flastx + f + midxs + (Rigid s pr (DeepTh sm prm mm sfm) sf) + -- note: size (DeepTh sm pr mm sfm) = sm = size pr + size mm + size sfm + = Deep (sm + s * (size midxs + 1)) -- note: sm = s - size pr - size sf + (fmap (fmap ffirstx) (digit12ToDigit prm)) + (liftA2Middle + (fmap ffirstx) + (fmap flastx) + (fmap . f) + midxs + (Rigid s (squashL pr prm) mm (squashR sfm sf))) + (fmap (fmap flastx) (digit12ToDigit sfm)) -- At the bottom -aptyMiddle firstf - lastf - map23 - fs - (Rigid s pr EmptyTh sf) - = deep - (One (fmap firstf sf)) - (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs) - (One (fmap lastf pr)) +liftA2Middle + ffirstx + flastx + f + midxs + (Rigid s pr EmptyTh sf) + = deep + (One (fmap ffirstx sf)) + (mapMulFT s (\(Elem x) -> fmap (fmap (f x)) converted) midxs) + (One (fmap flastx pr)) where converted = node2 pr sf -aptyMiddle firstf - lastf - map23 - fs - (Rigid s pr (SingleTh q) sf) - = deep - (Two (fmap firstf q) (fmap firstf sf)) - (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs) - (Two (fmap lastf pr) (fmap lastf q)) +liftA2Middle + ffirstx + flastx + f + midxs + (Rigid s pr (SingleTh q) sf) + = deep + (Two (fmap ffirstx q) (fmap ffirstx sf)) + (mapMulFT s (\(Elem x) -> fmap (fmap (f x)) converted) midxs) + (Two (fmap flastx pr) (fmap flastx q)) where converted = node3 pr q sf digit12ToDigit :: Digit12 a -> Digit a @@ -721,7 +785,7 @@ -- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations -- match up properly. mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b -mapMulFT _ _ EmptyT = EmptyT +mapMulFT !_ _ EmptyT = EmptyT mapMulFT _mul f (Single a) = Single (f a) mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf) @@ -885,7 +949,11 @@ instance Monoid (Seq a) where mempty = empty +#if MIN_VERSION_base(4,9,0) + mappend = (Semigroup.<>) +#else mappend = (><) +#endif #if MIN_VERSION_base(4,9,0) -- | @since 0.5.7 @@ -1375,6 +1443,240 @@ three = liftA3 Three m m m deepA = liftA3 (Deep (n * mSize)) emptyTree = pure EmptyT + +data RCountMid a = RCountMid + !(Node a) -- End of the first + !Int -- Number of units in the middle + !(Node a) -- Beginning of the last + +{- +We could generalize beforeSeq quite easily to + + beforeSeq :: (a -> c) -> Seq a -> Seq b -> Seq c + +This would let us add a rewrite rule + + fmap f xs <* ys ==> beforeSeq f xs ys + +We don't currently bother because I don't yet know of a practical use for (<*) +for sequences; a rewrite rule to optimize it seems like extreme overkill. +-} + +beforeSeq :: Seq a -> Seq b -> Seq a +beforeSeq xs ys = replicateEach (length ys) xs + +-- | Replicate each element of a sequence the given number of times. +-- +-- @replicateEach 3 [1,2] = [1,1,1,2,2,2]@ +-- @replicateEach n xs = xs >>= replicate n@ +replicateEach :: Int -> Seq a -> Seq a +-- The main idea is that we construct a function that takes an element and +-- produces a 2-3 tree representing that element replicated lenys times. We map +-- that function over the sequence to (mostly) produce the desired fingertree. But +-- if we *just* did that, we'd end up with a fingertree of 2-3 trees of the given +-- size, not of elements. So we need to work our way down to the appropriate +-- level by building the left side of the fingertree corresponding to the first +-- 2-3 tree and the right side corresponding to the last one, along with the +-- 2-3 trees corresponding to the right side of the first and the left side of +-- the last. +replicateEach lenys xs = case viewl xs of + EmptyL -> empty + firstx :< xs' -> case viewr xs' of + EmptyR -> replicate lenys firstx + Seq midxs :> lastx -> case lenys of + 0 -> empty + 1 -> xs + 2 -> + Seq $ rep2EachFT fxE midxs lxE + 3 -> + Seq $ rep3EachFT fxE midxs lxE + _ -> Seq $ case lenys `quotRem` 3 of -- lenys > 3 + (q,0) -> Deep (lenys * length xs) fd3 + (repEachMiddle_ lift_elem (RCountMid fn3 (q - 2) ln3)) + ld3 + where + lift_elem a = let n3a = n3 a in (n3a, n3a, n3a) + (q,1) -> Deep (lenys * length xs) fd2 + (repEachMiddle_ lift_elem (RCountMid fn2 (q - 1) ln2)) + ld2 + where + lift_elem a = let n2a = n2 a in (n2a, n3 a, n2a) + (q,_) -> Deep (lenys * length xs) fd3 + (repEachMiddle_ lift_elem (RCountMid fn2 (q - 1) ln3)) + ld2 + where + lift_elem a = let n3a = n3 a in (n3a, n3a, n2 a) + where + repEachMiddle_ = repEachMiddle midxs lenys 3 fn3 ln3 + fd2 = Two fxE fxE + fd3 = Three fxE fxE fxE + ld2 = Two lxE lxE + ld3 = Three lxE lxE lxE + fn2 = Node2 2 fxE fxE + fn3 = Node3 3 fxE fxE fxE + ln2 = Node2 2 lxE lxE + ln3 = Node3 3 lxE lxE lxE + n3 a = Node3 3 (Elem a) (Elem a) (Elem a) + n2 a = Node2 2 (Elem a) (Elem a) + where + fxE = Elem firstx + lxE = Elem lastx + +rep2EachFT :: Elem a -> FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) +rep2EachFT firstx xs lastx = + Deep (size xs * 2 + 4) + (Two firstx firstx) + (mapMulFT 2 (\ex -> Node2 2 ex ex) xs) + (Two lastx lastx) + +rep3EachFT :: Elem a -> FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) +rep3EachFT firstx xs lastx = + Deep (size xs * 3 + 6) + (Three firstx firstx firstx) + (mapMulFT 3 (\ex -> Node3 3 ex ex ex) xs) + (Three lastx lastx lastx) + +-- Invariants for repEachMiddle: +-- +-- 1. midxs is constant: the middle bit in the original sequence (xs = (first <: Seq midxs :> last)) +-- 2. lenys is constant: the length of ys +-- 3. firstx and pr repeat the same element: the first one in the original sequence xs +-- 4. lastx and sf repeat the same element: the last one in the original sequence xs +-- 5. sizec = size firstx = size lastx +-- 6. lenys = deep_count * sizec + size pr + size pf +-- 7. let (lft, fill, rght) = fill23 x, for any x: +-- 7a. All three sequences repeat the element x +-- 7b. size fill = sizec +-- 7c. size lft = size sf +-- 7d. size rght = size pr +-- 8. size result = deep_count * sizec + lenys * (size midxs + 1) +repEachMiddle + :: FingerTree (Elem a) -- midxs + -> Int -- lenys + -> Int -- sizec + -> Node c -- firstx + -> Node c -- lastx + -> (a -> (Node c, Node c, Node c)) -- fill23 + -> RCountMid c -- (RCountMid pr deep_count sf) + -> FingerTree (Node c) -- result + +-- At the bottom + +repEachMiddle midxs lenys + !_sizec + _firstx + _lastx + fill23 + (RCountMid pr 0 sf) + = Deep (lenys * (size midxs + 1)) + (One pr) + (mapMulFT lenys fill23_final midxs) + (One sf) + where + -- fill23_final :: Elem a -> Node (Node c) + fill23_final (Elem a) = case fill23 a of + -- See the note on lift_fill23 for an explanation of this + -- lazy pattern. + ~(lft, _fill, rght) -> Node2 (size pr + size sf) lft rght + +repEachMiddle midxs lenys + !sizec + firstx + lastx + fill23 + (RCountMid pr 1 sf) + = Deep (sizec + lenys * (size midxs + 1)) + (Two pr firstx) + (mapMulFT lenys fill23_final midxs) + (Two lastx sf) + where + -- fill23_final :: Elem a -> Node (Node c) + fill23_final (Elem a) = case fill23 a of + -- See the note on lift_fill23 for an explanation of this + -- lazy pattern. + ~(lft, fill, rght) -> Node3 (size pr + size sf + sizec) lft fill rght + +-- Not at the bottom yet + +repEachMiddle midxs lenys + !sizec + firstx + lastx + fill23 + (RCountMid pr deep_count sf) -- deep_count > 1 + = case deep_count `quotRem` 3 of + (q,0) + -> deep' + (Two firstx firstx) + (repEachMiddle_ + (lift_fill23 TOT3 TOT2 fill23) + (RCountMid pr' (q - 1) sf')) + (One lastx) + where + pr' = node2 firstx pr + sf' = node3 lastx lastx sf + (q,1) + -> deep' + (Two firstx firstx) + (repEachMiddle_ + (lift_fill23 TOT3 TOT3 fill23) + (RCountMid pr' (q - 1) sf')) + (Two lastx lastx) + where + pr' = node3 firstx firstx pr + sf' = node3 lastx lastx sf + (q,_) -- the remainder is 2 + -> deep' + (One firstx) + (repEachMiddle_ + (lift_fill23 TOT2 TOT2 fill23) + (RCountMid pr' q sf')) + (One lastx) + where + pr' = node2 firstx pr + sf' = node2 lastx sf + + where + deep' = Deep (deep_count * sizec + lenys * (size midxs + 1)) + repEachMiddle_ = repEachMiddle midxs lenys sizec' fn3 ln3 + sizec' = 3 * sizec + fn3 = Node3 sizec' firstx firstx firstx + ln3 = Node3 sizec' lastx lastx lastx + spr = size pr + ssf = size sf + lift_fill23 + :: TwoOrThree + -> TwoOrThree + -> (a -> (b, b, b)) + -> a -> (Node b, Node b, Node b) + lift_fill23 !tl !tr f a = (lft', fill', rght') + where + -- We use a strict pattern match on the recursive call. This means + -- that we build the 2-3 trees from the *bottom up* instead of from the + -- *top down*. We do it this way for two reasons: + -- + -- 1. The trees are never very deep, so we don't get much locality + -- benefit from building them lazily. + -- + -- 2. Building the trees lazily would require us to build four thunks + -- at each level of each tree, which seems just a bit pricy. + -- + -- Does this break the incremental optimality? I don't believe it does. + -- As far as I can tell, each sequence operation that inspects one of + -- these trees either inspects only its root (to get its size for + -- indexing purposes) or descends all the way to the bottom. So we're + -- strict here, and lazy in the construction of + -- the root in fill23_final. + !(lft, fill, rght) = f a + !fill' = Node3 (3 * sizec) fill fill fill + !lft' = case tl of + TOT2 -> Node2 (ssf + sizec) lft fill + TOT3 -> Node3 (ssf + 2 * sizec) lft fill fill + !rght' = case tr of + TOT2 -> Node2 (spr + sizec) rght fill + TOT3 -> Node3 (spr + 2 * sizec) rght fill fill + +data TwoOrThree = TOT2 | TOT3 ------------------------------------------------------------------------ -- Construction diff --git a/src/Data/Sequence/Internal/Sorting.hs b/src/Data/Sequence/Internal/Sorting.hs --- a/src/Data/Sequence/Internal/Sorting.hs +++ b/src/Data/Sequence/Internal/Sorting.hs @@ -394,7 +394,6 @@ pr' = foldDigit (<+>) f pr sf' = foldDigit (<+>) f sf m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m -{-# INLINE foldToMaybeTree #-} -- | A 'Data.Sequence.foldMapWithIndex'-like function, specialized to the -- 'Data.Semigroup.Option' monoid, which takes advantage of the diff --git a/src/Data/Set.hs b/src/Data/Set.hs --- a/src/Data/Set.hs +++ b/src/Data/Set.hs @@ -88,6 +88,10 @@ -- * Deletion , delete + -- * Generalized insertion/deletion + + , alterF + -- * Query , member , notMember diff --git a/src/Data/Set/Internal.hs b/src/Data/Set/Internal.hs --- a/src/Data/Set/Internal.hs +++ b/src/Data/Set/Internal.hs @@ -148,6 +148,7 @@ , singleton , insert , delete + , alterF , powerSet -- * Combine @@ -230,6 +231,7 @@ ) where import Prelude hiding (filter,foldl,foldr,null,map,take,drop,splitAt) +import Control.Applicative (Const(..)) import qualified Data.List as List import Data.Bits (shiftL, shiftR) #if !MIN_VERSION_base(4,8,0) @@ -245,6 +247,9 @@ import Data.Semigroup (stimesIdempotentMonoid) import Data.Functor.Classes #endif +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity (Identity) +#endif import qualified Data.Foldable as Foldable #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable (foldMap)) @@ -592,6 +597,72 @@ {-# INLINABLE delete #-} #else {-# INLINE delete #-} +#endif + +-- | /O(log n)/ @('alterF' f x s)@ can delete or insert @x@ in @s@ depending on +-- whether an equal element is found in @s@. +-- +-- In short: +-- +-- @ +-- 'member' x \<$\> 'alterF' f x s = f ('member' x s) +-- @ +-- +-- Note that unlike 'insert', 'alterF' will /not/ replace an element equal to +-- the given value. +-- +-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At". +-- +-- @since 0.6.3.1 +alterF :: (Ord a, Functor f) => (Bool -> f Bool) -> a -> Set a -> f (Set a) +alterF f k s = fmap choose (f member_) + where + (member_, inserted, deleted) = case alteredSet k s of + Deleted d -> (True , s, d) + Inserted i -> (False, i, s) + + choose True = inserted + choose False = deleted +#ifndef __GLASGOW_HASKELL__ +{-# INLINE alterF #-} +#else +{-# INLINABLE [2] alterF #-} + +{-# RULES +"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s + #-} +#endif + +#if MIN_VERSION_base(4,8,0) +{-# SPECIALIZE alterF :: Ord a => (Bool -> Identity Bool) -> a -> Set a -> Identity (Set a) #-} +#endif + +data AlteredSet a + -- | The needle is present in the original set. + -- We return the set where the needle is deleted. + = Deleted !(Set a) + + -- | The needle is not present in the original set. + -- We return the set with the needle inserted. + | Inserted !(Set a) + +alteredSet :: Ord a => a -> Set a -> AlteredSet a +alteredSet x0 s0 = go x0 s0 + where + go :: Ord a => a -> Set a -> AlteredSet a + go x Tip = Inserted (singleton x) + go x (Bin _ y l r) = case compare x y of + LT -> case go x l of + Deleted d -> Deleted (balanceR y d r) + Inserted i -> Inserted (balanceL y i r) + GT -> case go x r of + Deleted d -> Deleted (balanceL y l d) + Inserted i -> Inserted (balanceR y l i) + EQ -> Deleted (glue l r) +#if __GLASGOW_HASKELL__ +{-# INLINABLE alteredSet #-} +#else +{-# INLINE alteredSet #-} #endif {-------------------------------------------------------------------- diff --git a/src/Data/Tree.hs b/src/Data/Tree.hs --- a/src/Data/Tree.hs +++ b/src/Data/Tree.hs @@ -93,7 +93,7 @@ -- | Non-empty, possibly infinite, multi-way trees; also known as /rose trees/. data Tree a = Node { rootLabel :: a, -- ^ label value - subForest :: Forest a -- ^ zero or more child trees + subForest :: [Tree a] -- ^ zero or more child trees } #ifdef __GLASGOW_HASKELL__ deriving ( Eq @@ -107,6 +107,8 @@ deriving (Eq, Read, Show) #endif +-- | This type synonym exists primarily for historical +-- reasons. type Forest a = [Tree a] #if MIN_VERSION_base(4,9,0) @@ -249,7 +251,7 @@ -- `- 20 -- @ -- -drawForest :: Forest String -> String +drawForest :: [Tree String] -> String drawForest = unlines . map drawTree draw :: Tree String -> [String] @@ -321,7 +323,7 @@ -- -- Find depth of the tree; i.e. the number of branches from the root of the tree to the furthest leaf: -- --- > foldTree (\_ xs -> if null xs then 0 else 1 + maximum xs) (Node 1 [Node 2[], Node 3 []]) == 1 +-- > foldTree (\_ xs -> if null xs then 0 else 1 + maximum xs) (Node 1 [Node 2 [], Node 3 []]) == 1 -- -- You can even implement traverse using foldTree: -- @@ -377,7 +379,7 @@ -- -- For a monadic version see 'unfoldForestM_BF'. -- -unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a +unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree a] unfoldForest f = map (unfoldTree f) -- | Monadic tree builder, in depth-first order. @@ -388,7 +390,7 @@ return (Node a ts) -- | Monadic forest builder, in depth-first order -unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a) +unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a]) unfoldForestM f = Prelude.mapM (unfoldTreeM f) -- | Monadic tree builder, in breadth-first order. @@ -410,7 +412,7 @@ -- -- Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons -- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/. -unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a) +unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a]) unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList -- Takes a sequence (queue) of seeds and produces a sequence (reversed queue) of