IntervalMap 0.3.0.3 → 0.4.0.0

raw patch · 13 files changed

+2507/−1613 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/IntervalMap/Base.hs +0/−1230
• Data/IntervalMap/Generic/Base.hs +1229/−0
• Data/IntervalMap/Generic/Interval.hs +112/−0
• Data/IntervalMap/Generic/Lazy.hs +155/−0
• Data/IntervalMap/Generic/Strict.hs +567/−0
• Data/IntervalMap/Lazy.hs +7/−2
• Data/IntervalMap/Strict.hs +5/−373
• IntervalMap.cabal +24/−4
• bench/BenchAll.hs +23/−3
• bench/GenericLazyVsStrict.hs +109/−0
• examples/Example.lhs +1/−1
• examples/GenericExample.lhs +98/−0
• test/GenericIntervalTests.hs +177/−0

@@ -1,1230 +0,0 @@--- |--- Module      :  Data.IntervalMap.Base--- Copyright   :  (c) Christoph Breitkopf 2011--- License     :  BSD-style--- Maintainer  :  chbreitkopf@gmail.com--- Stability   :  experimental--- Portability :  portable------ An implementation of maps from intervals to values. The key intervals may--- overlap, and the implementation contains efficient search functions--- for all keys containing a point or overlapping an interval.--- Closed, open, and half-open intervals can be contained in the same map.------ An IntervalMap cannot contain duplicate keys - if you need to map a key--- to muiltiple values, use a collection as the value type, for--- example: @IntervalMap /k/ [/v/]@.------ It is an error to insert an empty interval into a map. This precondition is not--- checked by the various construction functions.------ Since many function names (but not the type name) clash with--- /Prelude/ names, this module is usually imported @qualified@, e.g.------ >  import Data.IntervalMap (IvMap)--- >  import qualified Data.IntervalMap as IvMap------ It offers most of the same functions as 'Data.Map', but uses 'Interval' /k/ instead of--- just /k/ as the key type. Some of the functions need stricter type constraints to--- maintain the additional information for efficient interval searching,--- for example 'fromDistinctAscList' needs an 'Ord' /k/ constraint.--- Also, some functions differ in asymptotic performance (for example 'size') or have not--- been tuned for efficiency as much as their equivalents in 'Data.Map' (in--- particular the various set functions).------ In addition, there are functions specific to maps of intervals, for example to search--- for all keys containing a given point or contained in a given interval.------ To stay compatible with standard Haskell, this implementation uses a fixed data--- type for intervals, and not a multi-parameter type class. Thus, it's currently--- not possible to define e.g. a 2-tuple as an instance of interval and use that--- map key. Instead, you must convert your keys to 'Interval'.------ The implementation is a red-black tree augmented with the maximum upper bound--- of all keys.------ Parts of this implementation are based on code from the 'Data.Map' implementation,--- (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008.--- The red-black tree deletion is based on code from llrbtree by Kazu Yamamoto.--- Of course, any errors are mine.----module Data.IntervalMap.Base (-            -- * re-export-            Interval(..)-            -- * Map type-            , IntervalMap(..)      -- instance Eq,Show,Read--            -- * Operators-            , (!), (\\)--            -- * Query-            , null-            , size-            , member-            , notMember-            , lookup-            , findWithDefault--            -- ** Interval query-            , containing-            , intersecting-            , within-            -            -- * Construction-            , empty-            , singleton--            -- ** Insertion-            , insert-            , insertWith-            , insertWithKey-            , insertLookupWithKey-            -            -- ** Delete\/Update-            , delete-            , adjust-            , adjustWithKey-            , update-            , updateWithKey-            , updateLookupWithKey-            , alter--            -- * Combine--            -- ** Union-            , union-            , unionWith-            , unionWithKey-            , unions-            , unionsWith--            -- ** Difference-            , difference-            , differenceWith-            , differenceWithKey-            -            -- ** Intersection-            , intersection-            , intersectionWith-            , intersectionWithKey--            -- * Traversal-            -- ** Map-            , map-            , mapWithKey-            , mapAccum-            , mapAccumWithKey-            , mapAccumRWithKey-            , mapKeys-            , mapKeysWith-            , mapKeysMonotonic--            -- ** Fold-            , foldr, foldl-            , foldrWithKey, foldlWithKey-            , foldl', foldr'-            , foldrWithKey', foldlWithKey'--            -- * Conversion-            , elems-            , keys-            , keysSet-            , assocs--            -- ** Lists-            , toList-            , fromList-            , fromListWith-            , fromListWithKey--            -- ** Ordered lists-            , toAscList-            , toDescList-            , fromAscList-            , fromAscListWith-            , fromAscListWithKey-            , fromDistinctAscList--            -- * Filter-            , filter-            , filterWithKey-            , partition-            , partitionWithKey--            , mapMaybe-            , mapMaybeWithKey-            , mapEither-            , mapEitherWithKey--            , split-            , splitLookup--            -- * Submap-            , isSubmapOf, isSubmapOfBy-            , isProperSubmapOf, isProperSubmapOfBy--            -- * Min\/Max-            , findMin-            , findMax-            , findLast-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax-            , updateMin-            , updateMax-            , updateMinWithKey-            , updateMaxWithKey-            , minView-            , maxView-            , minViewWithKey-            , maxViewWithKey--            -- * Internal, not re-exported by Data.IntervalMap.{Lazy,Strict}-            , Color(..)-            , balanceL, balanceR-            , turnBlack-            , setMinValue, setMaxValue--            -- * Debugging-            , valid--            -- * Testing-            , height, maxHeight, showStats--            ) where--import Prelude hiding (null, lookup, map, filter, foldr, foldl)-import Data.Bits (shiftR, (.&.))-import Data.Monoid (Monoid(..))-import Control.Applicative (Applicative(..), (<$>))-import Data.Traversable (Traversable(traverse))-import qualified Data.Foldable as Foldable-import qualified Data.List as L-import qualified Data.Set as Set-import Control.DeepSeq (NFData(rnf))--import Data.IntervalMap.Interval--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 !,\\ ------ | /O(log n)/. Lookup value for given key. Calls 'error' if the key is not in the map.-(!) :: (Ord k) => IntervalMap k v -> Interval k -> v-tree ! key = case lookup key tree of-               Just v  -> v-               Nothing -> error "IntervalMap.!: key not found"---- | Same as 'difference'.-(\\) :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a-m1 \\ m2 = difference m1 m2---data Color = R | B deriving (Eq, Read, Show)---- | A map from intervals with endpoints of type @k@ to values of type @v@.-data IntervalMap k v = Nil-                      | Node !Color-                             !(Interval k) -- key-                             !(Interval k) -- interval with maximum upper in tree-                             v             -- value-                             !(IntervalMap k v) -- left subtree-                             !(IntervalMap k v) -- right subtree--instance (Eq k, Eq v) => Eq (IntervalMap k v) where-  a == b = toAscList a == toAscList b--instance (Ord k, Ord v) => Ord (IntervalMap k v) where-  compare a b = compare (toAscList a) (toAscList b)--instance Functor (IntervalMap k) where-  fmap f m  = map f m--instance (Ord k) => Monoid (IntervalMap k v) where-    mempty  = empty-    mappend = union-    mconcat = unions--instance Traversable (IntervalMap k) where-  traverse _ Nil = pure Nil-  traverse f (Node c k m v l r)-    = flip (Node c k m) <$> traverse f l <*> f v <*> traverse f r--instance Foldable.Foldable (IntervalMap k) where-  fold Nil = mempty-  fold (Node _ _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r-  foldr = foldr-  foldl = foldl-  foldMap _ Nil = mempty-  foldMap f (Node _ _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r--instance (NFData k, NFData a) => NFData (IntervalMap k a) where-    rnf Nil = ()-    rnf (Node _ kx _ x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r--instance (Ord k, Read k, Read e) => Read (IntervalMap k e) where-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("fromList",s) <- lex r-    (xs,t) <- reads s-    return (fromList xs,t)--instance (Show k, Show a) => Show (IntervalMap k a) where-  showsPrec d m  = showParen (d > 10) $-    showString "fromList " . shows (toList m)---isRed :: IntervalMap k v -> Bool-isRed (Node R _ _ _ _ _) = True-isRed _ = False--turnBlack :: IntervalMap k v -> IntervalMap k v-turnBlack (Node R k m vs l r) = Node B k m vs l r-turnBlack t = t--turnRed :: IntervalMap k v -> IntervalMap k v-turnRed Nil = error "turnRed: Leaf"-turnRed (Node B k m v l r) = Node R k m v l r-turnRed t = t---- construct node, recomputing the upper key bound.-mNode :: (Ord k) => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v-mNode c k v l r = Node c k (maxUpper k l r) v l r--maxUpper :: Ord k => Interval k -> IntervalMap k v -> IntervalMap k v -> Interval k-maxUpper k Nil                Nil                = k `seq` k-maxUpper k Nil                (Node _ _ m _ _ _) = maxByUpper k m-maxUpper k (Node _ _ m _ _ _) Nil                = maxByUpper k m-maxUpper k (Node _ _ l _ _ _) (Node _ _ r _ _ _) = maxByUpper k (maxByUpper l r)---- interval with the greatest upper bound. The lower bound is ignored!-maxByUpper :: Ord a => Interval a -> Interval a -> Interval a-maxByUpper a@(IntervalCO     _ u) b = if u >  upperBound b then a else b-maxByUpper a@(ClosedInterval _ u) b = if u >= upperBound b then a else b-maxByUpper a@(OpenInterval   _ u) b = if u >  upperBound b then a else b-maxByUpper a@(IntervalOC     _ u) b = if u >= upperBound b then a else b----- ------------------------------------------------------------- | /O(1)/. The empty map.-empty :: IntervalMap k v-empty =  Nil---- | /O(1)/. A map with one entry.-singleton :: Interval k -> v -> IntervalMap k v-singleton k v = Node B k k v Nil Nil----- | /O(1)/. Is the map empty?-null :: IntervalMap k v -> Bool-null Nil = True-null _   = False---- | /O(n)/. Number of keys in the map.------ Caution: unlike 'Data.Map.size', which takes constant time, this is linear in the--- number of keys!-size :: IntervalMap k v -> Int-size t = h 0 t-  where-    h n m = n `seq` case m of-                      Nil -> n-                      Node _ _ _ _ l r -> h (h n l + 1) r---- | The height of the tree. For testing/debugging only.-height :: IntervalMap k v -> Int-height Nil = 0-height (Node _ _ _ _ l r) = 1 + max (height l) (height r)---- | The maximum height of a red-black tree with the given number of nodes.--- For testing/debugging only.-maxHeight :: Int -> Int-maxHeight nodes = 2 * log2 (nodes + 1)---- | Tree statistics (size, height, maxHeight size).--- For testing/debugging only.-showStats :: IntervalMap k a -> (Int, Int, Int)-showStats m = (n, height m, maxHeight n)-  where n = size m---- | /O(log n)/. Does the map contain the given key? See also 'notMember'.-member :: (Ord k) => Interval k -> IntervalMap k v -> Bool-member key tree = case lookup key tree of-                    Nothing -> False-                    Just _  -> True---- | /O(log n)/. Does the map not contain the given key? See also 'member'.-notMember :: (Ord k) => Interval k -> IntervalMap k v -> Bool-notMember key tree = not (member key tree)----- | /O(log n)/. Look up the given key in the map, returning the value @('Just' value)@,--- or 'Nothing' if the key is not in the map.-lookup :: (Ord k) => Interval k -> IntervalMap k v -> Maybe v-lookup k Nil =  k `seq` Nothing-lookup k (Node _ key _ v l r) = case compare k key of-                                  LT -> lookup k l-                                  GT -> lookup k r-                                  EQ -> Just v----- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'--findWithDefault :: Ord k => a -> Interval k -> IntervalMap k a -> a-findWithDefault def k m = case lookup k m of-    Nothing -> def-    Just x  -> x---- | Return all key/value pairs where the key intervals contain the given point.--- The elements are returned in ascending key order.------ /O(n)/, since potentially all keys could contain the point.--- /O(log n)/ average case. This is also the worst case for maps containing no overlapping keys.-containing :: (Ord k) => IntervalMap k v -> k -> [(Interval k, v)]-t `containing` pt = go [] pt t-  where-    go xs p Nil = p `seq` xs-    go xs p (Node _ k m v l r)-       | p `above` m  =  xs         -- above all intervals in the tree: no result-       | p `below` k  =  go xs p l  -- to the left of the lower bound: can't be in right subtree-       | p `inside` k =  go ((k,v) : go xs p r) p l-       | otherwise    =  go (go xs p r) p l---- | Return all key/value pairs where the key intervals overlap (intersect) the given interval.--- The elements are returned in ascending key order.------ /O(n)/, since potentially all keys could intersect the interval.--- /O(log n)/ average case, if few keys intersect the interval.-intersecting :: (Ord k) => IntervalMap k v -> Interval k -> [(Interval k, v)]-t `intersecting` iv = go [] iv t-  where-    go xs i Nil = i `seq` xs-    go xs i (Node _ k m v l r)-       | i `after` m     =  xs-       | i `before` k    =  go xs i l-       | i `overlaps` k  =  go ((k,v) : go xs i r) i l-       | otherwise       =  go (go xs i r) i l---- | Return all key/value pairs where the key intervals are completely inside the given interval.--- The elements are returned in ascending key order.------ /O(n)/, since potentially all keys could be inside the interval.--- /O(log n)/ average case, if few keys are inside the interval.-within :: (Ord k) => IntervalMap k v -> Interval k -> [(Interval k, v)]-t `within` iv = go [] iv t-  where-    go xs i Nil = i `seq` xs-    go xs i (Node _ k m v l r)-       | i `after` m     =  xs-       | i `before` k    =  go xs i l-       | i `subsumes` k  =  go ((k,v) : go xs i r) i l-       | otherwise       =  go (go xs i r) i l----- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is--- changed to the new value.-insert :: (Ord k) => Interval k -> v -> IntervalMap k v -> IntervalMap k v-insert =  insertWithKey (\_ v _ -> v)---- | /O(log n)/. Insert with a function, combining new value and old value.--- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.-insertWith :: (Ord k) => (v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v-insertWith f = insertWithKey (\_ new old -> f new old)---- | /O(log n)/. Insert with a function, combining key, new value and old value.--- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.-insertWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v-insertWithKey f key value mp  =  key `seq` turnBlack (ins mp)-  where-    singletonR k v = Node R k k v Nil Nil-    ins Nil = singletonR key value-    ins (Node color k m v l r) =-      case compare key k of-        LT -> balanceL color k v (ins l) r-        GT -> balanceR color k v l (ins r)-        EQ -> Node color k m (f k value v) l r---- | /O(log n)/. Combine insert with old values retrieval.-insertLookupWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v)-insertLookupWithKey f key value mp  =  key `seq` (oldval, turnBlack mp')-  where-    (oldval, mp') = ins mp-    singletonR k v = Node R k k v Nil Nil-    ins Nil = (Nothing, singletonR key value)-    ins (Node color k m v l r) =-      case compare key k of-        LT -> case ins l of-                 (x@(Just _), t') -> (x, Node color k m v t' r)-                 (Nothing, t') -> (Nothing, balanceL color k v t' r)-        GT -> case ins r of-                 (x@(Just _), t') -> (x, Node color k m v l t')-                 (Nothing, t') -> (Nothing, balanceR color k v l t')-        EQ -> (Just v, Node color k m (f k value v) l r)---balanceL :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v-balanceL B zk zv (Node R yk _ yv (Node R xk _ xv a b) c) d =-    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)-balanceL B zk zv (Node R xk _ xv a (Node R yk _ yv b c)) d =-    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)-balanceL c xk xv l r = mNode c xk xv l r--balanceR :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v-balanceR B xk xv a (Node R yk _ yv b (Node R zk _ zv c d)) =-    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)-balanceR B xk xv a (Node R zk _ zv (Node R yk _ yv b c) d) =-    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)-balanceR c xk xv l r = mNode c xk xv l r----- min/max---- | /O(log n)/. Returns the smallest key and its associated value.--- Calls 'error' if the map is empty.-findMin :: IntervalMap k v -> (Interval k, v)-findMin (Node _ k _ v Nil _) = (k,v)-findMin (Node _ _ _ _ l _) = findMin l-findMin Nil = error "IntervalMap.findMin: empty map"---- | /O(log n)/. Returns the largest key and its associated value.--- Calls 'error' if the map is empty.-findMax :: IntervalMap k v -> (Interval k, v)-findMax (Node _ k _ v _ Nil) = (k,v)-findMax (Node _ _ _ _ _ r) = findMax r-findMax Nil = error "IntervalMap.findMin: empty map"---- | Returns the interval with the largest endpoint.--- If there is more than one interval with that endpoint,--- return the rightmost.------ /O(n)/, since all keys could have the same endpoint.--- /O(log n)/ average case.-findLast :: Eq k => IntervalMap k v -> (Interval k, v)-findLast Nil = error "IntervalMap.findLast: empty map"-findLast t@(Node _ _ mx _ _ _) = lastMax-  where-    (lastMax : _) = go t-    go Nil = []-    go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ ((k,v) : go l)-                                                      else go r ++ go l-                          | otherwise  = []-    sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b----- Type to indicate whether the number of black nodes changed or stayed the same.-data DeleteResult k v = U !(IntervalMap k v)   -- Unchanged-                      | S !(IntervalMap k v)   -- Shrunk--unwrap :: DeleteResult k v -> IntervalMap k v-unwrap (U m) = m-unwrap (S m) = m---- DeleteResult with value-data DeleteResult' k v a = U' !(IntervalMap k v) a-                         | S' !(IntervalMap k v) a--unwrap' :: DeleteResult' k v a -> IntervalMap k v-unwrap' (U' m _) = m-unwrap' (S' m _) = m---- annotate DeleteResult with value-annotate :: DeleteResult k v -> a -> DeleteResult' k v a-annotate (U m) x = U' m x-annotate (S m) x = S' m x----- | /O(log n)/. Remove the smallest key from the map. Return the empty map if the map is empty.-deleteMin :: (Ord k) => IntervalMap k v -> IntervalMap k v-deleteMin Nil = Nil-deleteMin m   = turnBlack (unwrap' (deleteMin' m))--deleteMin' :: Ord k => IntervalMap k v -> DeleteResult' k v (Interval k, v)-deleteMin' Nil = error "deleteMin': Nil"-deleteMin' (Node B k _ v Nil Nil) = S' Nil (k,v)-deleteMin' (Node B k _ v Nil r@(Node R _ _ _ _ _)) = U' (turnBlack r) (k,v)-deleteMin' (Node R k _ v Nil r) = U' r (k,v)-deleteMin' (Node c k _ v l r) =-  case deleteMin' l of-    (U' l' kv) -> U' (mNode c k v l' r) kv-    (S' l' kv) -> annotate (unbalancedR c k v l' r) kv--deleteMax' :: Ord k => IntervalMap k v -> DeleteResult' k v (Interval k, v)-deleteMax' Nil = error "deleteMax': Nil"-deleteMax' (Node B k _ v Nil Nil) = S' Nil (k,v)-deleteMax' (Node B k _ v l@(Node R _ _ _ _ _) Nil) = U' (turnBlack l) (k,v)-deleteMax' (Node R k _ v l Nil) = U' l (k,v)-deleteMax' (Node c k _ v l r) =-  case deleteMax' r of-    (U' r' kv) -> U' (mNode c k v l r') kv-    (S' r' kv) -> annotate (unbalancedL c k v l r') kv---- The left tree lacks one Black node-unbalancedR :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v--- Decreasing one Black node in the right-unbalancedR B k v l r@(Node B _ _ _ _ _) = S (balanceR B k v l (turnRed r))-unbalancedR R k v l r@(Node B _ _ _ _ _) = U (balanceR B k v l (turnRed r))--- Taking one Red node from the right and adding it to the right as Black-unbalancedR B k v l (Node R rk _ rv rl@(Node B _ _ _ _ _) rr)-  = U (mNode B rk rv (balanceR B k v l (turnRed rl)) rr)-unbalancedR _ _ _ _ _ = error "unbalancedR"--unbalancedL :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v-unbalancedL R k v l@(Node B _ _ _ _ _) r = U (balanceL B k v (turnRed l) r)-unbalancedL B k v l@(Node B _ _ _ _ _) r = S (balanceL B k v (turnRed l) r)-unbalancedL B k v (Node R lk _ lv ll lr@(Node B _ _ _ _ _)) r-  = U (mNode B lk lv ll (balanceL B k v (turnRed lr) r))-unbalancedL _ _ _ _ _ = error "unbalancedL"------ | /O(log n)/. Remove the largest key from the map. Return the empty map if the map is empty.-deleteMax :: (Ord k) => IntervalMap k v -> IntervalMap k v-deleteMax Nil = Nil-deleteMax m   = turnBlack (unwrap' (deleteMax' m))---- | /O(log n)/. Delete and return the smallest key.-deleteFindMin :: (Ord k) => IntervalMap k v -> ((Interval k,v), IntervalMap k v)-deleteFindMin mp = case deleteMin' mp of-                     (U' r v) -> (v, turnBlack r)-                     (S' r v) -> (v, turnBlack r)---- | /O(log n)/. Delete and return the largest key.-deleteFindMax :: (Ord k) => IntervalMap k v -> ((Interval k,v), IntervalMap k v)-deleteFindMax mp = case deleteMax' mp of-                     (U' r v) -> (v, turnBlack r)-                     (S' r v) -> (v, turnBlack r)---- | /O(log n)/. Update or delete value at minimum key.-updateMin :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMin f m = updateMinWithKey (\_ v -> f v) m---- | /O(log n)/. Update or delete value at maximum key.-updateMax :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMax f m = updateMaxWithKey (\_ v -> f v) m---- | /O(log n)/. Update or delete value at minimum key.-updateMinWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMinWithKey _ Nil = Nil-updateMinWithKey f m = let (k,v) = findMin m in-                       case f k v of-                         Just v' -> setMinValue v' m-                         Nothing -> deleteMin m---- | /O(log n)/. Update or delete value at maximum key.-updateMaxWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMaxWithKey _ Nil = Nil-updateMaxWithKey f m = let (k,v) = findMax m in-                       case f k v of-                         Just v' -> setMaxValue v' m-                         Nothing -> deleteMax m---- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing--minViewWithKey :: Ord k => IntervalMap k a -> Maybe ((Interval k, a), IntervalMap k a)-minViewWithKey Nil = Nothing-minViewWithKey x   = Just (deleteFindMin x)---- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.-maxViewWithKey :: Ord k => IntervalMap k a -> Maybe ((Interval k, a), IntervalMap k a)-maxViewWithKey Nil = Nothing-maxViewWithKey x   = Just (deleteFindMax x)---- | /O(log n)/. Retrieves the value associated with minimal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.-minView :: Ord k => IntervalMap k a -> Maybe (a, IntervalMap k a)-minView Nil = Nothing-minView x   = case deleteFindMin x of ((_,a), x') -> Just (a, x')---- | /O(log n)/. Retrieves the value associated with maximal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.-maxView :: Ord k => IntervalMap k a -> Maybe (a, IntervalMap k a)-maxView Nil = Nothing-maxView x   = case deleteFindMax x of ((_,a), x') -> Just (a, x')---setMinValue :: v -> IntervalMap k v -> IntervalMap k v-setMinValue _  Nil = Nil-setMinValue v' (Node c k m _ Nil r) = Node c k m v' Nil r-setMinValue v' (Node c k m v l   r) = Node c k m v (setMinValue v' l) r--setMaxValue :: v -> IntervalMap k v -> IntervalMap k v-setMaxValue _  Nil = Nil-setMaxValue v' (Node c k m _ l Nil) = Node c k m v' l Nil-setMaxValue v' (Node c k m v l r)   = Node c k m v l (setMaxValue v' r)------ folding---- | /O(n)/. Fold the values in the map using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.-foldr :: (a -> b -> b) -> b -> IntervalMap k a -> b-foldr _ z Nil = z-foldr f z (Node _ _ _ x l r) = foldr f (f x (foldr f z r)) l---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> IntervalMap k a -> b-foldr' f z m = z `seq` case m of-                         Nil -> z-                         Node _ _ _ x l r -> foldr' f (f x (foldr' f z r)) l---- | /O(n)/. Fold the values in the map using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.-foldl :: (b -> a -> b) -> b -> IntervalMap k a -> b-foldl _ z Nil = z-foldl f z (Node _ _ _ x l r) = foldl f (f (foldl f z l) x) r---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (b -> a -> b) -> b -> IntervalMap k a -> b-foldl' f z m = z `seq` case m of-                         Nil -> z-                         Node _ _ _ x l r -> foldl' f (f (foldl' f z l) x) r---- | /O(n)/. Fold the keys and values in the map using the given right-associative--- binary operator, such that--- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.-foldrWithKey :: (Interval k -> v -> a -> a) -> a -> IntervalMap k v -> a-foldrWithKey _ z Nil = z-foldrWithKey f z (Node _ k _ x l r) = foldrWithKey f (f k x (foldrWithKey f z r)) l---- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldrWithKey' :: (Interval k -> v -> a -> a) -> a -> IntervalMap k v -> a-foldrWithKey' f z m = z `seq` case m of-                                Nil -> z-                                Node _ k _ x l r -> foldrWithKey' f (f k x (foldrWithKey' f z r)) l---- | /O(n)/. Fold the keys and values in the map using the given left-associative--- binary operator, such that--- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.-foldlWithKey :: (a -> Interval k -> v -> a) -> a -> IntervalMap k v -> a-foldlWithKey _ z Nil = z-foldlWithKey f z (Node _ k _ x l r) = foldlWithKey f (f (foldlWithKey f z l) k x) r---- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldlWithKey' :: (a -> Interval k -> v -> a) -> a -> IntervalMap k v -> a-foldlWithKey' f z m = z `seq` case m of-                                Nil -> z-                                Node _ k _ x l r -> foldlWithKey' f (f (foldlWithKey' f z l) k x) r---- delete---- | /O(log n)/. Delete a key from the map. If the map does not contain the key,--- it is returned unchanged.-delete :: (Ord k) => Interval k -> IntervalMap k v -> IntervalMap k v-delete key mp = turnBlack (unwrap (delete' key mp))--delete' :: Ord k => Interval k -> IntervalMap k v -> DeleteResult k v-delete' x Nil = x `seq` U Nil-delete' x (Node c k _ v l r) =-  case compare x k of-    LT -> case delete' x l of-            (U l') -> U (mNode c k v l' r)-            (S l')    -> unbalancedR c k v l' r-    GT -> case delete' x r of-            (U r') -> U (mNode c k v l r')-            (S r')    -> unbalancedL c k v l r'-    EQ -> case r of-            Nil -> if c == B then blackify l else U l-            _ -> case deleteMin' r of-                   (U' r' (rk,rv)) -> U (mNode c rk rv l r')-                   (S' r' (rk,rv)) -> unbalancedL c rk rv l r'--blackify :: IntervalMap k v -> DeleteResult k v-blackify (Node R k m v l r) = U (Node B k m v l r)-blackify s                  = S s---- | /O(log n)/. Update a value at a specific key with the result of the provided function.--- When the key is not--- a member of the map, the original map is returned.-adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a-adjust f k m = adjustWithKey (\_ v -> f v) k m---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.-adjustWithKey :: Ord k => (Interval k -> a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a-adjustWithKey _ _ Nil = Nil-adjustWithKey f x (Node c k m v l r) =-  case compare x k of-    LT -> Node c k m v (adjustWithKey f x l) r-    GT -> Node c k m v l (adjustWithKey f x r)-    EQ -> Node c k m (f k v) l r---- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.-update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a-update f k m = updateWithKey (\_ v -> f v) k m---- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.-updateWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a-updateWithKey f k m = snd (updateLookupWithKey f k m)---- | /O(log n)/. Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted.-updateLookupWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> (Maybe a, IntervalMap k a)-updateLookupWithKey f x m = case lookup x m of-                              Nothing -> (Nothing, m)-                              r@(Just v) -> case f x v of-                                              Nothing -> (r, delete x m)-                                              r'@(Just v') -> (r', adjust (const v') x m)---- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.-alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a-alter f x m = case lookup x m of-                Nothing -> case f Nothing of-                             Nothing -> m-                             Just v -> insert x v m-                y       -> case f y of-                             Nothing -> delete x m-                             Just v' -> adjust (const v') x m----- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. --- It prefers @t1@ when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).-union :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a-union m1 m2 = unionWithKey (\_ v _ -> v) m1 m2---- | /O(n+m)/. Union with a combining function.-unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a-unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2---- | /O(n+m)/. Union with a combining function.-unionWithKey :: Ord k => (Interval k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a-unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2))---- | The union of a list of maps:---   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).-unions :: Ord k => [IntervalMap k a] -> IntervalMap k a-unions = L.foldl union empty---- | The union of a list of maps, with a combining operation:---   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).-unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a-unionsWith f = L.foldl (unionWith f) empty---- | /O(n+m)/. Difference of two maps. --- Return elements of the first map not existing in the second map.-difference :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a-difference m1 m2 = differenceWithKey (\_ _ _ -> Nothing) m1 m2---- | /O(n+m)/. Difference with a combining function. --- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWith :: Ord k => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a-differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWithKey :: Ord k => (Interval k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a-differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2))---- | /O(n+m)/. Intersection of two maps.--- Return data in the first map for the keys existing in both maps.--- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).-intersection :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a-intersection m1 m2 = intersectionWithKey (\_ v _ -> v) m1 m2---- | /O(n+m)/. Intersection with a combining function.-intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c-intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2---- | /O(n+m)/. Intersection with a combining function.-intersectionWithKey :: Ord k => (Interval k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c-intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2))--ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)]-ascListUnion _ [] [] = []-ascListUnion _ [] ys = ys-ascListUnion _ xs [] = xs-ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') =-  case compare xk yk of-    LT -> x : ascListUnion f xs' ys-    GT -> y : ascListUnion f xs ys'-    EQ -> (xk, f xk xv yv) : ascListUnion f xs' ys'--ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)]-ascListDifference _ [] _  = []-ascListDifference _ xs [] = xs-ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') =-  case compare xk yk of-    LT -> x : ascListDifference f xs' ys-    GT -> ascListDifference f xs ys'-    EQ -> case f xk xv yv of-            Nothing -> ascListDifference f xs' ys'-            Just v' -> (xk,v') : ascListDifference f xs' ys'--ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)]-ascListIntersection _ [] _ = []-ascListIntersection _ _ [] = []-ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') =-  case compare xk yk of-    LT -> ascListIntersection f xs' ys-    GT -> ascListIntersection f xs ys'-    EQ -> (xk, f xk xv yv) : ascListIntersection f xs' ys'----- --- Conversion ------- | /O(n)/. The list of all key\/value pairs contained in the map, in ascending order of keys.-toAscList :: IntervalMap k v -> [(Interval k,v)]-toAscList m = foldrWithKey (\k v r -> (k,v) : r) [] m---- | /O(n)/. The list of all key\/value pairs contained in the map, in no particular order.-toList :: IntervalMap k v -> [(Interval k,v)]-toList m = toAscList m---- | /O(n)/. The list of all key\/value pairs contained in the map, in descending order of keys.-toDescList :: IntervalMap k v -> [(Interval k, v)]-toDescList m = foldlWithKey (\r k v -> (k,v) : r) [] m---- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.-fromList :: Ord k => [(Interval k,v)] -> IntervalMap k v-fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs---- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.-fromListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs---- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.-fromListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWithKey f xs = L.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./-fromAscList :: Ord k => [(Interval k,v)] -> IntervalMap k v-fromAscList xs = fromAscListWith (\_ b -> b) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./-fromAscListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./-fromAscListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs)--combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)]-combineEq _ [] = []-combineEq _ xs@[_] = xs-combineEq f (x@(xk,xv) : xs@((yk,yv) : xs'))-  | xk == yk  = combineEq f ((xk, f xk xv yv) : xs')-  | otherwise = x : combineEq f xs----- Strict tuple-data T2 a b = T2 !a !b----- | /O(n)/. Build a map from an ascending list of elements with distinct keys in linear time.--- /The precondition is not checked./-fromDistinctAscList :: (Ord k) => [(Interval k,v)] -> IntervalMap k v--- exactly 2^n-1 items have height n. They can be all black--- from 2^n - 2^n-2 items have height n+1. The lowest "row" should be red.-fromDistinctAscList lyst = case h (length lyst) lyst of-                             (T2 result []) -> result-                             _ -> error "fromDistinctAscList: list not fully consumed"-  where-    h n xs | n == 0      = T2 Nil xs-           | isPerfect n = buildB n xs-           | otherwise   = buildR n (log2 n) xs--    buildB n xs | xs `seq` n <= 0 = error "fromDictinctAscList: buildB 0"-                | n == 1     = case xs of ((k,v):xs') -> T2 (Node B k k v Nil Nil) xs'-                | otherwise  =-                     case n `quot` 2 of { n' ->-                     case buildB n' xs of { (T2 l ((k,v):xs')) ->-                     case buildB n' xs' of { (T2 r xs'') ->-                     T2 (mNode B k v l r) xs'' }}}--    buildR n d xs | d `seq` xs `seq` n == 0 = T2 Nil xs-                  | n == 1    = case xs of ((k,v):xs') -> T2 (Node (if d==0 then R else B) k k v Nil Nil) xs'-                  | otherwise =-                      case n `quot` 2 of { n' ->-                      case buildR n' (d-1) xs of { (T2 l ((k,v):xs')) ->-                      case buildR (n - (n' + 1)) (d-1) xs' of { (T2 r xs'') ->-                      T2 (mNode B k v l r) xs'' }}}----- is n a perfect binary tree size (2^m-1)?-isPerfect :: Int -> Bool-isPerfect n = (n .&. (n + 1)) == 0--log2 :: Int -> Int-log2 m = h (-1) m-  where-    h r n | r `seq` n <= 0 = r-          | otherwise      = h (r + 1) (n `shiftR` 1)----- | /O(n)/. List of all values in the map, in ascending order of their keys.-elems :: IntervalMap k v -> [v]-elems m = [v | (_,v) <- toAscList m]---- | /O(n)/. List of all keys in the map, in ascending order.-keys :: IntervalMap k v -> [Interval k]-keys m = [k | (k,_) <- toAscList m]---- | /O(n)/. Set of the keys.-keysSet :: (Ord k) => IntervalMap k v -> Set.Set (Interval k)-keysSet m =  Set.fromDistinctAscList (keys m)---- | Same as 'toAscList'.-assocs :: IntervalMap k v -> [(Interval k, v)]-assocs m = toAscList m---- --- Mapping ------- | /O(n)/. Map a function over all values in the map.-map :: (a -> b) -> IntervalMap k a -> IntervalMap k b-map f = mapWithKey (\_ x -> f x)---- | /O(n)/. Map a function over all values in the map.-mapWithKey :: (Interval k -> a -> b) -> IntervalMap k a -> IntervalMap k b-mapWithKey f = go-  where-    go Nil = Nil-    go (Node c k m v l r) = Node c k m (f k v) (go l) (go r)---- | /O(n)/. The function 'mapAccum' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])-mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)-mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m---- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])-mapAccumWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)-mapAccumWithKey f = go-  where-    go a Nil               = (a,Nil)-    go a (Node c kx m x l r) =-                 let (a1,l') = go a l-                     (a2,x') = f a1 kx x-                     (a3,r') = go a2 r-                 in (a3, Node c kx m x' l' r')---- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)-mapAccumRWithKey f = go-  where-    go a Nil = (a, Nil)-    go a (Node c kx m x l r) =-                 let (a1,r') = go a r-                     (a2,x') = f a1 kx x-                     (a3,l') = go a2 l-                 in (a3, Node c kx m x' l' r')----- | /O(n log n)/. @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the value at the smallest of--- these keys is retained.-mapKeys :: Ord k2 => (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a-mapKeys f m = fromList [ (f k, v) | (k, v) <- toDescList m ]---- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.-mapKeysWith :: Ord k2 => (a -> a -> a) -> (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a-mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ]---- | /O(n log n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./-mapKeysMonotonic :: Ord k2 => (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a-mapKeysMonotonic _ Nil = Nil-mapKeysMonotonic f (Node c k _ x l r) =-    mNode c (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)---- | /O(n)/. Filter values satisfying a predicate.-filter :: Ord k => (a -> Bool) -> IntervalMap k a -> IntervalMap k a-filter p m = filterWithKey (\_ v -> p v) m---- | /O(n)/. Filter keys\/values satisfying a predicate.-filterWithKey :: Ord k => (Interval k -> a -> Bool) -> IntervalMap k a -> IntervalMap k a-filterWithKey p m = mapMaybeWithKey (\k v -> if p k v then Just v else Nothing) m---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.-partition :: Ord k => (a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)-partition p m = partitionWithKey (\_ v -> p v) m---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.-partitionWithKey :: Ord k => (Interval k -> a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)-partitionWithKey p m = mapEitherWithKey p' m-  where-    p' k v | p k v     = Left v-           | otherwise = Right v---- | /O(n)/. Map values and collect the 'Just' results.-mapMaybe :: Ord k => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b-mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m---- | /O(n)/. Map keys\/values and collect the 'Just' results.-mapMaybeWithKey :: Ord k => (Interval k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b-mapMaybeWithKey f m = fromDistinctAscList (mapf [] m)-  where-    mapf z Nil = z-    mapf z (Node _ k _ v l r) = mapf (f' k v z r) l-    f' k v z r = case f k v of-                   Nothing -> mapf z r-                   Just v' -> (k,v') : mapf z r---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.-mapEither :: Ord k => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)-mapEither f m = mapEitherWithKey (\_ v -> f v) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.-mapEitherWithKey :: Ord k => (Interval k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)-mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r)-  where-    (l, r) = part [] [] (toDescList m)-    part ls rs [] = (ls, rs)-    part ls rs ((k,v):xs) = case f k v of-                              Left v'  -> part ((k,v'):ls) rs xs-                              Right v' -> part ls ((k,v'):rs) xs---- | /O(n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.--- Any key equal to @k@ is found in neither @map1@ nor @map2@.-split :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)-split x m = (l, r)-  where (l, _, r) = splitLookup x m-     --- | /O(n)/. The expression (@'splitLookup' k map@) splits a map just--- like 'split' but also returns @'lookup' k map@.                               -splitLookup :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, Maybe a, IntervalMap k a)-splitLookup x m = (fromDistinctAscList less, lookup x m, fromDistinctAscList greater)-  where-    less    = [e | e@(k,_) <- toAscList m, k < x]-    greater = [e | e@(k,_) <- toAscList m, k > x]---- submaps---- | /O(n+m)/. This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).-isSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool-isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2--{- | /O(n+m)/.- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if- all keys in @t1@ are in tree @t2@, and @f@ returns 'True' when- applied to their respective values.--}-isSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool-isSubmapOfBy f m1 m2 = go (toAscList m1) (toAscList m2)-  where-    go []    _  =  True-    go (_:_) [] =  False-    go s1@((k1,v1):r1) ((k2,v2):r2) =-       case compare k1 k2 of-         GT -> go s1 r2-         EQ -> f v1 v2 && go r1 r2-         LT -> False---- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). --- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).-isProperSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool-isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2--{- | /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,- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values.--}-isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool-isProperSubmapOfBy f t1 t2 = size t1 < size t2 && isSubmapOfBy f t1 t2----- debugging---- | Check red-black-tree and interval search augmentation invariants.--- For testing/debugging only.-valid :: Ord k => IntervalMap k v -> Bool-valid mp = test mp && height mp <= maxHeight (size mp) && validColor mp-  where-    test Nil = True-    test n@(Node _ _ _ _ l r) = validOrder n && validMax n && test l && test r-    validMax (Node _ k m _ lo hi) =  m == maxUpper k lo hi-    validMax Nil = True--    validOrder (Node _ _ _ _ Nil Nil) = True-    validOrder (Node _ k1 _ _ Nil (Node _ k2 _ _ _ _)) = k1 < k2-    validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) Nil) = k1 < k2-    validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) (Node _ k3 _ _ _ _)) = k1 < k2 && k2 < k3-    validOrder Nil = True--    -- validColor parentColor blackCount tree-    validColor n = blackDepth n >= 0--    -- return -1 if subtrees have diffrent black depths or two consecutive red nodes are encountered-    blackDepth :: IntervalMap k v -> Int-    blackDepth Nil  = 0-    blackDepth (Node c _ _ _ l r) = case blackDepth l of-                                      ld -> if ld < 0 then ld-                                            else-                                              case blackDepth r of-                                                rd -> if rd < 0 then rd-                                                      else if rd /= ld then -1-                                                      else if c == R && (isRed l || isRed r) then -1-                                                      else if c == B then rd + 1-                                                      else rd-

@@ -0,0 +1,1229 @@+-- |+-- Module      :  Data.IntervalMap.Generic.Base+-- Copyright   :  (c) Christoph Breitkopf 2014+-- License     :  BSD-style+-- Maintainer  :  chbreitkopf@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- An implementation of maps from intervals to values. The key intervals may+-- overlap, and the implementation contains efficient search functions+-- for all keys containing a point or overlapping an interval.+-- Closed, open, and half-open intervals can be contained in the same map.+--+-- An IntervalMap cannot contain duplicate keys - if you need to map a key+-- to muiltiple values, use a collection as the value type, for+-- example: @IntervalMap /k/ [/v/]@.+--+-- It is an error to insert an empty interval into a map. This precondition is not+-- checked by the various construction functions.+--+-- Since many function names (but not the type name) clash with+-- /Prelude/ names, this module is usually imported @qualified@, e.g.+--+-- >  import Data.IntervalMap (IvMap)+-- >  import qualified Data.IntervalMap as IvMap+--+-- It offers most of the same functions as 'Data.Map', but the key type must be an+-- instance of 'Interval'. Some of the functions need stricter type constraints to+-- maintain the additional information for efficient interval searching,+-- for example 'fromDistinctAscList' needs an 'Ord' /k/ constraint.+-- Also, some functions differ in asymptotic performance (for example 'size') or have not+-- been tuned for efficiency as much as their equivalents in 'Data.Map' (in+-- particular the various set functions).+--+-- In addition, there are functions specific to maps of intervals, for example to search+-- for all keys containing a given point or contained in a given interval.+--+-- The implementation is a red-black tree augmented with the maximum upper bound+-- of all keys.+--+-- Parts of this implementation are based on code from the 'Data.Map' implementation,+-- (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008.+-- The red-black tree deletion is based on code from llrbtree by Kazu Yamamoto.+-- Of course, any errors are mine.+--+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.IntervalMap.Generic.Base (+            -- * re-export+            Interval(..)+            -- * Map type+            , IntervalMap(..)      -- instance Eq,Show,Read++            -- * Operators+            , (!), (\\)++            -- * Query+            , null+            , size+            , member+            , notMember+            , lookup+            , findWithDefault++            -- ** Interval query+            , containing+            , intersecting+            , within+            +            -- * Construction+            , empty+            , singleton++            -- ** Insertion+            , insert+            , insertWith+            , insertWithKey+            , insertLookupWithKey+            +            -- ** Delete\/Update+            , delete+            , adjust+            , adjustWithKey+            , update+            , updateWithKey+            , updateLookupWithKey+            , alter++            -- * Combine++            -- ** Union+            , union+            , unionWith+            , unionWithKey+            , unions+            , unionsWith++            -- ** Difference+            , difference+            , differenceWith+            , differenceWithKey+            +            -- ** Intersection+            , intersection+            , intersectionWith+            , intersectionWithKey++            -- * Traversal+            -- ** Map+            , map+            , mapWithKey+            , mapAccum+            , mapAccumWithKey+            , mapAccumRWithKey+            , mapKeys+            , mapKeysWith+            , mapKeysMonotonic++            -- ** Fold+            , foldr, foldl+            , foldrWithKey, foldlWithKey+            , foldl', foldr'+            , foldrWithKey', foldlWithKey'++            -- * Conversion+            , elems+            , keys+            , keysSet+            , assocs++            -- ** Lists+            , toList+            , fromList+            , fromListWith+            , fromListWithKey++            -- ** Ordered lists+            , toAscList+            , toDescList+            , fromAscList+            , fromAscListWith+            , fromAscListWithKey+            , fromDistinctAscList++            -- * Filter+            , filter+            , filterWithKey+            , partition+            , partitionWithKey++            , mapMaybe+            , mapMaybeWithKey+            , mapEither+            , mapEitherWithKey++            , split+            , splitLookup++            -- * Submap+            , isSubmapOf, isSubmapOfBy+            , isProperSubmapOf, isProperSubmapOfBy++            -- * Min\/Max+            , findMin+            , findMax+            , findLast+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , updateMin+            , updateMax+            , updateMinWithKey+            , updateMaxWithKey+            , minView+            , maxView+            , minViewWithKey+            , maxViewWithKey++            -- * Internal, not re-exported by Data.IntervalMap.{Lazy,Strict}+            , Color(..)+            , balanceL, balanceR+            , turnBlack+            , setMinValue, setMaxValue++            -- * Debugging+            , valid++            -- * Testing+            , height, maxHeight, showStats++            ) where++import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import Data.Bits (shiftR, (.&.))+import Data.Monoid (Monoid(..))+import Control.Applicative (Applicative(..), (<$>))+import Data.Traversable (Traversable(traverse))+import qualified Data.Foldable as Foldable+import qualified Data.List as L+import qualified Data.Set as Set+import Control.DeepSeq (NFData(rnf))++import Data.IntervalMap.Generic.Interval++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | /O(log n)/. Lookup value for given key. Calls 'error' if the key is not in the map.+(!) :: (Interval k e, Ord k) => IntervalMap k v -> k -> v+tree ! key = case lookup key tree of+               Just v  -> v+               Nothing -> error "IntervalMap.!: key not found"++-- | Same as 'difference'.+(\\) :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+m1 \\ m2 = difference m1 m2+++data Color = R | B deriving (Eq, Read, Show)++-- | A map from intervals of type @k@ to values of type @v@.+data IntervalMap k v = Nil+                      | Node !Color+                             !k -- key+                             !k -- interval with maximum upper in tree+                             v             -- value+                             !(IntervalMap k v) -- left subtree+                             !(IntervalMap k v) -- right subtree++instance (Eq k, Eq v) => Eq (IntervalMap k v) where+  a == b = toAscList a == toAscList b++instance (Ord k, Ord v) => Ord (IntervalMap k v) where+  compare a b = compare (toAscList a) (toAscList b)++instance Functor (IntervalMap k) where+  fmap f m  = map f m++instance (Interval i k, Ord i) => Monoid (IntervalMap i v) where+    mempty  = empty+    mappend = union+    mconcat = unions++instance Traversable (IntervalMap k) where+  traverse _ Nil = pure Nil+  traverse f (Node c k m v l r)+    = flip (Node c k m) <$> traverse f l <*> f v <*> traverse f r++instance Foldable.Foldable (IntervalMap k) where+  fold Nil = mempty+  fold (Node _ _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r+  foldr = foldr+  foldl = foldl+  foldMap _ Nil = mempty+  foldMap f (Node _ _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r++instance (NFData k, NFData a) => NFData (IntervalMap k a) where+    rnf Nil = ()+    rnf (Node _ kx _ x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r++instance (Ord k, Read k, Read e, Interval i k, Ord i, Read i) => Read (IntervalMap i e) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)++instance (Show k, Show a) => Show (IntervalMap k a) where+  showsPrec d m  = showParen (d > 10) $+    showString "fromList " . shows (toList m)+++isRed :: IntervalMap k v -> Bool+isRed (Node R _ _ _ _ _) = True+isRed _ = False++turnBlack :: IntervalMap k v -> IntervalMap k v+turnBlack (Node R k m vs l r) = Node B k m vs l r+turnBlack t = t++turnRed :: IntervalMap k v -> IntervalMap k v+turnRed Nil = error "turnRed: Leaf"+turnRed (Node B k m v l r) = Node R k m v l r+turnRed t = t++-- construct node, recomputing the upper key bound.+mNode :: (Interval k e) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v+mNode c k v l r = Node c k (maxUpper k l r) v l r++maxUpper :: (Interval i k) => i -> IntervalMap i v -> IntervalMap i v -> i+maxUpper k Nil                Nil                = k `seq` k+maxUpper k Nil                (Node _ _ m _ _ _) = maxByUpper k m+maxUpper k (Node _ _ m _ _ _) Nil                = maxByUpper k m+maxUpper k (Node _ _ l _ _ _) (Node _ _ r _ _ _) = maxByUpper k (maxByUpper l r)++-- interval with the greatest upper bound. The lower bound is ignored!+maxByUpper :: (Interval i e) => i -> i -> i+maxByUpper a b | rightClosed a = if upperBound a >= upperBound b then a else b+               | otherwise     = if upperBound a >  upperBound b then a else b++-- ---------------------------------------------------------++-- | /O(1)/. The empty map.+empty :: IntervalMap k v+empty =  Nil++-- | /O(1)/. A map with one entry.+singleton :: k -> v -> IntervalMap k v+singleton k v = Node B k k v Nil Nil+++-- | /O(1)/. Is the map empty?+null :: IntervalMap k v -> Bool+null Nil = True+null _   = False++-- | /O(n)/. Number of keys in the map.+--+-- Caution: unlike 'Data.Map.size', which takes constant time, this is linear in the+-- number of keys!+size :: IntervalMap k v -> Int+size t = h 0 t+  where+    h n m = n `seq` case m of+                      Nil -> n+                      Node _ _ _ _ l r -> h (h n l + 1) r++-- | The height of the tree. For testing/debugging only.+height :: IntervalMap k v -> Int+height Nil = 0+height (Node _ _ _ _ l r) = 1 + max (height l) (height r)++-- | The maximum height of a red-black tree with the given number of nodes.+-- For testing/debugging only.+maxHeight :: Int -> Int+maxHeight nodes = 2 * log2 (nodes + 1)++-- | Tree statistics (size, height, maxHeight size).+-- For testing/debugging only.+showStats :: IntervalMap k a -> (Int, Int, Int)+showStats m = (n, height m, maxHeight n)+  where n = size m++-- | /O(log n)/. Does the map contain the given key? See also 'notMember'.+member :: (Ord k) => k -> IntervalMap k v -> Bool+member key tree = case lookup key tree of+                    Nothing -> False+                    Just _  -> True++-- | /O(log n)/. Does the map not contain the given key? See also 'member'.+notMember :: (Ord k) => k -> IntervalMap k v -> Bool+notMember key tree = not (member key tree)+++-- | /O(log n)/. Look up the given key in the map, returning the value @('Just' value)@,+-- or 'Nothing' if the key is not in the map.+lookup :: (Ord k) => k -> IntervalMap k v -> Maybe v+lookup k Nil =  k `seq` Nothing+lookup k (Node _ key _ v l r) = case compare k key of+                                  LT -> lookup k l+                                  GT -> lookup k r+                                  EQ -> Just v+++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a+findWithDefault def k m = case lookup k m of+    Nothing -> def+    Just x  -> x++-- | Return all key/value pairs where the key intervals contain the given point.+-- The elements are returned in ascending key order.+--+-- /O(n)/, since potentially all keys could contain the point.+-- /O(log n)/ average case. This is also the worst case for maps containing no overlapping keys.+containing :: (Interval k e) => IntervalMap k v -> e -> [(k, v)]+t `containing` pt = go [] pt t+  where+    go xs p Nil = p `seq` xs+    go xs p (Node _ k m v l r)+       | p `above` m  =  xs         -- above all intervals in the tree: no result+       | p `below` k  =  go xs p l  -- to the left of the lower bound: can't be in right subtree+       | p `inside` k =  go ((k,v) : go xs p r) p l+       | otherwise    =  go (go xs p r) p l++-- | Return all key/value pairs where the key intervals overlap (intersect) the given interval.+-- The elements are returned in ascending key order.+--+-- /O(n)/, since potentially all keys could intersect the interval.+-- /O(log n)/ average case, if few keys intersect the interval.+intersecting :: (Interval k e) => IntervalMap k v -> k -> [(k, v)]+t `intersecting` iv = go [] iv t+  where+    go xs i Nil = i `seq` xs+    go xs i (Node _ k m v l r)+       | i `after` m     =  xs+       | i `before` k    =  go xs i l+       | i `overlaps` k  =  go ((k,v) : go xs i r) i l+       | otherwise       =  go (go xs i r) i l++-- | Return all key/value pairs where the key intervals are completely inside the given interval.+-- The elements are returned in ascending key order.+--+-- /O(n)/, since potentially all keys could be inside the interval.+-- /O(log n)/ average case, if few keys are inside the interval.+within :: (Interval k e) => IntervalMap k v -> k -> [(k, v)]+t `within` iv = go [] iv t+  where+    go xs i Nil = i `seq` xs+    go xs i (Node _ k m v l r)+       | i `after` m     =  xs+       | i `before` k    =  go xs i l+       | i `subsumes` k  =  go ((k,v) : go xs i r) i l+       | otherwise       =  go (go xs i r) i l+++-- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is+-- changed to the new value.+insert :: (Interval k e, Ord k) => k -> v -> IntervalMap k v -> IntervalMap k v+insert =  insertWithKey (\_ v _ -> v)++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+insertWith :: (Interval k e, Ord k) => (v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v+insertWith f = insertWithKey (\_ new old -> f new old)++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+insertWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v+insertWithKey f key value mp  =  key `seq` turnBlack (ins mp)+  where+    singletonR k v = Node R k k v Nil Nil+    ins Nil = singletonR key value+    ins (Node color k m v l r) =+      case compare key k of+        LT -> balanceL color k v (ins l) r+        GT -> balanceR color k v l (ins r)+        EQ -> Node color k m (f k value v) l r++-- | /O(log n)/. Combine insert with old values retrieval.+insertLookupWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v)+insertLookupWithKey f key value mp  =  key `seq` (oldval, turnBlack mp')+  where+    (oldval, mp') = ins mp+    singletonR k v = Node R k k v Nil Nil+    ins Nil = (Nothing, singletonR key value)+    ins (Node color k m v l r) =+      case compare key k of+        LT -> case ins l of+                 (x@(Just _), t') -> (x, Node color k m v t' r)+                 (Nothing, t') -> (Nothing, balanceL color k v t' r)+        GT -> case ins r of+                 (x@(Just _), t') -> (x, Node color k m v l t')+                 (Nothing, t') -> (Nothing, balanceR color k v l t')+        EQ -> (Just v, Node color k m (f k value v) l r)+++balanceL :: (Interval k e) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v+balanceL B zk zv (Node R yk _ yv (Node R xk _ xv a b) c) d =+    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceL B zk zv (Node R xk _ xv a (Node R yk _ yv b c)) d =+    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceL c xk xv l r = mNode c xk xv l r++balanceR :: (Interval k e) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v+balanceR B xk xv a (Node R yk _ yv b (Node R zk _ zv c d)) =+    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceR B xk xv a (Node R zk _ zv (Node R yk _ yv b c) d) =+    mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceR c xk xv l r = mNode c xk xv l r+++-- min/max++-- | /O(log n)/. Returns the smallest key and its associated value.+-- Calls 'error' if the map is empty.+findMin :: IntervalMap k v -> (k, v)+findMin (Node _ k _ v Nil _) = (k,v)+findMin (Node _ _ _ _ l _) = findMin l+findMin Nil = error "IntervalMap.findMin: empty map"++-- | /O(log n)/. Returns the largest key and its associated value.+-- Calls 'error' if the map is empty.+findMax :: IntervalMap k v -> (k, v)+findMax (Node _ k _ v _ Nil) = (k,v)+findMax (Node _ _ _ _ _ r) = findMax r+findMax Nil = error "IntervalMap.findMin: empty map"++-- | Returns the interval with the largest endpoint.+-- If there is more than one interval with that endpoint,+-- return the rightmost.+--+-- /O(n)/, since all keys could have the same endpoint.+-- /O(log n)/ average case.+findLast :: (Interval k e) => IntervalMap k v -> (k, v)+findLast Nil = error "IntervalMap.findLast: empty map"+findLast t@(Node _ _ mx _ _ _) = lastMax+  where+    (lastMax : _) = go t+    go Nil = []+    go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ ((k,v) : go l)+                                                      else go r ++ go l+                          | otherwise  = []+    sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b+++-- Type to indicate whether the number of black nodes changed or stayed the same.+data DeleteResult k v = U !(IntervalMap k v)   -- Unchanged+                      | S !(IntervalMap k v)   -- Shrunk++unwrap :: DeleteResult k v -> IntervalMap k v+unwrap (U m) = m+unwrap (S m) = m++-- DeleteResult with value+data DeleteResult' k v a = U' !(IntervalMap k v) a+                         | S' !(IntervalMap k v) a++unwrap' :: DeleteResult' k v a -> IntervalMap k v+unwrap' (U' m _) = m+unwrap' (S' m _) = m++-- annotate DeleteResult with value+annotate :: DeleteResult k v -> a -> DeleteResult' k v a+annotate (U m) x = U' m x+annotate (S m) x = S' m x+++-- | /O(log n)/. Remove the smallest key from the map. Return the empty map if the map is empty.+deleteMin :: (Interval k e, Ord k) => IntervalMap k v -> IntervalMap k v+deleteMin Nil = Nil+deleteMin m   = turnBlack (unwrap' (deleteMin' m))++deleteMin' :: (Interval k e, Ord k) => IntervalMap k v -> DeleteResult' k v (k, v)+deleteMin' Nil = error "deleteMin': Nil"+deleteMin' (Node B k _ v Nil Nil) = S' Nil (k,v)+deleteMin' (Node B k _ v Nil r@(Node R _ _ _ _ _)) = U' (turnBlack r) (k,v)+deleteMin' (Node R k _ v Nil r) = U' r (k,v)+deleteMin' (Node c k _ v l r) =+  case deleteMin' l of+    (U' l' kv) -> U' (mNode c k v l' r) kv+    (S' l' kv) -> annotate (unbalancedR c k v l' r) kv++deleteMax' :: (Interval k e, Ord k) => IntervalMap k v -> DeleteResult' k v (k, v)+deleteMax' Nil = error "deleteMax': Nil"+deleteMax' (Node B k _ v Nil Nil) = S' Nil (k,v)+deleteMax' (Node B k _ v l@(Node R _ _ _ _ _) Nil) = U' (turnBlack l) (k,v)+deleteMax' (Node R k _ v l Nil) = U' l (k,v)+deleteMax' (Node c k _ v l r) =+  case deleteMax' r of+    (U' r' kv) -> U' (mNode c k v l r') kv+    (S' r' kv) -> annotate (unbalancedL c k v l r') kv++-- The left tree lacks one Black node+unbalancedR :: (Interval k e, Ord k) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v+-- Decreasing one Black node in the right+unbalancedR B k v l r@(Node B _ _ _ _ _) = S (balanceR B k v l (turnRed r))+unbalancedR R k v l r@(Node B _ _ _ _ _) = U (balanceR B k v l (turnRed r))+-- Taking one Red node from the right and adding it to the right as Black+unbalancedR B k v l (Node R rk _ rv rl@(Node B _ _ _ _ _) rr)+  = U (mNode B rk rv (balanceR B k v l (turnRed rl)) rr)+unbalancedR _ _ _ _ _ = error "unbalancedR"++unbalancedL :: (Interval k e, Ord k) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v+unbalancedL R k v l@(Node B _ _ _ _ _) r = U (balanceL B k v (turnRed l) r)+unbalancedL B k v l@(Node B _ _ _ _ _) r = S (balanceL B k v (turnRed l) r)+unbalancedL B k v (Node R lk _ lv ll lr@(Node B _ _ _ _ _)) r+  = U (mNode B lk lv ll (balanceL B k v (turnRed lr) r))+unbalancedL _ _ _ _ _ = error "unbalancedL"++++-- | /O(log n)/. Remove the largest key from the map. Return the empty map if the map is empty.+deleteMax :: (Interval k e, Ord k) => IntervalMap k v -> IntervalMap k v+deleteMax Nil = Nil+deleteMax m   = turnBlack (unwrap' (deleteMax' m))++-- | /O(log n)/. Delete and return the smallest key.+deleteFindMin :: (Interval k e, Ord k) => IntervalMap k v -> ((k,v), IntervalMap k v)+deleteFindMin mp = case deleteMin' mp of+                     (U' r v) -> (v, turnBlack r)+                     (S' r v) -> (v, turnBlack r)++-- | /O(log n)/. Delete and return the largest key.+deleteFindMax :: (Interval k e, Ord k) => IntervalMap k v -> ((k,v), IntervalMap k v)+deleteFindMax mp = case deleteMax' mp of+                     (U' r v) -> (v, turnBlack r)+                     (S' r v) -> (v, turnBlack r)++-- | /O(log n)/. Update or delete value at minimum key.+updateMin :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMin f m = updateMinWithKey (\_ v -> f v) m++-- | /O(log n)/. Update or delete value at maximum key.+updateMax :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMax f m = updateMaxWithKey (\_ v -> f v) m++-- | /O(log n)/. Update or delete value at minimum key.+updateMinWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMinWithKey _ Nil = Nil+updateMinWithKey f m = let (k,v) = findMin m in+                       case f k v of+                         Just v' -> setMinValue v' m+                         Nothing -> deleteMin m++-- | /O(log n)/. Update or delete value at maximum key.+updateMaxWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMaxWithKey _ Nil = Nil+updateMaxWithKey f m = let (k,v) = findMax m in+                       case f k v of+                         Just v' -> setMaxValue v' m+                         Nothing -> deleteMax m++-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: (Interval k e, Ord k) => IntervalMap k a -> Maybe ((k, a), IntervalMap k a)+minViewWithKey Nil = Nothing+minViewWithKey x   = Just (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+maxViewWithKey :: (Interval k e, Ord k) => IntervalMap k a -> Maybe ((k, a), IntervalMap k a)+maxViewWithKey Nil = Nothing+maxViewWithKey x   = Just (deleteFindMax x)++-- | /O(log n)/. Retrieves the value associated with minimal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+minView :: (Interval k e, Ord k) => IntervalMap k a -> Maybe (a, IntervalMap k a)+minView Nil = Nothing+minView x   = case deleteFindMin x of ((_,a), x') -> Just (a, x')++-- | /O(log n)/. Retrieves the value associated with maximal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+maxView :: (Interval k e, Ord k) => IntervalMap k a -> Maybe (a, IntervalMap k a)+maxView Nil = Nothing+maxView x   = case deleteFindMax x of ((_,a), x') -> Just (a, x')+++setMinValue :: v -> IntervalMap k v -> IntervalMap k v+setMinValue _  Nil = Nil+setMinValue v' (Node c k m _ Nil r) = Node c k m v' Nil r+setMinValue v' (Node c k m v l   r) = Node c k m v (setMinValue v' l) r++setMaxValue :: v -> IntervalMap k v -> IntervalMap k v+setMaxValue _  Nil = Nil+setMaxValue v' (Node c k m _ l Nil) = Node c k m v' l Nil+setMaxValue v' (Node c k m v l r)   = Node c k m v l (setMaxValue v' r)++++-- folding++-- | /O(n)/. Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+foldr :: (a -> b -> b) -> b -> IntervalMap k a -> b+foldr _ z Nil = z+foldr f z (Node _ _ _ x l r) = foldr f (f x (foldr f z r)) l++-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> IntervalMap k a -> b+foldr' f z m = z `seq` case m of+                         Nil -> z+                         Node _ _ _ x l r -> foldr' f (f x (foldr' f z r)) l++-- | /O(n)/. Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+foldl :: (b -> a -> b) -> b -> IntervalMap k a -> b+foldl _ z Nil = z+foldl f z (Node _ _ _ x l r) = foldl f (f (foldl f z l) x) r++-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (b -> a -> b) -> b -> IntervalMap k a -> b+foldl' f z m = z `seq` case m of+                         Nil -> z+                         Node _ _ _ x l r -> foldl' f (f (foldl' f z l) x) r++-- | /O(n)/. Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+foldrWithKey :: (k -> v -> a -> a) -> a -> IntervalMap k v -> a+foldrWithKey _ z Nil = z+foldrWithKey f z (Node _ k _ x l r) = foldrWithKey f (f k x (foldrWithKey f z r)) l++-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (k -> v -> a -> a) -> a -> IntervalMap k v -> a+foldrWithKey' f z m = z `seq` case m of+                                Nil -> z+                                Node _ k _ x l r -> foldrWithKey' f (f k x (foldrWithKey' f z r)) l++-- | /O(n)/. Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+foldlWithKey :: (a -> k -> v -> a) -> a -> IntervalMap k v -> a+foldlWithKey _ z Nil = z+foldlWithKey f z (Node _ k _ x l r) = foldlWithKey f (f (foldlWithKey f z l) k x) r++-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> k -> v -> a) -> a -> IntervalMap k v -> a+foldlWithKey' f z m = z `seq` case m of+                                Nil -> z+                                Node _ k _ x l r -> foldlWithKey' f (f (foldlWithKey' f z l) k x) r++-- delete++-- | /O(log n)/. Delete a key from the map. If the map does not contain the key,+-- it is returned unchanged.+delete :: (Interval k e, Ord k) => k -> IntervalMap k v -> IntervalMap k v+delete key mp = turnBlack (unwrap (delete' key mp))++delete' :: (Interval k e, Ord k) => k -> IntervalMap k v -> DeleteResult k v+delete' x Nil = x `seq` U Nil+delete' x (Node c k _ v l r) =+  case compare x k of+    LT -> case delete' x l of+            (U l') -> U (mNode c k v l' r)+            (S l')    -> unbalancedR c k v l' r+    GT -> case delete' x r of+            (U r') -> U (mNode c k v l r')+            (S r')    -> unbalancedL c k v l r'+    EQ -> case r of+            Nil -> if c == B then blackify l else U l+            _ -> case deleteMin' r of+                   (U' r' (rk,rv)) -> U (mNode c rk rv l r')+                   (S' r' (rk,rv)) -> unbalancedL c rk rv l r'++blackify :: IntervalMap k v -> DeleteResult k v+blackify (Node R k m v l r) = U (Node B k m v l r)+blackify s                  = S s++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+adjust :: Ord k => (a -> a) -> k -> IntervalMap k a -> IntervalMap k a+adjust f k m = adjustWithKey (\_ v -> f v) k m++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: Ord k => (k -> a -> a) -> k -> IntervalMap k a -> IntervalMap k a+adjustWithKey _ _ Nil = Nil+adjustWithKey f x (Node c k m v l r) =+  case compare x k of+    LT -> Node c k m v (adjustWithKey f x l) r+    GT -> Node c k m v l (adjustWithKey f x r)+    EQ -> Node c k m (f k v) l r++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: (Interval k e, Ord k) => (a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a+update f k m = updateWithKey (\_ v -> f v) k m++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+updateWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a+updateWithKey f k m = snd (updateLookupWithKey f k m)++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+updateLookupWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> (Maybe a, IntervalMap k a)+updateLookupWithKey f x m = case lookup x m of+                              Nothing -> (Nothing, m)+                              r@(Just v) -> case f x v of+                                              Nothing -> (r, delete x m)+                                              r'@(Just v') -> (r', adjust (const v') x m)++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Interval k e, Ord k) => (Maybe a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a+alter f x m = case lookup x m of+                Nothing -> case f Nothing of+                             Nothing -> m+                             Just v -> insert x v m+                y       -> case f y of+                             Nothing -> delete x m+                             Just v' -> adjust (const v') x m+++-- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+union :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k a -> IntervalMap k a+union m1 m2 = unionWithKey (\_ v _ -> v) m1 m2++-- | /O(n+m)/. Union with a combining function.+unionWith :: (Interval k e, Ord k) => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2++-- | /O(n+m)/. Union with a combining function.+unionWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2))++-- | The union of a list of maps:+--   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: (Interval k e, Ord k) => [IntervalMap k a] -> IntervalMap k a+unions = L.foldl union empty++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: (Interval k e, Ord k) => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a+unionsWith f = L.foldl (unionWith f) empty++-- | /O(n+m)/. Difference of two maps. +-- Return elements of the first map not existing in the second map.+difference :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+difference m1 m2 = differenceWithKey (\_ _ _ -> Nothing) m1 m2++-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWith :: (Interval k e, Ord k) => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a+differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWithKey :: (Interval k e, Ord k) => (k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a+differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2))++-- | /O(n+m)/. Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+intersection :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+intersection m1 m2 = intersectionWithKey (\_ v _ -> v) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+intersectionWith :: (Interval k e, Ord k) => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+intersectionWithKey :: (Interval k e, Ord k) => (k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2))++ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)]+ascListUnion _ [] [] = []+ascListUnion _ [] ys = ys+ascListUnion _ xs [] = xs+ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') =+  case compare xk yk of+    LT -> x : ascListUnion f xs' ys+    GT -> y : ascListUnion f xs ys'+    EQ -> (xk, f xk xv yv) : ascListUnion f xs' ys'++ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)]+ascListDifference _ [] _  = []+ascListDifference _ xs [] = xs+ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') =+  case compare xk yk of+    LT -> x : ascListDifference f xs' ys+    GT -> ascListDifference f xs ys'+    EQ -> case f xk xv yv of+            Nothing -> ascListDifference f xs' ys'+            Just v' -> (xk,v') : ascListDifference f xs' ys'++ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)]+ascListIntersection _ [] _ = []+ascListIntersection _ _ [] = []+ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') =+  case compare xk yk of+    LT -> ascListIntersection f xs' ys+    GT -> ascListIntersection f xs ys'+    EQ -> (xk, f xk xv yv) : ascListIntersection f xs' ys'+++-- --- Conversion ---++-- | /O(n)/. The list of all key\/value pairs contained in the map, in ascending order of keys.+toAscList :: IntervalMap k v -> [(k,v)]+toAscList m = foldrWithKey (\k v r -> (k,v) : r) [] m++-- | /O(n)/. The list of all key\/value pairs contained in the map, in no particular order.+toList :: IntervalMap k v -> [(k,v)]+toList m = toAscList m++-- | /O(n)/. The list of all key\/value pairs contained in the map, in descending order of keys.+toDescList :: IntervalMap k v -> [(k, v)]+toDescList m = foldlWithKey (\r k v -> (k,v) : r) [] m++-- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: (Interval k e, Ord k) => [(k,v)] -> IntervalMap k v+fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs++-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWith :: (Interval k e, Ord k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs++-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromListWithKey f xs = L.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: (Interval k e, Eq k) => [(k,v)] -> IntervalMap k v+fromAscList xs = fromAscListWith (\_ b -> b) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWith :: (Interval k e, Eq k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWithKey :: (Interval k e, Eq k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs)++combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)]+combineEq _ [] = []+combineEq _ xs@[_] = xs+combineEq f (x@(xk,xv) : xs@((yk,yv) : xs'))+  | xk == yk  = combineEq f ((xk, f xk xv yv) : xs')+  | otherwise = x : combineEq f xs+++-- Strict tuple+data T2 a b = T2 !a !b+++-- | /O(n)/. Build a map from an ascending list of elements with distinct keys in linear time.+-- /The precondition is not checked./+fromDistinctAscList :: (Interval k e) => [(k,v)] -> IntervalMap k v+-- exactly 2^n-1 items have height n. They can be all black+-- from 2^n - 2^n-2 items have height n+1. The lowest "row" should be red.+fromDistinctAscList lyst = case h (length lyst) lyst of+                             (T2 result []) -> result+                             _ -> error "fromDistinctAscList: list not fully consumed"+  where+    h n xs | n == 0      = T2 Nil xs+           | isPerfect n = buildB n xs+           | otherwise   = buildR n (log2 n) xs++    buildB n xs | xs `seq` n <= 0 = error "fromDictinctAscList: buildB 0"+                | n == 1     = case xs of ((k,v):xs') -> T2 (Node B k k v Nil Nil) xs'+                                          _ -> error "fromDictinctAscList: buildB 1"+                | otherwise  =+                     case n `quot` 2 of { n' ->+                     case buildB n' xs of { (T2 _ []) -> error "fromDictinctAscList: buildB n";+                                            (T2 l ((k,v):xs')) ->+                     case buildB n' xs' of { (T2 r xs'') ->+                     T2 (mNode B k v l r) xs'' }}}++    buildR n d xs | d `seq` xs `seq` n == 0 = T2 Nil xs+                  | n == 1    = case xs of ((k,v):xs') -> T2 (Node (if d==0 then R else B) k k v Nil Nil) xs'+                                           _ -> error "fromDistinctAscList: buildR 1"+                  | otherwise =+                      case n `quot` 2 of { n' ->+                      case buildR n' (d-1) xs of { (T2 _ []) -> error "fromDistinctAscList: buildR n";+                                                   (T2 l ((k,v):xs')) ->+                      case buildR (n - (n' + 1)) (d-1) xs' of { (T2 r xs'') ->+                      T2 (mNode B k v l r) xs'' }}}+++-- is n a perfect binary tree size (2^m-1)?+isPerfect :: Int -> Bool+isPerfect n = (n .&. (n + 1)) == 0++log2 :: Int -> Int+log2 m = h (-1) m+  where+    h r n | r `seq` n <= 0 = r+          | otherwise      = h (r + 1) (n `shiftR` 1)+++-- | /O(n)/. List of all values in the map, in ascending order of their keys.+elems :: IntervalMap k v -> [v]+elems m = [v | (_,v) <- toAscList m]++-- | /O(n)/. List of all keys in the map, in ascending order.+keys :: IntervalMap k v -> [k]+keys m = [k | (k,_) <- toAscList m]++-- | /O(n)/. Set of the keys.+keysSet :: (Ord k) => IntervalMap k v -> Set.Set k+keysSet m =  Set.fromDistinctAscList (keys m)++-- | Same as 'toAscList'.+assocs :: IntervalMap k v -> [(k, v)]+assocs m = toAscList m++-- --- Mapping ---++-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntervalMap k a -> IntervalMap k b+map f = mapWithKey (\_ x -> f x)++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (k -> a -> b) -> IntervalMap k a -> IntervalMap k b+mapWithKey f = go+  where+    go Nil = Nil+    go (Node c k m v l r) = Node c k m (f k v) (go l) (go r)++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])+mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])+mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumWithKey f = go+  where+    go a Nil               = (a,Nil)+    go a (Node c kx m x l r) =+                 let (a1,l') = go a l+                     (a2,x') = f a1 kx x+                     (a3,r') = go a2 r+                 in (a3, Node c kx m x' l' r')++-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumRWithKey f = go+  where+    go a Nil = (a, Nil)+    go a (Node c kx m x l r) =+                 let (a1,r') = go a r+                     (a2,x') = f a1 kx x+                     (a3,l') = go a2 l+                 in (a3, Node c kx m x' l' r')+++-- | /O(n log n)/. @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the smallest of+-- these keys is retained.+mapKeys :: (Interval k2 e, Ord k2) => (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeys f m = fromList [ (f k, v) | (k, v) <- toDescList m ]++-- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+mapKeysWith :: (Interval k2 e, Ord k2) => (a -> a -> a) -> (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ]++-- | /O(n log n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+mapKeysMonotonic :: (Interval k2 e, Ord k2) => (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeysMonotonic _ Nil = Nil+mapKeysMonotonic f (Node c k _ x l r) =+    mNode c (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++-- | /O(n)/. Filter values satisfying a predicate.+filter :: (Interval k e) => (a -> Bool) -> IntervalMap k a -> IntervalMap k a+filter p m = filterWithKey (\_ v -> p v) m++-- | /O(n)/. Filter keys\/values satisfying a predicate.+filterWithKey :: (Interval k e) => (k -> a -> Bool) -> IntervalMap k a -> IntervalMap k a+filterWithKey p m = mapMaybeWithKey (\k v -> if p k v then Just v else Nothing) m++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: (Interval k e) => (a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)+partition p m = partitionWithKey (\_ v -> p v) m++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: (Interval k e) => (k -> a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)+partitionWithKey p m = mapEitherWithKey p' m+  where+    p' k v | p k v     = Left v+           | otherwise = Right v++-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: (Interval k e) => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b+mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: (Interval k e) => (k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b+mapMaybeWithKey f m = fromDistinctAscList (mapf [] m)+  where+    mapf z Nil = z+    mapf z (Node _ k _ v l r) = mapf (f' k v z r) l+    f' k v z r = case f k v of+                   Nothing -> mapf z r+                   Just v' -> (k,v') : mapf z r++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+mapEither :: (Interval k e) => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)+mapEither f m = mapEitherWithKey (\_ v -> f v) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: (Interval i k) => (i -> a -> Either b c) -> IntervalMap i a -> (IntervalMap i b, IntervalMap i c)+mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r)+  where+    (l, r) = part [] [] (toDescList m)+    part ls rs [] = (ls, rs)+    part ls rs ((k,v):xs) = case f k v of+                              Left v'  -> part ((k,v'):ls) rs xs+                              Right v' -> part ls ((k,v'):rs) xs++-- | /O(n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+split :: (Interval i k, Ord i) => i -> IntervalMap i a -> (IntervalMap i a, IntervalMap i a)+split x m = (l, r)+  where (l, _, r) = splitLookup x m+     +-- | /O(n)/. The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+splitLookup :: (Interval i k, Ord i) => i -> IntervalMap i a -> (IntervalMap i a, Maybe a, IntervalMap i a)+splitLookup x m = (fromDistinctAscList less, lookup x m, fromDistinctAscList greater)+  where+    less    = [e | e@(k,_) <- toAscList m, k < x]+    greater = [e | e@(k,_) <- toAscList m, k > x]++-- submaps++-- | /O(n+m)/. This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and @f@ returns 'True' when+ applied to their respective values.+-}+isSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool+isSubmapOfBy f m1 m2 = go (toAscList m1) (toAscList m2)+  where+    go []    _  =  True+    go (_:_) [] =  False+    go s1@((k1,v1):r1) ((k2,v2):r2) =+       case compare k1 k2 of+         GT -> go s1 r2+         EQ -> f v1 v2 && go r1 r2+         LT -> False++-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool+isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2++{- | /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,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values.+-}+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool+isProperSubmapOfBy f t1 t2 = size t1 < size t2 && isSubmapOfBy f t1 t2+++-- debugging++-- | Check red-black-tree and interval search augmentation invariants.+-- For testing/debugging only.+valid :: (Interval i k, Ord i) => IntervalMap i v -> Bool+valid mp = test mp && height mp <= maxHeight (size mp) && validColor mp+  where+    test Nil = True+    test n@(Node _ _ _ _ l r) = validOrder n && validMax n && test l && test r+    validMax (Node _ k m _ lo hi) =  m == maxUpper k lo hi+    validMax Nil = True++    validOrder (Node _ _ _ _ Nil Nil) = True+    validOrder (Node _ k1 _ _ Nil (Node _ k2 _ _ _ _)) = k1 < k2+    validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) Nil) = k1 < k2+    validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) (Node _ k3 _ _ _ _)) = k1 < k2 && k2 < k3+    validOrder Nil = True++    -- validColor parentColor blackCount tree+    validColor n = blackDepth n >= 0++    -- return -1 if subtrees have diffrent black depths or two consecutive red nodes are encountered+    blackDepth :: IntervalMap k v -> Int+    blackDepth Nil  = 0+    blackDepth (Node c _ _ _ l r) = case blackDepth l of+                                      ld -> if ld < 0 then ld+                                            else+                                              case blackDepth r of+                                                rd -> if rd < 0 then rd+                                                      else if rd /= ld then -1+                                                      else if c == R && (isRed l || isRed r) then -1+                                                      else if c == B then rd + 1+                                                      else rd+

@@ -0,0 +1,112 @@+-- |+-- Module      :  Data.IntervalMap.Generic.Interval+-- Copyright   :  (c) Christoph Breitkopf 2014+-- License     :  BSD-style+-- Maintainer  :  chbreitkopf@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Data.IntervalMap.Generic.Interval (+    -- * Interval type+    Interval(..),+    -- * helper functions for declaring Eq and Ord instances+    genericEquals, genericCompare+) where++import qualified Data.IntervalMap.Interval as I+++-- | Intervals with endpoints of type @e@.+-- A minimal instance declaration needs to define 'con', 'lowerBound', and 'upperBound'.+class Ord e => Interval i e | i -> e where+  --  Construct interval from endpoints+  -- con :: e -> e -> i e++  -- | lower and upper bound+  lowerBound, upperBound :: i -> e++  -- | Does the interval include its lower bound?+  -- Default is True for all values, i.e. closed intervals.+  leftClosed :: i -> Bool+  leftClosed  _ = True++  -- | Does the interval include its upper bound bound?+  -- Default is True for all values, i.e. closed intervals.+  rightClosed :: i -> Bool+  rightClosed _ = True++  overlaps, subsumes, before, after :: i -> i -> Bool+  a `before` b = upperBound a < lowerBound b+                 || (upperBound a == lowerBound b && not (rightClosed a && leftClosed b))+  a `after` b  = lowerBound a > upperBound b+                 || (lowerBound a == upperBound b && not (leftClosed a && rightClosed b))+  a `subsumes` b = (lowerBound a < lowerBound b || (lowerBound a == lowerBound b && (leftClosed a || not (leftClosed b))))+                   &&+                   (upperBound a > upperBound b || (upperBound a == upperBound b && (rightClosed a || not (rightClosed b))))+  a `overlaps` b = (lowerBound a < upperBound b || (lowerBound a == upperBound b && leftClosed a && rightClosed b))+                   &&+                   (upperBound a > lowerBound b || (upperBound a == lowerBound b && rightClosed a && leftClosed b))++  above, below, inside :: e -> i -> Bool+  p `below` i | leftClosed i  = p <  lowerBound i+              | otherwise     = p <= lowerBound i+  p `above` i | rightClosed i = p >  upperBound i+              | otherwise     = p >= upperBound i+  p `inside` i = not ((p `above` i) || (p `below` i)) ++  isEmpty :: i -> Bool+  isEmpty i | leftClosed i && rightClosed i = lowerBound i >  upperBound i+            | otherwise                     = lowerBound i >= upperBound i++{-+-- sample instance for tuples:+instance Ord e => Interval (e,e) e where+  lowerBound (a,_) = a+  upperBound (_,b) = b+-}++genericEquals :: (Interval i e, Eq e) => i -> i -> Bool+genericEquals a b = lowerBound a == lowerBound b && upperBound a == upperBound b+                    && leftClosed a == leftClosed b+                    && rightClosed a == rightClosed b++genericCompare :: (Interval i e, Ord e) => i -> i -> Ordering+genericCompare a b = case compareL a b of+                       LT -> LT+                       GT -> GT+                       EQ -> compareU a b++compareL :: (Interval i e, Ord e) => i -> i -> Ordering+compareL a b = case compare (lowerBound a) (lowerBound b) of+                 LT -> LT+                 GT -> GT+                 EQ -> case (leftClosed a, leftClosed b) of+                         (True, False) -> LT+                         (False, True) -> GT+                         _ -> EQ++compareU :: (Interval i e, Ord e) => i -> i -> Ordering+compareU a b = case compare (upperBound a) (upperBound b) of+                 LT -> LT+                 GT -> GT+                 EQ -> case (rightClosed a, rightClosed b) of+                         (True, False) -> GT+                         (False, True) -> LT+                         _ -> EQ++instance Ord a => Interval (I.Interval a) a where+    lowerBound  = I.lowerBound+    upperBound  = I.upperBound+    leftClosed  = I.leftClosed+    rightClosed = I.rightClosed+    overlaps    = I.overlaps+    subsumes    = I.subsumes+    before      = I.before+    after       = I.after+    above       = I.above+    below       = I.below+    inside      = I.inside+    isEmpty     = I.isEmpty

@@ -0,0 +1,155 @@+{- |+Module      :  Data.IntervalMap.Lazy+Copyright   :  (c) Christoph Breitkopf 2011+License     :  BSD-style+Maintainer  :  chbreitkopf@gmail.com+Stability   :  experimental+Portability :  portable++An implementation of maps from intervals to values. The key intervals may+overlap, and the implementation contains efficient search functions+for all keys containing a point or overlapping an interval.+Closed, open, and half-open intervals can be contained in the same map.++This module implements the same functions as "Data.IntervalMap.Strict",+but with value-lazy semantics.+-}+module Data.IntervalMap.Generic.Lazy (+            -- * re-export+            Interval(..)+            -- * Map type+            , IntervalMap      -- instance Eq,Show,Read++            -- * Operators+            , (!), (\\)++            -- * Query+            , M.null+            , size+            , member+            , notMember+            , M.lookup+            , findWithDefault++            -- ** Interval query+            , containing+            , intersecting+            , within+            +            -- * Construction+            , empty+            , singleton++            -- ** Insertion+            , insert+            , insertWith+            , insertWithKey+            , insertLookupWithKey+            +            -- ** Delete\/Update+            , delete+            , adjust+            , adjustWithKey+            , update+            , updateWithKey+            , updateLookupWithKey+            , alter++            -- * Combine++            -- ** Union+            , union+            , unionWith+            , unionWithKey+            , unions+            , unionsWith++            -- ** Difference+            , difference+            , differenceWith+            , differenceWithKey+            +            -- ** Intersection+            , intersection+            , intersectionWith+            , intersectionWithKey++            -- * Traversal+            -- ** Map+            , M.map+            , mapWithKey+            , mapAccum+            , mapAccumWithKey+            , mapAccumRWithKey+            , mapKeys+            , mapKeysWith+            , mapKeysMonotonic++            -- ** Fold+            , M.foldr, M.foldl+            , foldrWithKey, foldlWithKey++            -- * Conversion+            , elems+            , keys+            , keysSet+            , assocs++            -- ** Lists+            , toList+            , fromList+            , fromListWith+            , fromListWithKey++            -- ** Ordered lists+            , toAscList+            , toDescList+            , fromAscList+            , fromAscListWith+            , fromAscListWithKey+            , fromDistinctAscList++            -- * Filter+            , M.filter+            , filterWithKey+            , partition+            , partitionWithKey++            , mapMaybe+            , mapMaybeWithKey+            , mapEither+            , mapEitherWithKey++            , split+            , splitLookup++            -- * Submap+            , isSubmapOf, isSubmapOfBy+            , isProperSubmapOf, isProperSubmapOfBy++            -- * Min\/Max+            , findMin+            , findMax+            , findLast+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , updateMin+            , updateMax+            , updateMinWithKey+            , updateMaxWithKey+            , minView+            , maxView+            , minViewWithKey+            , maxViewWithKey++            -- * Debugging+            , valid++            -- * Testing+            , height, maxHeight, showStats++            ) where++import Data.IntervalMap.Generic.Base as M

@@ -0,0 +1,567 @@+{- |+Module      :  Data.IntervalMap.Generic.Strict+Copyright   :  (c) Christoph Breitkopf 2014+License     :  BSD-style+Maintainer  :  chbreitkopf@gmail.com+Stability   :  experimental+Portability :  portable++An implementation of maps from intervals to values. The key intervals+may overlap, and the implementation contains efficient search+functions for all keys containing a point or overlapping an+interval. Closed, open, and half-open intervals can be contained in+the same map.++The functions in this module are strict in both the keys and the+values.  If you need value-lazy maps, use "Data.IntervalMap.Lazy"+instead. The IntervalMap type itself is shared between the lazy and+strict modules, meaning that the same IntervalMap value can be passed+to functions in both modules (although that is rarely needed).++An IntervalMap cannot contain duplicate keys - if you need to map a+key to multiple values, use a collection as the value type, for+example: @IntervalMap /k/ [/v/]@.++It is an error to insert an empty interval into a map. This+precondition is not checked by the various construction functions.++Since many function names (but not the type name) clash with /Prelude/+names, this module is usually imported @qualified@, e.g.++>  import Data.IntervalMap (IvMap)+>  import qualified Data.IntervalMap as IvMap++It offers most of the same functions as 'Data.Map', but uses+'Interval' /k/ instead of just /k/ as the key type. Some of the+functions need stricter type constraints to maintain the additional+information for efficient interval searching, for example+'fromDistinctAscList' needs an 'Ord' /k/ constraint. Also, some+functions differ in asymptotic performance (for example 'size') or+have not been tuned for efficiency as much as their equivalents in+'Data.Map' (in particular the various set functions).++In addition, there are functions specific to maps of intervals, for+example to search for all keys containing a given point or contained+in a given interval.++The implementation is a red-black tree augmented with the maximum+upper bound of all keys.++Parts of this implementation are based on code from the 'Data.Map'+implementation, (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008. The+red-black tree deletion is based on code from llrbtree by Kazu+Yamamoto. Of course, any errors are mine.+-}+module Data.IntervalMap.Generic.Strict (+            -- * re-export+            Interval(..)+            -- * Map type+            , IntervalMap      -- instance Eq,Show,Read++            -- * Operators+            , (!), (\\)++            -- * Query+            , null+            , size+            , member+            , notMember+            , lookup+            , findWithDefault++            -- ** Interval query+            , containing+            , intersecting+            , within+            +            -- * Construction+            , empty+            , singleton++            -- ** Insertion+            , insert+            , insertWith+            , insertWithKey+            , insertLookupWithKey+            +            -- ** Delete\/Update+            , delete+            , adjust+            , adjustWithKey+            , update+            , updateWithKey+            , updateLookupWithKey+            , alter++            -- * Combine++            -- ** Union+            , union+            , unionWith+            , unionWithKey+            , unions+            , unionsWith++            -- ** Difference+            , difference+            , differenceWith+            , differenceWithKey+            +            -- ** Intersection+            , intersection+            , intersectionWith+            , intersectionWithKey++            -- * Traversal+            -- ** Map+            , map+            , mapWithKey+            , mapAccum+            , mapAccumWithKey+            , mapAccumRWithKey+            , mapKeys+            , mapKeysWith+            , mapKeysMonotonic++            -- ** Fold+            , foldr, foldl+            , foldrWithKey, foldlWithKey++            -- * Conversion+            , elems+            , keys+            , keysSet+            , assocs++            -- ** Lists+            , toList+            , fromList+            , fromListWith+            , fromListWithKey++            -- ** Ordered lists+            , toAscList+            , toDescList+            , fromAscList+            , fromAscListWith+            , fromAscListWithKey+            , fromDistinctAscList++            -- * Filter+            , filter+            , filterWithKey+            , partition+            , partitionWithKey++            , mapMaybe+            , mapMaybeWithKey+            , mapEither+            , mapEitherWithKey++            , split+            , splitLookup++            -- * Submap+            , isSubmapOf, isSubmapOfBy+            , isProperSubmapOf, isProperSubmapOfBy++            -- * Min\/Max+            , findMin+            , findMax+            , findLast+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , updateMin+            , updateMax+            , updateMinWithKey+            , updateMaxWithKey+            , minView+            , maxView+            , minViewWithKey+            , maxViewWithKey++            -- * Debugging+            , valid++            -- * Testing+            , height, maxHeight, showStats++            ) where++import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import qualified Data.List as L+import Data.IntervalMap.Generic.Base as M hiding (+      singleton+    , insert+    , insertWith+    , insertWithKey+    , findWithDefault+    , insertLookupWithKey+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , unionWith+    , unionWithKey+    , unionsWith+    , differenceWith+    , differenceWithKey+    , intersectionWith+    , intersectionWithKey+    , map+    , mapWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeysWith+    , fromList+    , fromListWith+    , fromListWithKey+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+  )++-- | /O(1)/. A map with one entry.+singleton :: k -> v -> IntervalMap k v+singleton k v = v `seq` Node B k k v Nil Nil+++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'+findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a+findWithDefault def k m = def `seq` case M.lookup k m of+    Nothing -> def+    Just x  -> x++-- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is+-- changed to the new value.+insert :: (Interval k e, Ord k) => k -> v -> IntervalMap k v -> IntervalMap k v+insert =  insertWithKey (\_ v _ -> v)++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+insertWith :: (Interval k e, Ord k) => (v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v+insertWith f = insertWithKey (\_ new old -> f new old)++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+insertWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v+insertWithKey f key value mp  =  key `seq` turnBlack (ins mp)+  where+    singletonR k v = Node R k k v Nil Nil+    ins Nil = value `seq` singletonR key value+    ins (Node color k m v l r) =+      case compare key k of+        LT -> balanceL color k v (ins l) r+        GT -> balanceR color k v l (ins r)+        EQ -> let v' = f k value v in v' `seq` Node color k m v' l r+++-- | /O(log n)/. Combine insert with old values retrieval.+insertLookupWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v)+insertLookupWithKey f key value mp  =  key `seq` (oldval, turnBlack mp')+  where+    (oldval, mp') = ins mp+    singletonR k v = Node R k k v Nil Nil+    ins Nil = value `seq` (Nothing, singletonR key value)+    ins (Node color k m v l r) =+      case compare key k of+        LT -> case ins l of+                 (x@(Just _), t') -> (x, Node color k m v t' r)+                 (Nothing, t') -> (Nothing, balanceL color k v t' r)+        GT -> case ins r of+                 (x@(Just _), t') -> (x, Node color k m v l t')+                 (Nothing, t') -> (Nothing, balanceR color k v l t')+        EQ -> let v' = f k value v in v' `seq` (Just v, Node color k m v' l r)+++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+adjust :: Ord k => (a -> a) -> k -> IntervalMap k a -> IntervalMap k a+adjust f k m = adjustWithKey (\_ v -> f v) k m++-- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: Ord k => (k -> a -> a) -> k -> IntervalMap k a -> IntervalMap k a+adjustWithKey _ _ Nil = Nil+adjustWithKey f x (Node c k m v l r) =+  case compare x k of+    LT -> Node c k m v (adjustWithKey f x l) r+    GT -> Node c k m v l (adjustWithKey f x r)+    EQ -> let v' = f k v in v' `seq` Node c k m v' l r++-- | /O(log n)/. Update or delete value at minimum key.+updateMin :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMin f m = updateMinWithKey (\_ v -> f v) m++-- | /O(log n)/. Update or delete value at maximum key.+updateMax :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMax f m = updateMaxWithKey (\_ v -> f v) m++-- | /O(log n)/. Update or delete value at minimum key.+updateMinWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMinWithKey _ Nil = Nil+updateMinWithKey f m = let (k,v) = findMin m in+                       case f k v of+                         Just v' -> v' `seq` setMinValue v' m+                         Nothing -> deleteMin m++-- | /O(log n)/. Update or delete value at maximum key.+updateMaxWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMaxWithKey _ Nil = Nil+updateMaxWithKey f m = let (k,v) = findMax m in+                       case f k v of+                         Just v' -> v' `seq` setMaxValue v' m+                         Nothing -> deleteMax m++-- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: (Interval k e, Ord k) => [(k,v)] -> IntervalMap k v+fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs++-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWith :: (Interval k e, Ord k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a+fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs++-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a+fromListWithKey f xs = L.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: (Interval k e, Eq k) => [(k,v)] -> IntervalMap k v+fromAscList xs = fromAscListWith (\_ b -> b) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWith :: (Interval k e, Eq k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWithKey :: (Interval k e, Eq k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a+fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs)++combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)]+combineEq _ [] = []+combineEq _ xs@[_] = xs+combineEq f (x@(xk,xv) : xs@((yk,yv) : xs'))+  | xk == yk  = let v' = f xk xv yv in v' `seq` combineEq f ((xk, v') : xs')+  | otherwise = x : combineEq f xs+++-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntervalMap k a -> IntervalMap k b+map f = mapWithKey (\_ x -> f x)++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (k -> a -> b) -> IntervalMap k a -> IntervalMap k b+mapWithKey f = go+  where+    go Nil = Nil+    go (Node c k m v l r) = let v' = f k v in v' `seq` Node c k m v' (go l) (go r)++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])+mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])+mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumWithKey f = go+  where+    go a Nil               = (a,Nil)+    go a (Node c kx m x l r) =+                 let (a1,l') = go a l+                     (a2,x') = f a1 kx x+                     (a3,r') = go a2 r+                 in x' `seq` (a3, Node c kx m x' l' r')++-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumRWithKey f = go+  where+    go a Nil = (a, Nil)+    go a (Node c kx m x l r) =+                 let (a1,r') = go a r+                     (a2,x') = f a1 kx x+                     (a3,l') = go a2 l+                 in x' `seq` (a3, Node c kx m x' l' r')+++-- | /O(n)/. Map values and collect the 'Just' results.+mapMaybe :: (Interval k e) => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b+mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: (Interval k e) => (k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b+mapMaybeWithKey f m = fromDistinctAscList (mapf [] m)+  where+    mapf z Nil = z+    mapf z (Node _ k _ v l r) = mapf (f' k v z r) l+    f' k v z r = case f k v of+                   Nothing -> mapf z r+                   Just v' -> v' `seq` (k,v') : mapf z r++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+mapEither :: (Interval k e) => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)+mapEither f m = mapEitherWithKey (\_ v -> f v) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: (Interval k e) => (k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)+mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r)+  where+    (l, r) = part [] [] (toDescList m)+    part ls rs [] = (ls, rs)+    part ls rs ((k,v):xs) = case f k v of+                              Left v'  -> v' `seq` part ((k,v'):ls) rs xs+                              Right v' -> v' `seq` part ls ((k,v'):rs) xs+++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Interval k e, Ord k) => (Maybe a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a+alter f x m = case lookup x m of+                Nothing -> case f Nothing of+                             Nothing -> m+                             Just v -> insert x v m+                y       -> case f y of+                             Nothing -> delete x m+                             Just v' -> adjust (const v') x m+++-- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+mapKeysWith :: (Interval k2 e, Ord k2) => (a -> a -> a) -> (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ]++-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: (Interval k e, Ord k) => (a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a+update f k m = updateWithKey (\_ v -> f v) k m++-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+updateWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a+updateWithKey f k m = snd (updateLookupWithKey f k m)++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+updateLookupWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> (Maybe a, IntervalMap k a)+updateLookupWithKey f x m = case lookup x m of+                              Nothing -> (Nothing, m)+                              r@(Just v) -> case f x v of+                                              Nothing -> (r, delete x m)+                                              r'@(Just v') -> (r', adjust (const v') x m)+++-- | /O(n+m)/. Union with a combining function.+unionWith :: (Interval k e, Ord k) => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2++-- | /O(n+m)/. Union with a combining function.+unionWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2))++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: (Interval k e, Ord k) => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a+unionsWith f = L.foldl (unionWith f) empty++-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWith :: (Interval k e, Ord k) => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a+differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWithKey :: (Interval k e, Ord k) => (k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a+differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2))++-- | /O(n+m)/. Intersection with a combining function.+intersectionWith :: (Interval k e, Ord k) => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2++-- | /O(n+m)/. Intersection with a combining function.+intersectionWithKey :: (Interval k e, Ord k) => (k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2))+++ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)]+ascListUnion _ [] [] = []+ascListUnion _ [] ys = ys+ascListUnion _ xs [] = xs+ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') =+  case compare xk yk of+    LT -> x : ascListUnion f xs' ys+    GT -> y : ascListUnion f xs ys'+    EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListUnion f xs' ys'++ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)]+ascListDifference _ [] _  = []+ascListDifference _ xs [] = xs+ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') =+  case compare xk yk of+    LT -> x : ascListDifference f xs' ys+    GT -> ascListDifference f xs ys'+    EQ -> case f xk xv yv of+            Nothing -> ascListDifference f xs' ys'+            Just v' -> v' `seq` (xk,v') : ascListDifference f xs' ys'++ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)]+ascListIntersection _ [] _ = []+ascListIntersection _ _ [] = []+ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') =+  case compare xk yk of+    LT -> ascListIntersection f xs' ys+    GT -> ascListIntersection f xs ys'+    EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListIntersection f xs' ys'

@@ -16,7 +16,7 @@ -} module Data.IntervalMap.Lazy (             -- * re-export-            Interval(..)+            I.Interval(..)             -- * Map type             , IntervalMap      -- instance Eq,Show,Read @@ -152,4 +152,9 @@              ) where -import Data.IntervalMap.Base as M+import Data.IntervalMap.Interval as I+import Data.IntervalMap.Generic.Lazy hiding (IntervalMap, null, filter, lookup, map, foldr, foldl)+import qualified Data.IntervalMap.Generic.Lazy as M+++type IntervalMap k v = M.IntervalMap (I.Interval k) v

@@ -60,7 +60,7 @@ -} module Data.IntervalMap.Strict (             -- * re-export-            Interval(..)+            I.Interval(..)             -- * Map type             , IntervalMap      -- instance Eq,Show,Read @@ -196,378 +196,10 @@              ) where -import Prelude hiding (null, lookup, map, filter, foldr, foldl)-import qualified Data.List as L-import Data.IntervalMap.Base as M hiding (-      singleton-    , insert-    , insertWith-    , insertWithKey-    , findWithDefault-    , insertLookupWithKey-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , unionWith-    , unionWithKey-    , unionsWith-    , differenceWith-    , differenceWithKey-    , intersectionWith-    , intersectionWithKey-    , map-    , mapWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeysWith-    , fromList-    , fromListWith-    , fromListWithKey-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-  ) --- | /O(1)/. A map with one entry.-singleton :: Interval k -> v -> IntervalMap k v-singleton k v = v `seq` Node B k k v Nil Nil----- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'-findWithDefault :: Ord k => a -> Interval k -> IntervalMap k a -> a-findWithDefault def k m = def `seq` case M.lookup k m of-    Nothing -> def-    Just x  -> x---- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is--- changed to the new value.-insert :: (Ord k) => Interval k -> v -> IntervalMap k v -> IntervalMap k v-insert =  insertWithKey (\_ v _ -> v)---- | /O(log n)/. Insert with a function, combining new value and old value.--- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.-insertWith :: (Ord k) => (v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v-insertWith f = insertWithKey (\_ new old -> f new old)---- | /O(log n)/. Insert with a function, combining key, new value and old value.--- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.-insertWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v-insertWithKey f key value mp  =  key `seq` turnBlack (ins mp)-  where-    singletonR k v = Node R k k v Nil Nil-    ins Nil = value `seq` singletonR key value-    ins (Node color k m v l r) =-      case compare key k of-        LT -> balanceL color k v (ins l) r-        GT -> balanceR color k v l (ins r)-        EQ -> let v' = f k value v in v' `seq` Node color k m v' l r----- | /O(log n)/. Combine insert with old values retrieval.-insertLookupWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v)-insertLookupWithKey f key value mp  =  key `seq` (oldval, turnBlack mp')-  where-    (oldval, mp') = ins mp-    singletonR k v = Node R k k v Nil Nil-    ins Nil = value `seq` (Nothing, singletonR key value)-    ins (Node color k m v l r) =-      case compare key k of-        LT -> case ins l of-                 (x@(Just _), t') -> (x, Node color k m v t' r)-                 (Nothing, t') -> (Nothing, balanceL color k v t' r)-        GT -> case ins r of-                 (x@(Just _), t') -> (x, Node color k m v l t')-                 (Nothing, t') -> (Nothing, balanceR color k v l t')-        EQ -> let v' = f k value v in v' `seq` (Just v, Node color k m v' l r)----- | /O(log n)/. Update a value at a specific key with the result of the provided function.--- When the key is not--- a member of the map, the original map is returned.-adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a-adjust f k m = adjustWithKey (\_ v -> f v) k m---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.-adjustWithKey :: Ord k => (Interval k -> a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a-adjustWithKey _ _ Nil = Nil-adjustWithKey f x (Node c k m v l r) =-  case compare x k of-    LT -> Node c k m v (adjustWithKey f x l) r-    GT -> Node c k m v l (adjustWithKey f x r)-    EQ -> let v' = f k v in v' `seq` Node c k m v' l r---- | /O(log n)/. Update or delete value at minimum key.-updateMin :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMin f m = updateMinWithKey (\_ v -> f v) m---- | /O(log n)/. Update or delete value at maximum key.-updateMax :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMax f m = updateMaxWithKey (\_ v -> f v) m---- | /O(log n)/. Update or delete value at minimum key.-updateMinWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMinWithKey _ Nil = Nil-updateMinWithKey f m = let (k,v) = findMin m in-                       case f k v of-                         Just v' -> v' `seq` setMinValue v' m-                         Nothing -> deleteMin m---- | /O(log n)/. Update or delete value at maximum key.-updateMaxWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v-updateMaxWithKey _ Nil = Nil-updateMaxWithKey f m = let (k,v) = findMax m in-                       case f k v of-                         Just v' -> v' `seq` setMaxValue v' m-                         Nothing -> deleteMax m---- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.-fromList :: Ord k => [(Interval k,v)] -> IntervalMap k v-fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs---- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.-fromListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs---- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.-fromListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWithKey f xs = L.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./-fromAscList :: Ord k => [(Interval k,v)] -> IntervalMap k v-fromAscList xs = fromAscListWith (\_ b -> b) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./-fromAscListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./-fromAscListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs)--combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)]-combineEq _ [] = []-combineEq _ xs@[_] = xs-combineEq f (x@(xk,xv) : xs@((yk,yv) : xs'))-  | xk == yk  = let v' = f xk xv yv in v' `seq` combineEq f ((xk, v') : xs')-  | otherwise = x : combineEq f xs----- | /O(n)/. Map a function over all values in the map.-map :: (a -> b) -> IntervalMap k a -> IntervalMap k b-map f = mapWithKey (\_ x -> f x)---- | /O(n)/. Map a function over all values in the map.-mapWithKey :: (Interval k -> a -> b) -> IntervalMap k a -> IntervalMap k b-mapWithKey f = go-  where-    go Nil = Nil-    go (Node c k m v l r) = let v' = f k v in v' `seq` Node c k m v' (go l) (go r)---- | /O(n)/. The function 'mapAccum' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])-mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)-mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m---- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])-mapAccumWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)-mapAccumWithKey f = go-  where-    go a Nil               = (a,Nil)-    go a (Node c kx m x l r) =-                 let (a1,l') = go a l-                     (a2,x') = f a1 kx x-                     (a3,r') = go a2 r-                 in x' `seq` (a3, Node c kx m x' l' r')---- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)-mapAccumRWithKey f = go-  where-    go a Nil = (a, Nil)-    go a (Node c kx m x l r) =-                 let (a1,r') = go a r-                     (a2,x') = f a1 kx x-                     (a3,l') = go a2 l-                 in x' `seq` (a3, Node c kx m x' l' r')----- | /O(n)/. Map values and collect the 'Just' results.-mapMaybe :: Ord k => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b-mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m---- | /O(n)/. Map keys\/values and collect the 'Just' results.-mapMaybeWithKey :: Ord k => (Interval k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b-mapMaybeWithKey f m = fromDistinctAscList (mapf [] m)-  where-    mapf z Nil = z-    mapf z (Node _ k _ v l r) = mapf (f' k v z r) l-    f' k v z r = case f k v of-                   Nothing -> mapf z r-                   Just v' -> v' `seq` (k,v') : mapf z r---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.-mapEither :: Ord k => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)-mapEither f m = mapEitherWithKey (\_ v -> f v) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.-mapEitherWithKey :: Ord k => (Interval k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)-mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r)-  where-    (l, r) = part [] [] (toDescList m)-    part ls rs [] = (ls, rs)-    part ls rs ((k,v):xs) = case f k v of-                              Left v'  -> v' `seq` part ((k,v'):ls) rs xs-                              Right v' -> v' `seq` part ls ((k,v'):rs) xs----- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.-alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a-alter f x m = case lookup x m of-                Nothing -> case f Nothing of-                             Nothing -> m-                             Just v -> insert x v m-                y       -> case f y of-                             Nothing -> delete x m-                             Just v' -> adjust (const v') x m----- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.-mapKeysWith :: Ord k2 => (a -> a -> a) -> (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a-mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ]---- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.-update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a-update f k m = updateWithKey (\_ v -> f v) k m---- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.-updateWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a-updateWithKey f k m = snd (updateLookupWithKey f k m)---- | /O(log n)/. Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted.-updateLookupWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> (Maybe a, IntervalMap k a)-updateLookupWithKey f x m = case lookup x m of-                              Nothing -> (Nothing, m)-                              r@(Just v) -> case f x v of-                                              Nothing -> (r, delete x m)-                                              r'@(Just v') -> (r', adjust (const v') x m)----- | /O(n+m)/. Union with a combining function.-unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a-unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2---- | /O(n+m)/. Union with a combining function.-unionWithKey :: Ord k => (Interval k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a-unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2))---- | The union of a list of maps, with a combining operation:---   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).-unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a-unionsWith f = L.foldl (unionWith f) empty---- | /O(n+m)/. Difference with a combining function. --- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWith :: Ord k => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a-differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWithKey :: Ord k => (Interval k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a-differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2))---- | /O(n+m)/. Intersection with a combining function.-intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c-intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2---- | /O(n+m)/. Intersection with a combining function.-intersectionWithKey :: Ord k => (Interval k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c-intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2))+import Data.IntervalMap.Interval as I+import Data.IntervalMap.Generic.Strict hiding (IntervalMap, null, filter, lookup, map, foldr, foldl)+import qualified Data.IntervalMap.Generic.Strict as M  -ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)]-ascListUnion _ [] [] = []-ascListUnion _ [] ys = ys-ascListUnion _ xs [] = xs-ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') =-  case compare xk yk of-    LT -> x : ascListUnion f xs' ys-    GT -> y : ascListUnion f xs ys'-    EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListUnion f xs' ys'--ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)]-ascListDifference _ [] _  = []-ascListDifference _ xs [] = xs-ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') =-  case compare xk yk of-    LT -> x : ascListDifference f xs' ys-    GT -> ascListDifference f xs ys'-    EQ -> case f xk xv yv of-            Nothing -> ascListDifference f xs' ys'-            Just v' -> v' `seq` (xk,v') : ascListDifference f xs' ys'--ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)]-ascListIntersection _ [] _ = []-ascListIntersection _ _ [] = []-ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') =-  case compare xk yk of-    LT -> ascListIntersection f xs' ys-    GT -> ascListIntersection f xs ys'-    EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListIntersection f xs' ys'+type IntervalMap k v = M.IntervalMap (I.Interval k) v

@@ -1,5 +1,5 @@ Name:                IntervalMap-Version:             0.3.0.3+Version:             0.4.0.0 Stability:           experimental Synopsis:            Maps from Intervals to values, with efficient search. Homepage:            http://www.chr-breitkopf.de/comp/IntervalMap@@ -12,7 +12,7 @@ Category:            Data Build-type:          Simple Cabal-version:       >= 1.8-Tested-With:         GHC==7.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.0.4, GHC==6.12.1+Tested-With:         GHC==7.8.3 Description:                      A map from intervals to values, with efficient search                      for all keys containing a point or overlapping an interval.@@ -25,8 +25,11 @@  Library   Exposed-modules:     Data.IntervalMap, Data.IntervalMap.Lazy,-                       Data.IntervalMap.Strict, Data.IntervalMap.Interval-  other-modules:       Data.IntervalMap.Base+                       Data.IntervalMap.Strict, Data.IntervalMap.Interval,+                       Data.IntervalMap.Generic.Interval,+                       Data.IntervalMap.Generic.Lazy,+                       Data.IntervalMap.Generic.Strict+  other-modules:       Data.IntervalMap.Generic.Base   Build-depends:       base >= 4 && < 5, containers, deepseq   ghc-options: -Wall   if impl(ghc >= 6.8)@@ -39,6 +42,14 @@   build-depends:      base >= 4 && < 5, containers, deepseq,                       QuickCheck, Cabal >= 1.9.2 ++Test-Suite TestGenericInterval+  type:               exitcode-stdio-1.0+  main-is:            GenericIntervalTests.hs+  hs-source-dirs:     . test+  build-depends:      base >= 4 && < 5, containers, deepseq,+                      QuickCheck, Cabal >= 1.9.2+ Test-Suite TestIntervalMap   type:               exitcode-stdio-1.0   main-is:            IntervalMapTests.hs@@ -50,6 +61,15 @@   type:               exitcode-stdio-1.0   hs-source-dirs:     . bench   main-is:            BenchAll.hs+  Build-depends:      base >= 4 && < 5,+                      containers, random, deepseq,+                      criterion >= 1.0+  ghc-options: -Wall++benchmark bench-generic-lazy-strict+  type:               exitcode-stdio-1.0+  hs-source-dirs:     . bench+  main-is:            GenericLazyVsStrict.hs   Build-depends:      base >= 4 && < 5,                       containers, random, deepseq,                       criterion >= 1.0

@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ import Criterion.Main import Criterion.Types (Config(..)) @@ -10,6 +13,7 @@ import Data.IntervalMap.Interval import qualified Data.Map as D import qualified Data.IntervalMap as M+import qualified Data.IntervalMap.Generic.Lazy as G   seed :: Int@@ -45,35 +49,49 @@ cDATA_SIZE :: Int cDATA_SIZE =  10000 +instance Ord a => G.Interval (a,a) a where+  lowerBound (a,_) = a+  upperBound (_,a) = a + main :: IO () main =   do       let ivs  = genRandomIntervals cDATA_SIZE 20 cDATA_SIZE       let ivs2 = genRandomIntervals cDATA_SIZE 20 (cDATA_SIZE `quot` 2)       ivsP   <- ensure $ [(ClosedInterval lo hi, lo) | (lo,hi) <- ivs]+      ivsG   <- ensure $ [(iv,lo) | iv@(lo,_) <- ivs]       oIvsP  <- ensure $ sort ivsP+      oIvsG  <- ensure $ sort ivsG       lookupKeys <- ensure $ [i | (i,_) <- ivsP]+      lookupKeysG <- ensure $ [i | (i,_) <- ivsG]       dMap   <- ensure $ D.fromList ivsP       dIvMap <- ensure $ M.fromList ivsP+      gIvMap <- ensure $ G.fromList ivsG       dMapSmall <- ensure $ D.fromList [(ClosedInterval lo hi, lo) | (lo,hi) <- ivs2]       dIvMapSmall <- ensure $ M.fromList [(ClosedInterval lo hi, lo) | (lo,hi) <- ivs2]       rndInts <- ensure (genRandomInts 1 cDATA_SIZE cDATA_SIZE)       defaultMainWith benchConfig [          bgroup "fromList (insert)" [            bench "Data.Map"        $ nf D.fromList ivsP,-           bench "IntervalMap"     $ nf M.fromList ivsP+           bench "IntervalMap"     $ nf M.fromList ivsP,+           bench "IMGeneric"       $ nf G.fromList ivsG          ],          bgroup "fromAscList" [            bench "Data.Map"        $ nf D.fromAscList oIvsP,-           bench "IntervalMap"     $ nf M.fromAscList oIvsP+           bench "IntervalMap"     $ nf M.fromAscList oIvsP,+           bench "IMGeneric"       $ nf G.fromAscList oIvsG          ],          bgroup "search" [            bench "lookup Data.Map" $ nf (\m -> [D.lookup i m | i <- lookupKeys]) dMap,            bench "lookup"          $ nf (\m -> [M.lookup i m | i <- lookupKeys]) dIvMap,            bench "containing"      $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.containing` p]) dIvMap,            bench "intersecting"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.intersecting` (ClosedInterval p (p+15))]) dIvMap,-           bench "within" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.within` (ClosedInterval p (p+15))]) dIvMap+           bench "within" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.within` (ClosedInterval p (p+15))]) dIvMap,+           bench "G lookup"          $ nf (\m -> [G.lookup i m | i <- lookupKeysG]) gIvMap,+           bench "G containing"      $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `G.containing` p]) gIvMap,+           bench "G intersecting"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `G.intersecting` (p, p+15)]) gIvMap,+           bench "G within" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `G.within` (p, p+15)]) gIvMap          ],          bgroup "mapKeys" [            bench "Data.Map"              $ nf (D.mapKeys (move 1)) dMap,@@ -94,6 +112,8 @@            bench "Data.Map Empty/Large"    $ nf (\m -> D.union D.empty m) dMap,            bench "IntervalMap Large/Empty" $ nf (\m -> M.union m M.empty) dIvMap,            bench "IntervalMap Empty/Large" $ nf (\m -> M.union M.empty m) dIvMap,+           bench "IMGeneric Large/Empty" $ nf (\m -> G.union m G.empty) gIvMap,+           bench "IMGeneric Empty/Large" $ nf (\m -> G.union G.empty m) gIvMap,            bench "Data.Map self"    $ nf (\m -> D.union m m) dMap,            bench "IntervalMap self" $ nf (\m -> M.union m m) dIvMap          ],

@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Criterion.Main+import Criterion.Types (Config(..))++import Control.DeepSeq+import Prelude hiding (lookup, max, foldr)+import System.Random+import Data.Foldable (foldr)+import Data.List (sort)++import Data.IntervalMap.Generic.Interval+import qualified Data.IntervalMap.Generic.Lazy as L+import qualified Data.IntervalMap.Generic.Lazy as S+++seed :: Int+seed = 54321++ensure :: NFData a => a -> IO a+ensure xs = xs `deepseq` return xs++forceRange :: Int -> Int -> Int -> Int+forceRange lo hi n | n >= lo && n <= hi = n+                   | n < 0              = forceRange lo hi (0 - n)+                   | otherwise          = lo + (n `rem` (1 + hi - lo))++genRandomInts :: Int -> Int -> Int -> [Int]+genRandomInts lo hi n = Prelude.map (forceRange lo hi) . take n . randoms . mkStdGen $ seed++genRandomIntervals :: Int -> Int -> Int -> [(Int,Int)]+genRandomIntervals max lap n = genIvs . take (2*n) . randoms . mkStdGen $ seed+  where+    genIvs [] = []+    genIvs [_] = []+    genIvs (x:y:xs) = let lo = forceRange 1 max x+                          sz = forceRange 0 lap y+                      in (lo, lo + sz) : genIvs xs+++benchConfig :: Config+benchConfig =  defaultConfig { reportFile = Just "bench-lazy-strict.html" }++cDATA_SIZE :: Int+cDATA_SIZE =  10000++data IV = IV {-# UNPACK #-} !Int {-# UNPACK #-} !Int+          deriving (Eq, Ord)++instance NFData IV where+  rnf a = a `seq` ()++instance Interval IV Int where+  lowerBound (IV l _) = l+  upperBound (IV _ u) = u++move :: Int -> IV -> IV+move n (IV a b) = IV (a+n) (b+n)+++main :: IO ()+main =+  do+      let ivs  = genRandomIntervals cDATA_SIZE 20 cDATA_SIZE+      ivsP   <- ensure $ [(IV lo hi, lo) | (lo,hi) <- ivs]+      oIvsP  <- ensure $ sort ivsP+      lookupKeys <- ensure $ [i | (i,_) <- ivsP]+      sMap <- ensure $ S.fromList ivsP+      lMap <- ensure $ L.fromList ivsP+      rndInts <- ensure (genRandomInts 1 cDATA_SIZE cDATA_SIZE)+      defaultMainWith benchConfig [+         bgroup "fromList (insert)" [+           bench "Lazy"     $ nf L.fromList ivsP,+           bench "Strict"   $ nf S.fromList ivsP+         ],+         bgroup "fromAscList" [+           bench "Lazy"     $ nf L.fromAscList oIvsP,+           bench "Strict"   $ nf S.fromAscList oIvsP+         ],+         bgroup "search" [+           bench "lookup lazy"          $ nf (\m -> [L.lookup i m | i <- lookupKeys]) lMap,+           bench "lookup strict"        $ nf (\m -> [S.lookup i m | i <- lookupKeys]) sMap,+           bench "containing lazy"      $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.containing` p]) lMap,+           bench "containing strict"      $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.containing` p]) sMap,+           bench "intersecting lazy"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.intersecting` (IV p (p+15))]) lMap,+           bench "intersecting strict"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.intersecting` (IV p (p+15))]) sMap,+           bench "within lazy" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.within` (IV p (p+15))]) lMap,+           bench "within strict" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.within` (IV p (p+15))]) sMap+         ],+         bgroup "mapKeys" [+           bench "lazy"             $ nf (L.mapKeys (move 1)) lMap,+           bench "strict"           $ nf (S.mapKeys (move 1)) sMap,+           bench "monotonic lazy"   $ nf (L.mapKeysMonotonic (move 1)) lMap,+           bench "monotonic strict" $ nf (S.mapKeysMonotonic (move 1)) sMap+         ],+         bgroup "map" [+           bench "lazy"    $ nf (L.map (1+)) lMap,+           bench "strict"  $ nf (S.map (1+)) sMap+         ],+         bgroup "union" [+           bench "Large/Empty lazy"   $ nf (\m -> L.union m L.empty) lMap,+           bench "Large/Empty strict" $ nf (\m -> S.union m S.empty) sMap,+           bench "Empty/Large lazy"   $ nf (\m -> L.union L.empty m) lMap,+           bench "Empty/Large strict" $ nf (\m -> S.union S.empty m) sMap,+           bench "self lazy"          $ nf (\m -> L.union m m) lMap,+           bench "self strict"        $ nf (\m -> S.union m m) sMap+         ]+       ]

@@ -1,4 +1,4 @@-<h1>IntervalMap usage example</h2>+<h1>IntervalMap usage example</h1>  In this example I use an IntervalMap to store a set of appointments. The appointments are for several people, so they can overlap.

@@ -0,0 +1,98 @@+<h1>IntervalMap.generic usage example</h1>++In this example I use an IntervalMap to store a set of appointments.+The appointments are for several people, so they can overlap.++This is a literate Haskell file, you can [download it](Example.lhs) and compile it with+ghc or run in in ghci. You must first install IntervalMap, if you have not already done so:+`cabal install IntervalMap`.++First, I have to enable some language extensions to be able to+make my own interval type an instance of Interval:++> {-# LANGUAGE MultiParamTypeClasses #-}+> {-# LANGUAGE FlexibleInstances #-}++In most cases, you should use the value-strict version, so I import that:++> import Data.IntervalMap.Generic.Strict++For readability, here are simple type synonyms for our data types. In production+code, one would of course use newtype or data for this.++> type Person = String+> type Details = String++Again for readability, I use strings to represent timestamps. Also, to keep it shorter,+I will omit the date and only use the time of the day in this example, e.g.: "09:00", "12:47".++> type Time = String+> type TimeSpan = (Time,Time)++I have a time span include its start time but not its end time.+So I declare an Interval instance for tuples that is closed at the startpoint+but open at the endpoint:++> instance Ord e => Interval (e,e) e where+>   lowerBound (a,_) = a+>   upperBound (_,b) = b+>   rightClosed _ = False++Constructing timespans is just using tuples:++> mkTimeSpan :: Time -> Time -> TimeSpan+> mkTimeSpan from to = (from,to)++An appointment consists of the timespan, the person, and the appointment details:++> type Appointment = (TimeSpan, Person, Details)++For a set of possible overlapping appointments, I store a list of (person, details)+tuples for each timespan:++> type Appointments = IntervalMap TimeSpan [(Person, Details)]++Not that the key type is *Time*, not *TimeSpan*. That is, you specify the type of the+endpoints, not the type of the interval itself.++Now I can define some helper functions.++A set containing no appointments:++> noAppointments :: Appointments+> noAppointments =  empty++To add an appointment to a set, I use (++) as a combining function to add+the new appointment:++> addAppointment :: Person -> Time -> Time -> Details -> Appointments -> Appointments+> addAppointment who from to what = insertWith (++) (mkTimeSpan from to) [(who, what)]++To look up all appointments at a given time, just get all entries _containing_+that time:++> appointmentsAt :: Time -> Appointments -> [Appointment]+> appointmentsAt t apps = [ (time, person, details)+>                           | (time, pds) <- apps `containing` t,+>                             (person, details) <- pds ]++The function to get all appointments that overlap a given timespan is almost+the same, just using _intersecting_ instead:++> appointmentsDuring :: Time -> Time -> Appointments -> [Appointment]+> appointmentsDuring from to apps = [ (time, person, details)+>                                     | (time, pds) <- apps `intersecting` mkTimeSpan from to,+>                                       (person, details) <- pds ]++Here is a sample set of appointments and a main function to show some test results:++> sampleApps :: Appointments+> sampleApps = addAppointment "Paul" "09:00" "11:00" "Dentist" $+>              addAppointment "John" "10:00" "11:30" "Meeting" $+>              addAppointment "Rosy" "10:00" "11:30" "Shopping" $+>              addAppointment "Lisa" "08:45" "09:15" "Bank" $+>              noAppointments+>+> main :: IO ()+> main = do putStrLn (show (appointmentsAt "09:00" sampleApps))+>           putStrLn (show (appointmentsDuring "09:30" "10:30" sampleApps))

@@ -0,0 +1,177 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- module IntervalTests (main) where++import System.Exit (exitSuccess, exitFailure)++import Test.QuickCheck+import Test.QuickCheck.Test (isSuccess)+import Control.Monad (liftM)++import Data.IntervalMap.Generic.Interval++data IV a = IV !Bool !a !a !Bool deriving (Eq, Show)++-- Note that we can not derive Ord for intervals with "mixed" closedness.+-- If, in contrast, all values have identical closedness, deriving should work.+instance Ord a => Ord (IV a) where+  compare = genericCompare++instance Ord a => Interval (IV a) a where+  lowerBound (IV _ x _ _) = x+  upperBound (IV _ _ x _) = x+  leftClosed (IV c _ _ _) = c+  rightClosed (IV _ _ _ c) = c++closedInterval, openInterval, intervalCO, intervalOC :: a -> a -> IV a+closedInterval a b = IV True a b True+openInterval a b = IV False a b False+intervalCO a b = IV True a b False+intervalOC a b = IV False a b True+++c15, o15, co15, oc15 :: IV Int+c15 = closedInterval 1 5+o15 = openInterval 1 5+co15 = intervalCO 1 5+oc15 = intervalOC 1 5+++prop_boundsC, prop_boundsO, prop_boundsCO, prop_boundsOC :: Int -> Int -> Bool+prop_boundsC lo hi = let iv = closedInterval lo hi in lowerBound iv == lo && upperBound iv == hi+prop_boundsO lo hi = let iv = openInterval lo hi in lowerBound iv == lo && upperBound iv == hi+prop_boundsCO lo hi = let iv = intervalCO lo hi in lowerBound iv == lo && upperBound iv == hi+prop_boundsOC lo hi = let iv = intervalOC lo hi in lowerBound iv == lo && upperBound iv == hi++prop_empty = +  isEmpty (openInterval 1 1) &&+  isEmpty (intervalCO 1 1) &&+  isEmpty (intervalOC 1 1) &&+  not (isEmpty (closedInterval 1 1))++prop_ord =+  closedInterval 1 2 < openInterval 1 2 &&+  closedInterval 2 3 > openInterval 1 2+  ++contains :: Interval i e => i -> e -> Bool+contains = flip inside++prop_contains1 =+  (c15 `contains` 3) &&+  (o15 `contains` 3) &&+  (co15 `contains` 3) &&+  (oc15 `contains` 3) &&+  (c15 `contains` 1) &&+  (c15 `contains` 5) &&+  not (o15 `contains` 1) &&+  not (o15 `contains` 5) &&+  (co15 `contains` 1) &&+  not (co15 `contains` 5) &&+  not (oc15 `contains` 1) &&+  (oc15 `contains` 5)+++prop_overlaps = +  (c15 `overlaps` closedInterval 5 6) &&+  not (c15 `overlaps` openInterval 5 6) &&+  (c15 `overlaps` intervalCO 5 6) &&+  not (c15 `overlaps` intervalOC 5 6) &&+  (c15 `overlaps` closedInterval 0 1) &&+  not (c15 `overlaps` openInterval 0 1) &&+  (c15 `overlaps` intervalOC 0 1) &&+  not (c15 `overlaps` intervalCO 0 1)++prop_subsumes1 =  (c15 `subsumes` o15) && -- closed subsumes open+		  not (o15 `subsumes` c15) && -- ~? "open does not subsume closed",+		  not (co15 `subsumes` c15) && -- "open does not subsume closed",+		  not (oc15 `subsumes` c15) -- "open does not subsume closed"++ivGen :: Int -> Int -> Gen II+ivGen lo hi = do start <- choose (lo, hi)+		 size  <- choose (0, hi - start)+		 if size == 0+		  then return (II (closedInterval start start))+		  else oneof [+		    return (II (closedInterval start (start + size))),+		    return (II (openInterval start (start + size))),+		    return (II (intervalCO start (start + size))),+		    return (II (intervalOC start (start + size))) ]++newtype II = II (IV Int) deriving (Show)++instance Arbitrary II where+  arbitrary = do x <- arbitrary+		 liftM II (interval (abs x))++interval x = do+	     y <- sized (\n -> choose (x, x + abs n))+	     if x == y then return (closedInterval x y)+		else oneof [return (closedInterval x y),+			    return (openInterval x y),+			    return (intervalCO x y),+			    return (intervalOC x y)]++-- our generator will never generate empty intervals+prop_not_empty (II iv) = not (isEmpty iv)++prop_leftClosed = leftClosed (closedInterval 1 2) &&+                  leftClosed (intervalCO 1 2) &&+                  not (leftClosed (openInterval 1 2)) &&+		  not (leftClosed (intervalOC 1 2))++prop_rightClosed = rightClosed (closedInterval 1 2) &&+                   rightClosed (intervalOC 1 2) &&+                   not (rightClosed (openInterval 1 2)) &&+                   not (rightClosed (intervalCO 1 2))+++prop_overlaps_symmetric (II i1) (II i2) = (i1 `overlaps` i2) == (i2 `overlaps` i1)++prop_compare1 (II i1) (II i2) =+  case compare (lowerBound i1) (lowerBound i2) of+    LT -> compare i1 i2 == LT+    GT -> compare i1 i2 == GT+    EQ -> True++prop_contains (II i) p =+  if p `inside` i then+    lowerBound i <= p && upperBound i >= p+  else+    p <= lowerBound i || p >= upperBound i++prop_subsumes (II i1) = forAll subIv (\(II i2) -> (i1 `subsumes` i2) ==>+						    ((i1 == i2) || not (i2 `subsumes` i1)))+  where+    subIv = ivGen (lowerBound i1) (upperBound i1)+	       +prop_equals (II a) (II b) =+  (lowerBound a /= lowerBound b || upperBound a /= upperBound b) ==> (a /= b)++check p name = do r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p+		  if isSuccess r+		   then return r+		   else do putStrLn ("error: " ++ name ++ ": " ++ show r)+			   exitFailure+++main = do+         check prop_boundsO "boundsO"+	 check prop_boundsC "boundsC"+	 check prop_boundsOC "boundsOC"+	 check prop_boundsCO "boundsCO"+	 check prop_empty "empty"+	 check prop_leftClosed "leftClosed"+	 check prop_rightClosed "rightClosed"+         check prop_ord "ord"+	 check prop_compare1 "compare1"+	 check prop_contains1 "contains1"+	 check prop_overlaps "overlaps"+	 check prop_subsumes1 "subsumes1"+	 check prop_not_empty "not empty"+	 check prop_overlaps_symmetric "overlaps symmetric"+	 check prop_contains "contains"+	 check prop_subsumes "subsumes"+	 check prop_equals "equals"+	 exitSuccess