IntervalMap 0.4.0.1 → 0.4.1.0

raw patch · 14 files changed

+1536/−180 lines, 14 filesdep +SegmentTreedep +fingertreePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: SegmentTree, fingertree

API changes (from Hackage documentation)

Files

• Data/IntervalMap/Generic/Base.hs +27/−25
• Data/IntervalMap/Generic/Interval.hs +15/−4
• Data/IntervalMap/Generic/Lazy.hs +1/−1
• Data/IntervalSet.hs +769/−0
• IntervalMap.cabal +55/−8
• LICENSE +1/−1
• README.md +3/−9
• bench/CompareRBImpl.hs +98/−0
• bench/CompareTypes.hs +196/−0
• bench/GenericLazyVsStrict.hs +1/−1
• changelog +18/−0
• examples/GenericExample.lhs +0/−3
• test/IntervalMapTests.hs +140/−128
• test/IntervalSetTests.hs +212/−0

@@ -198,7 +198,7 @@ import qualified Data.Foldable as Foldable import qualified Data.List as L import qualified Data.Set as Set-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq  import Data.IntervalMap.Generic.Interval @@ -208,6 +208,9 @@ infixl 9 !,\\ --  -- | /O(log n)/. Lookup value for given key. Calls 'error' if the key is not in the map.+--+-- Use 'lookup' or 'findWithDefault' instead of this function, unless you are absolutely+-- sure that the key is present in the map. (!) :: (Interval k e, Ord k) => IntervalMap k v -> k -> v tree ! key = case lookup key tree of                Just v  -> v@@ -258,7 +261,7 @@  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+    rnf (Node _ kx _ x l r) = kx `deepseq` x `deepseq` l `deepseq` r `deepseq` ()  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@@ -366,10 +369,6 @@ -- | /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@@ -500,19 +499,17 @@ 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.+-- | Returns the key with the largest endpoint and its associated value.+-- If there is more than one key 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+findLast t@(Node _ _ mx _ _ _) = head (go t)   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)+    go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ [(k,v)]                                                       else go r ++ go l                           | otherwise  = []     sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b@@ -824,12 +821,20 @@ -- | 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+unions ms = unionsWith const ms  -- | 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+unionsWith _ []  = empty+unionsWith _ [m] = m+unionsWith f ms = fromDistinctAscList (head (go (L.map toAscList ms)))+  where+    f' _ l r = f l r+    merge m1 m2 = ascListUnion f' m1 m2+    go [] = []+    go xs@[_] = xs+    go (x:y:xs) = go (merge x y : go xs)  -- | /O(n+m)/. Difference of two maps.  -- Return elements of the first map not existing in the second map.@@ -1029,17 +1034,11 @@  -- | /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@@ -1079,7 +1078,7 @@ 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@+-- | /O(n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ -- is strictly monotonic. -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. -- /The precondition is not checked./@@ -1149,10 +1148,13 @@ -- | /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]+splitLookup x m = case span (\(k,_) -> k < x) (toAscList m) of+                    ([], [])                        -> (empty, Nothing, empty)+                    ([], ((k,v):_))     | k == x    -> (empty, Just v, deleteMin m)+                                        | otherwise -> (empty, Nothing, m)+                    (_, [])                         -> (m, Nothing, empty)+                    (lt, ge@((k,v):gt)) | k == x    -> (fromDistinctAscList lt, Just v, fromDistinctAscList gt)+                                        | otherwise -> (fromDistinctAscList lt, Nothing, fromDistinctAscList ge)  -- submaps 

@@ -11,6 +11,13 @@ -- As there is no sensible default, no instances for prelude types -- are provided (E.g. you might want to have tuples as closed -- intervals in one case, and open in another).+--+-- Empty intervals, i.e. intervals where 'lowerBound >= upperBound' should be avoided+-- if possible. If you must use empty intervals, you need to provide implementations+-- for all operations, as the default implementations do not necessarily work correctly.+-- for example, the default implementation of 'inside' returns 'True' if the point+-- is equal to the lowerBound of a left-closed interval even if it is larger than+-- the upper bound.  {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-}@@ -70,13 +77,17 @@    -- | Is a point strictly less than lower bound?   below :: e -> i -> Bool-  p `below` i | leftClosed i  = p <  lowerBound i-              | otherwise     = p <= lowerBound i+  p `below` i = case compare p (lowerBound i) of+                  LT -> True+                  EQ -> not (leftClosed i)+                  GT -> False    -- | Is a point strictly greater than upper bound?   above :: e -> i -> Bool-  p `above` i | rightClosed i = p >  upperBound i-              | otherwise     = p >= upperBound i+  p `above` i = case compare p (upperBound i) of+                  LT -> False+                  EQ -> not (rightClosed i)+                  GT -> True    -- | Does the interval contain a given point?   inside :: e -> i -> Bool

@@ -1,5 +1,5 @@ {- |-Module      :  Data.IntervalMap.Lazy+Module      :  Data.IntervalMap.Generic.Lazy Copyright   :  (c) Christoph Breitkopf 2014 License     :  BSD-style Maintainer  :  chbreitkopf@gmail.com

@@ -0,0 +1,769 @@+-- |+-- Module      :  Data.IntervalSet+-- Copyright   :  (c) Christoph Breitkopf 2015+-- License     :  BSD-style+-- Maintainer  :  chbreitkopf@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (MPTC with FD)+--+-- An implementation of sets of intervals. The intervals may+-- overlap, and the implementation contains efficient search functions+-- for all intervals containing a point or overlapping a given interval.+-- Closed, open, and half-open intervals can be contained in the same set.+--+-- It is an error to insert an empty interval into a set. 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.IntervalSet.Strict (IntervalSet)+-- >  import qualified Data.IntervalSet.Strict as IS+--+-- It offers most of the same functions as 'Data.Set', but the member type must be an+-- instance of 'Interval'. The 'findMin' and 'findMax' functions deviate from their+-- set counterparts in being total and returning a 'Maybe' value.+-- Some functions differ in asymptotic performance (for example 'size') or have not+-- been tuned for efficiency as much as their equivalents in 'Data.Set'.+--+-- In addition, there are functions specific to sets of intervals, for example to search+-- for all intervals 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.IntervalSet (+            -- * re-export+            Interval(..)+            -- * Set type+            , IntervalSet(..)      -- instance Eq,Show,Read++            -- * Operators+            , (\\)++            -- * Query+            , null+            , size+            , member+            , notMember++            -- ** Interval query+            , containing+            , intersecting+            , within+            +            -- * Construction+            , empty+            , singleton++            -- ** Insertion+            , insert+            +            -- ** Delete\/Update+            , delete++            -- * Combine+            , union+            , unions+            , difference+            , intersection++            -- * Traversal+            -- ** Map+            , map+            , mapMonotonic++            -- ** Fold+            , foldr, foldl+            , foldl', foldr'++            -- * Conversion+            , elems++            -- ** Lists+            , toList+            , fromList++            -- ** Ordered lists+            , toAscList+            , toDescList+            , fromAscList+            , fromDistinctAscList++            -- * Filter+            , filter+            , partition++            , split+            , splitMember++            -- * Subset+            , isSubsetOf, isProperSubsetOf++            -- * Min\/Max+            , findMin+            , findMax+            , findLast+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , minView+            , maxView++            -- * Debugging+            , valid++            ) where++import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import Data.Bits (shiftR, (.&.))+import Data.Monoid (Monoid(..))+import qualified Data.Foldable as Foldable+import qualified Data.List as L+import Control.DeepSeq+import qualified Data.Foldable as Foldable++import Data.IntervalMap.Generic.Interval++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | Same as 'difference'.+(\\) :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k+m1 \\ m2 = difference m1 m2+++data Color = R | B deriving (Eq)++-- | A set of intervals of type @k@.+data IntervalSet k = Nil+                   | Node !Color+                          !k -- key+                          !k -- interval with maximum upper in tree+                          !(IntervalSet k) -- left subtree+                          !(IntervalSet k) -- right subtree++instance (Eq k) => Eq (IntervalSet k) where+  a == b = toAscList a == toAscList b++instance (Ord k) => Ord (IntervalSet k) where+  compare a b = compare (toAscList a) (toAscList b)++instance (Interval i k, Ord i) => Monoid (IntervalSet i) where+    mempty  = empty+    mappend = union+    mconcat = unions+              +instance Foldable.Foldable IntervalSet where+    fold t = go t+      where go Nil = mempty+            go (Node _ k _ l r) = go l `mappend` (k `mappend` go r)+    foldr = foldr+    foldl = foldl+    foldMap f t = go t+      where go Nil = mempty+            go (Node _ k _ l r) = go l `mappend` (f k `mappend` go r)++instance (NFData k) => NFData (IntervalSet k) where+    rnf Nil = ()+    rnf (Node _ kx _ l r) = kx `deepseq` l `deepseq` r `deepseq` ()++instance (Ord k, Read k, Interval i k, Ord i, Read i) => Read (IntervalSet i) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)++instance (Show k) => Show (IntervalSet k) where+  showsPrec d m  = showParen (d > 10) $+    showString "fromList " . shows (toList m)+++isRed :: IntervalSet k -> Bool+isRed (Node R _ _ _ _) = True+isRed _ = False++turnBlack :: IntervalSet k -> IntervalSet k+turnBlack (Node R k m l r) = Node B k m l r+turnBlack t = t++turnRed :: IntervalSet k -> IntervalSet k+turnRed Nil = error "turnRed: Leaf"+turnRed (Node B k m l r) = Node R k m l r+turnRed t = t++-- construct node, recomputing the upper key bound.+mNode :: (Interval k e) => Color -> k -> IntervalSet k -> IntervalSet k -> IntervalSet k+mNode c k l r = Node c k (maxUpper k l r) l r++maxUpper :: (Interval i k) => i -> IntervalSet i -> IntervalSet i -> 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 set.+empty :: IntervalSet k+empty =  Nil++-- | /O(1)/. A set with one entry.+singleton :: k -> IntervalSet k+singleton k = Node B k k Nil Nil+++-- | /O(1)/. Is the set empty?+null :: IntervalSet k -> Bool+null Nil = True+null _   = False++-- | /O(n)/. Number of keys in the set.+--+-- Caution: unlike 'Data.Set.size', this takes linear time!+size :: IntervalSet k -> Int+size t = h 0 t+  where+    h n s = n `seq` case s of+                      Nil -> n+                      Node _ _ _ l r -> h (h n l + 1) r++-- | /O(log n)/. Does the set contain the given value? See also 'notMember'.+member :: (Ord k) => k -> IntervalSet k -> Bool+member k Nil = k `seq` False+member k (Node _ key _ l r) = case compare k key of+                                LT -> member k l+                                GT -> member k r+                                EQ -> True++-- | /O(log n)/. Does the set not contain the given value? See also 'member'.+notMember :: (Ord k) => k -> IntervalSet k -> Bool+notMember key tree = not (member key tree)++-- | Return the set of all intervals containing the given point.+--+-- /O(n)/, since potentially all intervals could contain the point.+-- /O(log n)/ average case. This is also the worst case for sets containing no overlapping intervals.+containing :: (Interval k e) => IntervalSet k -> e -> IntervalSet k+t `containing` pt = fromDistinctAscList (go [] pt t)+  where+    go xs p Nil = p `seq` xs+    go xs p (Node _ k m 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 : go xs p r) p l+       | otherwise    =  go (go xs p r) p l++-- | Return the set of all intervals overlapping (intersecting) the given interval.+--+-- /O(n)/, since potentially all values could intersect the interval.+-- /O(log n)/ average case, if few values intersect the interval.+intersecting :: (Interval k e) => IntervalSet k -> k -> IntervalSet k+t `intersecting` iv = fromDistinctAscList (go [] iv t)+  where+    go xs i Nil = i `seq` xs+    go xs i (Node _ k m l r)+       | i `after` m     =  xs+       | i `before` k    =  go xs i l+       | i `overlaps` k  =  go (k : go xs i r) i l+       | otherwise       =  go (go xs i r) i l++-- | Return the set of all intervals which are completely inside the given interval.+--+-- /O(n)/, since potentially all values could be inside the interval.+-- /O(log n)/ average case, if few keys are inside the interval.+within :: (Interval k e) => IntervalSet k -> k -> IntervalSet k+t `within` iv = fromDistinctAscList (go [] iv t)+  where+    go xs i Nil = i `seq` xs+    go xs i (Node _ k m l r)+       | i `after` m     =  xs+       | i `before` k    =  go xs i l+       | i `subsumes` k  =  go (k : go xs i r) i l+       | otherwise       =  go (go xs i r) i l+++-- | /O(log n)/. Insert a new value. If the set already contains an element equal to the value,+-- it is replaced by the new value.+insert :: (Interval k e, Ord k) => k -> IntervalSet k -> IntervalSet k+insert v s = v `seq` turnBlack (ins s)+  where+    singletonR k = Node R k k Nil Nil+    ins Nil = singletonR v+    ins (Node color k m l r) =+      case compare v k of+        LT -> balanceL color k (ins l) r+        GT -> balanceR color k l (ins r)+        EQ -> Node color v m l r++balanceL :: (Interval k e) => Color -> k -> IntervalSet k -> IntervalSet k -> IntervalSet k+balanceL B zk (Node R yk _ (Node R xk _ a b) c) d =+    mNode R yk (mNode B xk a b) (mNode B zk c d)+balanceL B zk (Node R xk _ a (Node R yk _ b c)) d =+    mNode R yk (mNode B xk a b) (mNode B zk c d)+balanceL c xk l r = mNode c xk l r++balanceR :: (Interval k e) => Color -> k -> IntervalSet k -> IntervalSet k -> IntervalSet k+balanceR B xk a (Node R yk _ b (Node R zk _ c d)) =+    mNode R yk (mNode B xk a b) (mNode B zk c d)+balanceR B xk a (Node R zk _ (Node R yk _ b c) d) =+    mNode R yk (mNode B xk a b) (mNode B zk c d)+balanceR c xk l r = mNode c xk l r+++-- min/max++-- | /O(log n)/. Returns the least interval in the set.+findMin :: IntervalSet k -> Maybe k+findMin (Node _ k _ Nil _) = Just k+findMin (Node _ _ _ l _) = findMin l+findMin Nil = Nothing++-- | /O(log n)/. Returns the largest interval in the set.+findMax :: IntervalSet k -> Maybe k+findMax (Node _ k _ _ Nil) = Just k+findMax (Node _ _ _ _ r) = findMax r+findMax Nil = Nothing++-- | Returns the interval with the largest endpoint.+-- If there is more than one interval with that endpoint,+-- return the rightmost.+--+-- /O(n)/, since all intervals could have the same endpoint.+-- /O(log n)/ average case.+findLast :: (Interval k e) => IntervalSet k -> Maybe k+findLast Nil = Nothing+findLast t@(Node _ _ mx _ _) = go t+  where+    go (Node _ k m l r) | sameU m mx = if sameU k m then go r `or` Just k+                                                    else go r `or` go l+                        | otherwise  = Nothing+    go Nil = Nothing+    sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b+    Nothing `or` x = x+    x       `or` _ = x+++-- Type to indicate whether the number of black nodes changed or stayed the same.+data DeleteResult k = U !(IntervalSet k)   -- Unchanged+                    | S !(IntervalSet k)   -- Shrunk++unwrap :: DeleteResult k -> IntervalSet k+unwrap (U m) = m+unwrap (S m) = m++-- DeleteResult with value+data DeleteResult' k a = U' !(IntervalSet k) a+                       | S' !(IntervalSet k) a++unwrap' :: DeleteResult' k a -> IntervalSet k+unwrap' (U' m _) = m+unwrap' (S' m _) = m++-- annotate DeleteResult with value+annotate :: DeleteResult k -> a -> DeleteResult' k a+annotate (U m) x = U' m x+annotate (S m) x = S' m x+++-- | /O(log n)/. Remove the smallest element from the set. Return the empty set if the set is empty.+deleteMin :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k+deleteMin Nil = Nil+deleteMin m   = turnBlack (unwrap' (deleteMin' m))++deleteMin' :: (Interval k e, Ord k) => IntervalSet k -> DeleteResult' k k+deleteMin' Nil = error "deleteMin': Nil"+deleteMin' (Node B k _ Nil Nil) = S' Nil k+deleteMin' (Node B k _ Nil r@(Node R _ _ _ _)) = U' (turnBlack r) k+deleteMin' (Node R k _ Nil r) = U' r k+deleteMin' (Node c k _ l r) =+  case deleteMin' l of+    (U' l' kv) -> U' (mNode c k l' r) kv+    (S' l' kv) -> annotate (unbalancedR c k l' r) kv++deleteMax' :: (Interval k e, Ord k) => IntervalSet k -> DeleteResult' k k+deleteMax' Nil = error "deleteMax': Nil"+deleteMax' (Node B k _ Nil Nil) = S' Nil k+deleteMax' (Node B k _ l@(Node R _ _ _ _) Nil) = U' (turnBlack l) k+deleteMax' (Node R k _ l Nil) = U' l k+deleteMax' (Node c k _ l r) =+  case deleteMax' r of+    (U' r' kv) -> U' (mNode c k l r') kv+    (S' r' kv) -> annotate (unbalancedL c k l r') kv++-- The left tree lacks one Black node+unbalancedR :: (Interval k e, Ord k) => Color -> k -> IntervalSet k -> IntervalSet k -> DeleteResult k+-- Decreasing one Black node in the right+unbalancedR B k l r@(Node B _ _ _ _) = S (balanceR B k l (turnRed r))+unbalancedR R k l r@(Node B _ _ _ _) = U (balanceR B k l (turnRed r))+-- Taking one Red node from the right and adding it to the right as Black+unbalancedR B k l (Node R rk _ rl@(Node B _ _ _ _) rr)+  = U (mNode B rk (balanceR B k l (turnRed rl)) rr)+unbalancedR _ _ _ _ = error "unbalancedR"++unbalancedL :: (Interval k e, Ord k) => Color -> k -> IntervalSet k -> IntervalSet k -> DeleteResult k+unbalancedL R k l@(Node B _ _ _ _) r = U (balanceL B k (turnRed l) r)+unbalancedL B k l@(Node B _ _ _ _) r = S (balanceL B k (turnRed l) r)+unbalancedL B k (Node R lk _ ll lr@(Node B _ _ _ _)) r+  = U (mNode B lk ll (balanceL B k (turnRed lr) r))+unbalancedL _ _ _ _ = error "unbalancedL"+++-- | /O(log n)/. Remove the largest element from the set. Return the empty set if the set is empty.+deleteMax :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k+deleteMax Nil = Nil+deleteMax m   = turnBlack (unwrap' (deleteMax' m))++-- | /O(log n)/. Delete and return the smallest element.+deleteFindMin :: (Interval k e, Ord k) => IntervalSet k -> (k, IntervalSet k)+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 element.+deleteFindMax :: (Interval k e, Ord k) => IntervalSet k -> (k, IntervalSet k)+deleteFindMax mp = case deleteMax' mp of+                     (U' r v) -> (v, turnBlack r)+                     (S' r v) -> (v, turnBlack r)++-- | /O(log n)/. Retrieves the minimal element of the set, and+-- the set stripped of that element, or 'Nothing' if passed an empty set.+minView :: (Interval k e, Ord k) => IntervalSet k -> Maybe (k, IntervalSet k)+minView Nil = Nothing+minView x   = Just (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal element of the set, and+-- the set stripped of that element, or 'Nothing' if passed an empty set.+maxView :: (Interval k e, Ord k) => IntervalSet k -> Maybe (k, IntervalSet k)+maxView Nil = Nothing+maxView x   = Just (deleteFindMax x)+++-- folding++-- | /O(n)/. Fold the values in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+foldr :: (k -> b -> b) -> b -> IntervalSet k -> b+foldr _ z Nil = z+foldr f z (Node _ k _ l r) = foldr f (f k (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' :: (k -> b -> b) -> b -> IntervalSet k -> b+foldr' f z s = z `seq` case s of+                         Nil -> z+                         Node _ k _ l r -> foldr' f (f k (foldr' f z r)) l++-- | /O(n)/. Fold the values in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+foldl :: (b -> k -> b) -> b -> IntervalSet k -> b+foldl _ z Nil = z+foldl f z (Node _ k _ l r) = foldl f (f (foldl f z l) k) 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 -> k -> b) -> b -> IntervalSet k -> b+foldl' f z s = z `seq` case s of+                         Nil -> z+                         Node _ k _ l r -> foldl' f (f (foldl' f z l) k) r++-- delete++-- | /O(log n)/. Delete an element from the set. If the set does not contain the value,+-- it is returned unchanged.+delete :: (Interval k e, Ord k) => k -> IntervalSet k -> IntervalSet k+delete key mp = turnBlack (unwrap (delete' key mp))++delete' :: (Interval k e, Ord k) => k -> IntervalSet k -> DeleteResult k+delete' x Nil = x `seq` U Nil+delete' x (Node c k _ l r) =+  case compare x k of+    LT -> case delete' x l of+            (U l') -> U (mNode c k l' r)+            (S l')    -> unbalancedR c k l' r+    GT -> case delete' x r of+            (U r') -> U (mNode c k l r')+            (S r')    -> unbalancedL c k l r'+    EQ -> case r of+            Nil -> if c == B then blackify l else U l+            _ -> case deleteMin' r of+                   (U' r' rk) -> U (mNode c rk l r')+                   (S' r' rk) -> unbalancedL c rk l r'++blackify :: IntervalSet k -> DeleteResult k+blackify (Node R k m l r) = U (Node B k m l r)+blackify s                = S s+++-- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate elements are encountered.+union :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k+union m1 m2 = fromDistinctAscList (ascListUnion (toAscList m1) (toAscList m2))++-- | The union of a list of sets:+--   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: (Interval k e, Ord k) => [IntervalSet k] -> IntervalSet k+unions []  = empty+unions [s] = s+unions iss = fromDistinctAscList (head (go (L.map toAscList iss)))+  where+    go []       = []+    go xs@[_]   = xs+    go (x:y:xs) = go (ascListUnion x y : go xs)++-- | /O(n+m)/. Difference of two sets.+-- Return elements of the first set not existing in the second set.+difference :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k+difference m1 m2 = fromDistinctAscList (ascListDifference (toAscList m1) (toAscList m2))++-- | /O(n+m)/. Intersection of two sets.+-- Return elements in the first set also existing in the second set.+intersection :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k+intersection m1 m2 = fromDistinctAscList (ascListIntersection (toAscList m1) (toAscList m2))++ascListUnion :: Ord k => [k] -> [k] -> [k]+ascListUnion [] [] = []+ascListUnion [] ys = ys+ascListUnion xs [] = xs+ascListUnion xs@(x:xs') ys@(y:ys') =+  case compare x y of+    LT -> x : ascListUnion xs' ys+    GT -> y : ascListUnion xs ys'+    EQ -> x : ascListUnion xs' ys'++ascListDifference :: Ord k => [k] -> [k] -> [k]+ascListDifference [] _  = []+ascListDifference xs [] = xs+ascListDifference xs@(xk:xs') ys@(yk:ys') =+  case compare xk yk of+    LT -> xk : ascListDifference xs' ys+    GT -> ascListDifference xs ys'+    EQ -> ascListDifference xs' ys'++ascListIntersection :: Ord k => [k] -> [k] -> [k]+ascListIntersection [] _ = []+ascListIntersection _ [] = []+ascListIntersection xs@(xk:xs') ys@(yk:ys') =+  case compare xk yk of+    LT -> ascListIntersection xs' ys+    GT -> ascListIntersection xs ys'+    EQ -> xk : ascListIntersection xs' ys'+++-- --- Conversion ---++-- | /O(n)/. The list of all values contained in the set, in ascending order.+toAscList :: IntervalSet k -> [k]+toAscList m = foldr (\k r -> k : r) [] m++-- | /O(n)/. The list of all values in the set, in no particular order.+toList :: IntervalSet k -> [k]+toList s = go s []+  where+    go Nil              xs = xs+    go (Node _ k _ l r) xs = k : go l (go r xs)++-- | /O(n)/. The list of all values in the set, in descending order.+toDescList :: IntervalSet k -> [k]+toDescList m = foldl (\r k -> k : r) [] m++-- | /O(n log n)/. Build a set from a list of elements. See also 'fromAscList'.+-- If the list contains duplicate values, the last value is retained.+fromList :: (Interval k e, Ord k) => [k] -> IntervalSet k+fromList xs = L.foldl' (\m k -> insert k m) empty xs++-- | /O(n)/. Build a set from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: (Interval k e, Eq k) => [k] -> IntervalSet k+fromAscList xs = fromDistinctAscList (uniq xs)++uniq :: Eq k => [k] -> [k]+uniq [] = []+uniq (x:xs) = go x xs+  where+    go v [] = [v]+    go v (y:ys) | v == y    = go v ys+                | otherwise = v : go y ys+                              +-- Strict tuple+data T2 a b = T2 !a !b+++-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+fromDistinctAscList :: (Interval k e) => [k] -> IntervalSet k+-- 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:xs') -> T2 (Node B k k 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:xs')) ->+                     case buildB n' xs' of { (T2 r xs'') ->+                     T2 (mNode B k l r) xs'' }}}++    buildR n d xs | d `seq` xs `seq` n == 0 = T2 Nil xs+                  | n == 1    = case xs of (k:xs') -> T2 (Node (if d==0 then R else B) k k 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:xs')) ->+                      case buildR (n - (n' + 1)) (d-1) xs' of { (T2 r xs'') ->+                      T2 (mNode B k 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 set, in ascending order.+elems :: IntervalSet k -> [k]+elems s = toAscList s++-- --- Mapping ---++-- | /O(n log n)/. Map a function over all values in the set.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- elements to the same value.+map :: (Interval a e1, Interval b e2, Ord b) => (a -> b) -> IntervalSet a -> IntervalSet b+map f s = fromList [f x | x <- toList s]++-- | /O(n)/. @'mapMonotonic' f s == 'map' 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./+mapMonotonic :: (Interval k2 e, Ord k2) => (k1 -> k2) -> IntervalSet k1 -> IntervalSet k2+mapMonotonic _ Nil = Nil+mapMonotonic f (Node c k _ l r) =+    mNode c (f k) (mapMonotonic f l) (mapMonotonic f r)++-- | /O(n)/. Filter values satisfying a predicate.+filter :: (Interval k e) => (k -> Bool) -> IntervalSet k -> IntervalSet k+filter p s = fromDistinctAscList (L.filter p (toAscList s))++-- | /O(n)/. Partition the set according to a predicate. The first+-- set contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: (Interval k e) => (k -> Bool) -> IntervalSet k -> (IntervalSet k, IntervalSet k)+partition p s = let (xs,ys) = L.partition p (toAscList s)+                in (fromDistinctAscList xs, fromDistinctAscList ys)++-- | /O(n)/. The expression (@'split' k set@) is a pair @(set1,set2)@ where+-- the elements in @set1@ are smaller than @k@ and the elements in @set2@ larger than @k@.+-- Any key equal to @k@ is found in neither @set1@ nor @set2@.+split :: (Interval i k, Ord i) => i -> IntervalSet i -> (IntervalSet i, IntervalSet i)+split x m = (l, r)+  where (l, _, r) = splitMember x m+     +-- | /O(n)/. The expression (@'splitMember' k set@) splits a set just+-- like 'split' but also returns @'member' k set@.+splitMember :: (Interval i k, Ord i) => i -> IntervalSet i -> (IntervalSet i, Bool, IntervalSet i)+splitMember x s = case span (< x) (toAscList s) of+                    ([], [])                    -> (empty, False, empty)+                    ([], (y:_))     | y == x    -> (empty, True, deleteMin s)+                                    | otherwise -> (empty, False, s)+                    (_, [])                     -> (s, False, empty)+                    (lt, ge@(y:gt)) | y == x    -> (fromDistinctAscList lt, True, fromDistinctAscList gt)+                                    | otherwise -> (fromDistinctAscList lt, False, fromDistinctAscList ge)++-- subsets++-- | /O(n+m)/.+isSubsetOf :: (Ord k) => IntervalSet k -> IntervalSet k -> Bool+isSubsetOf m1 m2 = go (toAscList m1) (toAscList m2)+  where+    go []    _  =  True+    go (_:_) [] =  False+    go s1@(k1:r1) (k2:r2) =+       case compare k1 k2 of+         GT -> go s1 r2+         EQ -> go r1 r2+         LT -> False++-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +isProperSubsetOf :: (Ord k) => IntervalSet k -> IntervalSet k -> Bool+isProperSubsetOf m1 m2 = size m1 < size m2 && isSubsetOf m1 m2++-- debugging+++-- | The height of the tree. For testing/debugging only.+height :: IntervalSet k -> 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)+++-- | Check red-black-tree and interval search augmentation invariants.+-- For testing/debugging only.+valid :: (Interval i k, Ord i) => IntervalSet i -> 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 :: IntervalSet k -> 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+

@@ -1,5 +1,5 @@ Name:                IntervalMap-Version:             0.4.0.1+Version:             0.4.1.0 Stability:           experimental Synopsis:            Maps from Intervals to values, with efficient search. Homepage:            http://www.chr-breitkopf.de/comp/IntervalMap@@ -8,27 +8,33 @@ Author:              Christoph Breitkopf Maintainer:          Christoph Breitkopf <chbreitkopf@gmail.com> bug-reports:         mailto:chbreitkopf@gmail.com-Copyright:           2011-2014 Christoph Breitkopf+Copyright:           2011-2015 Christoph Breitkopf Category:            Data Build-type:          Simple Cabal-version:       >= 1.8-Tested-With:         GHC==7.8.3+Tested-With:         GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.2 Description:-                     A map from intervals to values, with efficient search+                     Ordered containers of intervals, with efficient search                      for all keys containing a point or overlapping an interval.                      See the example code on the home page for a quick introduction.  extra-source-files:   README.md+  changelog   test/*.hs   examples/*.lhs +Flag HPC+  Description: Enable HPC test coverage support+  Default:     False+ Library   Exposed-modules:     Data.IntervalMap, Data.IntervalMap.Lazy,                        Data.IntervalMap.Strict, Data.IntervalMap.Interval,                        Data.IntervalMap.Generic.Interval,                        Data.IntervalMap.Generic.Lazy,-                       Data.IntervalMap.Generic.Strict+                       Data.IntervalMap.Generic.Strict,+                       Data.IntervalSet   other-modules:       Data.IntervalMap.Generic.Base   Build-depends:       base >= 4 && < 5, containers, deepseq   ghc-options: -Wall@@ -41,7 +47,11 @@   hs-source-dirs:     . test   build-depends:      base >= 4 && < 5, containers, deepseq,                       QuickCheck, Cabal >= 1.9.2-+  if flag(HPC)+    ghc-options:        -with-rtsopts=-K1K -fhpc+  else+    ghc-options:        -with-rtsopts=-K1K+    Test-Suite TestGenericInterval   type:               exitcode-stdio-1.0@@ -49,6 +59,10 @@   hs-source-dirs:     . test   build-depends:      base >= 4 && < 5, containers, deepseq,                       QuickCheck, Cabal >= 1.9.2+  if flag(HPC)+    ghc-options:        -with-rtsopts=-K1K -fhpc+  else+    ghc-options:        -with-rtsopts=-K1K  Test-Suite TestIntervalMap   type:               exitcode-stdio-1.0@@ -56,7 +70,22 @@   hs-source-dirs:     . test   build-depends:      base >= 4 && < 5, containers, deepseq,                       QuickCheck, Cabal >= 1.9.2+  if flag(HPC)+    ghc-options:        -with-rtsopts=-K1K -fhpc+  else+    ghc-options:        -with-rtsopts=-K1K +Test-Suite TestIntervalSet+  type:               exitcode-stdio-1.0+  main-is:            IntervalSetTests.hs+  hs-source-dirs:     . test+  build-depends:      base >= 4 && < 5, containers, deepseq,+                      QuickCheck, Cabal >= 1.9.2+  if flag(HPC)+    ghc-options:        -with-rtsopts=-K1K -fhpc+  else+    ghc-options:        -with-rtsopts=-K1K+ benchmark bench-all   type:               exitcode-stdio-1.0   hs-source-dirs:     . bench@@ -73,8 +102,26 @@   Build-depends:      base >= 4 && < 5,                       containers, random, deepseq,                       criterion >= 1.0+  ghc-options: -Wall -with-rtsopts=-K1K++benchmark bench-compare-types+  type:               exitcode-stdio-1.0+  hs-source-dirs:     . bench+  main-is:            CompareTypes.hs+  Build-depends:      base >= 4 && < 5,+                      containers, random, deepseq, fingertree >= 0.1, SegmentTree,+                      criterion >= 1.0   ghc-options: -Wall +benchmark bench-rb-impl+  type:               exitcode-stdio-1.0+  hs-source-dirs:     . bench+  main-is:            CompareRBImpl.hs+  Build-depends:      base >= 4 && < 5,+                      containers, random, deepseq,+                      criterion >= 1.0+  ghc-options: -Wall -with-rtsopts=-K1K+ source-repository head-  type:     darcs-  location: http://hub.darcs.net/bokesan/IntervalMap+  type:     git+  location: https://github.com/bokesan/IntervalMap

@@ -1,4 +1,4 @@-Copyright (c) 2011-2014, Christoph Breitkopf+Copyright (c) 2011-2015, Christoph Breitkopf  All rights reserved. 

@@ -1,20 +1,14 @@-# IntervalMap+# IntervalMap [![Build Status](https://travis-ci.org/bokesan/IntervalMap.svg?branch=master)](https://travis-ci.org/bokesan/IntervalMap) -Maps with intervals as keys offering efficient search.+Containers for intervals offering efficient search.  Home page and documentation: [http://www.chr-breitkopf.de/comp/IntervalMap/index.html](http://www.chr-breitkopf.de/comp/IntervalMap/index.html)   Install from hackage with cabal install. -To run the tests, do extract the archive, and do+To run the tests, extract the archive, and do      $ cabal configure --enable-tests     $ cabal build     $ cabal test-----------Christoph Breitkopf <chbreitkopf@gmail.com>--Last edit: 2014-07-30

@@ -0,0 +1,98 @@+{-# 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.List (sort)++import Data.IntervalMap.Generic.Interval+import qualified Data.IntervalMap.Generic.Strict as S+import qualified RBColorInt as L+import qualified RBColorNode as N++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-rb-impl.html" }++cDATA_SIZE :: Int+cDATA_SIZE =  500000++cTEST_SIZE :: Int+cTEST_SIZE =  25000++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+++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 $ take cTEST_SIZE [i | (i,_) <- ivsP]+      sMap <- ensure $ S.fromAscList oIvsP+      lMap <- ensure $ L.fromAscList oIvsP+      nMap <- ensure $ N.fromAscList oIvsP+      rndInts <- ensure (genRandomInts 1 cDATA_SIZE cTEST_SIZE)+      defaultMainWith benchConfig [+         bgroup "fromAscList" [+           bench "regular" $ nf S.fromAscList oIvsP,+           bench "int"     $ nf L.fromAscList oIvsP,+           bench "node"    $ nf N.fromAscList oIvsP+         ],+         bgroup "lookup" [+           bench "reg"    $ nf (\m -> [S.lookup i m | i <- lookupKeys]) sMap,+           bench "int"    $ nf (\m -> [L.lookup i m | i <- lookupKeys]) lMap,+           bench "node"   $ nf (\m -> [N.lookup i m | i <- lookupKeys]) nMap+         ],+         bgroup "containing" [+           bench "reg"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.containing` p]) sMap,+           bench "int"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.containing` p]) lMap,+           bench "node"   $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `N.containing` p]) nMap+         ],+         bgroup "intersecting" [+           bench "reg"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.intersecting` (IV p (p+15))]) sMap,+           bench "int"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.intersecting` (IV p (p+15))]) lMap,+           bench "node"   $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `N.intersecting` (IV p (p+15))]) nMap+         ],+         bgroup "within" [+           bench "reg"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.within` (IV p (p+15))]) sMap,+           bench "int"    $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.within` (IV p (p+15))]) lMap,+           bench "node"   $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `N.within` (IV p (p+15))]) nMap+         ]+       ]

@@ -0,0 +1,196 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Criterion.Main+import Criterion.Types (Config(..), Verbosity(..))++import Control.DeepSeq+import Prelude hiding (lookup, max, foldr)+import System.Random+import Data.List (nub)+import Data.Foldable (foldr)+import Data.Maybe++import IntRange+import qualified Data.IntervalMap.Generic.Strict as RB+import qualified IvMapSortedList as SL+import qualified Data.IntervalMap.FingerTree as FT+import qualified Data.SegmentTree as ST+++instance Ord a => Interval (FT.Interval a) a where+  lowerBound = FT.low+  upperBound = FT.high++instance Ord a => Interval (ST.Interval a) a where+  lowerBound (ST.Interval _ (ST.R a) _ _) = a+  lowerBound _ = error "interval lower"+  upperBound (ST.Interval _ _ (ST.R a) _) = a+  upperBound _ = error "interval upper"+++instance NFData a => NFData (FT.Interval a) where+  rnf (FT.Interval a b) = a `deepseq` b `deepseq` ()++instance NFData a => NFData (ST.Interval a) where+  rnf (ST.Interval _ (ST.R a) (ST.R b) _) = a `deepseq` b `deepseq` ()+  rnf a = a `seq` ()++instance (NFData k, NFData v) => NFData (FT.IntervalMap k v) where+  -- FIXME+  rnf a = a `seq` ()++instance NFData v => NFData (ST.STree v Int) where+  rnf (ST.Leaf a b) = a `deepseq` b `deepseq`()+  rnf (ST.Branch a b c d) = a `deepseq` b `deepseq` c `deepseq` d `deepseq` ()++ftFromList :: Ord k => [(FT.Interval k, v)] -> FT.IntervalMap k v+ftFromList =  foldr (\(k,v) m -> FT.insert k v m) FT.empty++stFromList :: [(Int,Int)] -> ST.STree [ST.Interval Int] Int+stFromList = ST.fromList++stLoBound :: ST.Interval Int -> Int+stLoBound (ST.Interval{ST.low=(ST.R v)}) = v+stLoBound _ = error "stLoBound"++cSEED, cSEED2 :: Int+cSEED  = 54321+cSEED2 = 12345++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))++genRandomIntervals :: Int -> Int -> Int -> [IntRange]+genRandomIntervals = genRandomIntervalsWithSeed cSEED++genRandomIntervalsWithSeed :: Int -> Int -> Int -> Int -> [IntRange]+genRandomIntervalsWithSeed seed 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 IntRange lo (lo + sz) : genIvs xs+++benchConfig :: Config+benchConfig =  defaultConfig { reportFile = Just "bench-compare-types.html", verbosity = Verbose }++cNUM_KEYS :: Int+cNUM_KEYS =  10++mkKeys :: Int -> [IntRange]+mkKeys n =  genRandomIntervalsWithSeed cSEED2 n 18 cNUM_KEYS ++ [IntRange 0 1, IntRange (n+1) (n+2)]++slEnv :: Int -> IO ([IntRange], SL.IVS IntRange Int)+slEnv n = do+   let ivs = genRandomIntervals n 20 n+   return (mkKeys n, SL.fromList [(iv, lowerBound iv) | iv <- ivs])++rbEnv :: Int -> IO ([IntRange], RB.IntervalMap IntRange Int)+rbEnv n = do+   let ivs = genRandomIntervals n 20 n+   return (mkKeys n, RB.fromList [(iv, lowerBound iv) | iv <- ivs])++ftEnv :: Int -> IO ([FT.Interval Int], FT.IntervalMap Int Int)+ftEnv n = do+   let ivs  = genRandomIntervals n 20 n+   let ivsFt = [(FT.Interval lo hi, lo) | (IntRange lo hi) <- nub ivs]+   return (map toIv (mkKeys n), ftFromList ivsFt)+  where+   toIv (IntRange a b) = FT.Interval a b++stEnv :: Int -> IO ([ST.Interval Int], ST.STree [ST.Interval Int] Int)+stEnv n = do+   let ivs  = genRandomIntervals n 20 n+   let ivsFt = [(lo,hi) | (IntRange lo hi) <- nub ivs]+   return (map toIv (mkKeys n), stFromList ivsFt)+  where+   toIv (IntRange a b) = ST.Interval ST.Closed (ST.R a) (ST.R b) ST.Closed+++runInsert :: Interval k a => (k -> a -> m -> m) -> m -> [k] -> m+runInsert ins m keys = foldr (\k mp -> ins k (lowerBound k) mp) m keys++runLookup :: (k -> m -> Maybe Int) -> m -> [k] -> Int+runLookup f m keys = sum $ catMaybes $ map (\k -> f k m) keys++runContains :: (Interval i e) => (t -> e -> [(t1, Int)]) -> t -> [i] -> Int+runContains f m keys = sum [v | k <- keys, (_,v) <- f m (lowerBound k)]++benchIV name ins look cont ~(keys,m) = bgroup name [+    bench "insert"      $ whnf (runInsert ins m) keys,+    bench "lookup"      $ nf (runLookup look m) keys,+    bench "containing"  $ nf (runContains cont m) keys+  ]++benchSL :: ([IntRange], SL.IVS IntRange Int) -> Benchmark+benchSL = benchIV "SortedList" SL.insert SL.lookup SL.containing++benchRB :: ([IntRange], RB.IntervalMap IntRange Int) -> Benchmark+benchRB = benchIV "RedBlackTree" RB.insert RB.lookup RB.containing++benchFT :: ([FT.Interval Int], FT.IntervalMap Int Int) -> Benchmark+benchFT ~(keys,m) = bgroup "FingerTree" [+    bench "insert"      $ whnf (runInsert FT.insert m) keys,+    bench "containing"  $ nf (\ks -> sum [v | k <- ks, (_,v) <- FT.search (FT.low k) m]) keys+  ]++benchST :: ([ST.Interval Int], ST.STree [ST.Interval Int] Int) -> Benchmark+benchST ~(keys,m) = bgroup "SegmentTree" [+    bench "insert"      $ whnf (runInsert (\k _ mp -> ST.insert mp k) m) keys,+    bench "containing"  $ nf (\ks -> sum [stLoBound v | k <- ks, v <- ST.stabbingQuery m (stLoBound k)]) keys+  ]++++main :: IO ()+main = defaultMainWith benchConfig [+        bgroup "10" [+           env (slEnv 10) benchSL,+           env (rbEnv 10) benchRB,+           env (ftEnv 10) benchFT,+           env (stEnv 10) benchST+         ],+         bgroup "100" [+           env (slEnv 100) benchSL,+           env (rbEnv 100) benchRB,+           env (ftEnv 100) benchFT,+           env (stEnv 100) benchST+         ],+         bgroup "1000" [+           env (slEnv 1000) benchSL,+           env (rbEnv 1000) benchRB,+           env (ftEnv 1000) benchFT,+           env (stEnv 1000) benchST+         ],+         bgroup "2500" [+           env (slEnv 2500) benchSL,+           env (rbEnv 2500) benchRB,+           env (ftEnv 2500) benchFT,+           env (stEnv 2500) benchST+         ],+         bgroup "10000" [+           env (rbEnv 10000) benchRB,+           env (ftEnv 10000) benchFT,+           env (stEnv 10000) benchST+         ],+         bgroup "20000" [+           env (rbEnv 20000) benchRB,+           env (ftEnv 20000) benchFT,+           env (stEnv 20000) benchST+         ],+         bgroup "50000" [+           env (rbEnv 50000) benchRB,+           env (ftEnv 50000) benchFT,+           env (stEnv 50000) benchST+         ],+         bgroup "100000" [+           env (rbEnv 100000) benchRB,+           env (ftEnv 100000) benchFT,+           env (stEnv 100000) benchST+         ]+       ]

@@ -12,7 +12,7 @@  import Data.IntervalMap.Generic.Interval import qualified Data.IntervalMap.Generic.Lazy as L-import qualified Data.IntervalMap.Generic.Lazy as S+import qualified Data.IntervalMap.Generic.Strict as S   seed :: Int

@@ -0,0 +1,18 @@+0.4.1.0  Add IntervalSet.+         Minor performance tweaks.+         Documentation updates.+         Moved to GitHub.++0.4.0.1  Documentation update. Wrong portability info fixed.++0.4.0.0  Major update adding support for user-defined key intervals.++0.3.0.3  Updated benchmark to use Criterion 1.0. Tested with ghc 7.8.3.++0.3.0.2  Dropped upper constraint on criterion. Tested with ghc 7.6.3.+         Migrated repo to Darcs Hub.++0.3.0.1  Bugfixes: Lazy was too strict, Strict too lazy.++0.3.0.0  Split into Lazy and Strict modules, following containers.+

@@ -52,9 +52,6 @@  > 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:

@@ -16,20 +16,20 @@  instance Arbitrary II where   arbitrary = do x <- arbitrary-		 liftM II (interval (abs x))+                 liftM II (interval (abs x))  interval :: Int -> Gen (Interval Int) 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)]+             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)]  instance Arbitrary IMI where   arbitrary = do xs <- orderedList-		 return (IMI (fromAscList [(v, lowerBound v) | (II v) <- xs]))+                 return (IMI (fromAscList [(v, lowerBound v) | (II v) <- xs]))   emptyM, single46 :: M.IntervalMap Int String@@ -51,11 +51,11 @@  bal3 :: M.IntervalMap Int String bal3 =  let m1 = M.insert (ClosedInterval 1 4) "14" single46-	in M.insert (ClosedInterval 5 8) "58" m1+        in M.insert (ClosedInterval 5 8) "58" m1  bal3' :: M.IntervalMap Int String bal3' =  let m1 = M.insert (ClosedInterval 1 4) "14" single46-	 in M.insert (OpenInterval 5 8) "o58" m1+         in M.insert (OpenInterval 5 8) "o58" m1  prop_tests2 =    3 == M.size bal3 &&@@ -82,12 +82,12 @@ deep100L :: M.IntervalMap Int Int deep100L = construct 100 M.empty   where construct n m  | n <= 0    = m-		       | otherwise = construct (n - 1) (M.insert (ClosedInterval n n) n m)+                       | otherwise = construct (n - 1) (M.insert (ClosedInterval n n) n m)  deep100R :: M.IntervalMap Int Int deep100R = construct 1 M.empty   where construct n m  | n > 100   = m-		       | otherwise = construct (n + 1) (M.insert (ClosedInterval n n) n m)+                       | otherwise = construct (n + 1) (M.insert (ClosedInterval n n) n m)   prop_tests3 =@@ -107,48 +107,51 @@    M.valid (M.delete (ClosedInterval 23 23) deep100R)  prop_mapKeys =-		equalMap ["foo"] (M.mapKeys lower (M.insert (ClosedInterval 4 5) "foo" single46)) &&-		equalMap ["single46"] (M.mapKeys lower (M.insert (ClosedInterval 4 7) "foo" single46))+                equalMap ["foo"] (M.mapKeys lower (M.insert (ClosedInterval 4 5) "foo" single46)) &&+                equalMap ["single46"] (M.mapKeys lower (M.insert (ClosedInterval 4 7) "foo" single46))   where lower k = ClosedInterval (lowerBound k) (lowerBound k)  prop_mapKeysWith (IMI m) = M.valid m' && all correct (M.keys m)   where lower k = ClosedInterval (lowerBound k) (lowerBound k)-	m' = M.mapKeysWith (+) lower m-	correct x = let mps = sum [v | (k,v) <- M.toList m, lowerBound k == lowerBound x]-		    in case M.lookup (lower x) m' of-		         Nothing -> False-			 Just v' -> v' == mps-			-	+        m' = M.mapKeysWith (+) lower m+        correct x = let mps = sum [v | (k,v) <- M.toList m, lowerBound k == lowerBound x]+                    in case M.lookup (lower x) m' of+                         Nothing -> False+                         Just v' -> v' == mps+                        +               -- check that our generator yields valid maps. prop_valid (IMI m) = M.valid m +prop_singleton (II k) = let m = singleton k 'a' in+                        m!k == 'a' && size m == 1+ prop_delete (IMI m) (II k) = let m' = M.delete k m in-			     M.valid m' &&-			     notMember k m' &&-			     if M.null m          then M.null m'-			     else if M.member k m then M.size m' == M.size m - 1-			     else                      M.size m' == M.size m+                             M.valid m' &&+                             notMember k m' &&+                             if M.null m          then M.null m'+                             else if M.member k m then M.size m' == M.size m - 1+                             else                      M.size m' == M.size m  prop_insert (IMI m) (II k) = let m' = M.insert k 4711 m in                              M.valid m' &&-			     M.lookup k m' == Just 4711 &&-			     if M.member k m then M.size m' == M.size m-				             else M.size m' == M.size m + 1+                             M.lookup k m' == Just 4711 &&+                             if M.member k m then M.size m' == M.size m+                                             else M.size m' == M.size m + 1  prop_min (IMI m) = if M.null m then M.null (M.deleteMin m) else                                       let (k,v) = findMin m-					  m' = deleteMin m-				      in notMember k m' && M.size m == M.size m' + 1-					 && k == minimum (M.keys m) && valid m'+                                          m' = deleteMin m+                                      in notMember k m' && M.size m == M.size m' + 1+                                         && k == minimum (M.keys m) && valid m'  prop_max (IMI m) = if M.null m then M.null (M.deleteMax m) else                                       let (k,v) = findMax m-					  m' = deleteMax m-				      in notMember k m' && M.size m == M.size m' + 1-					 && k == maximum (M.keys m) && valid m'+                                          m' = deleteMax m+                                      in notMember k m' && M.size m == M.size m' + 1+                                         && k == maximum (M.keys m) && valid m'  prop_updateMin_u (IMI m) =    let m' = M.updateMin (\v -> Just (v+1)) m in@@ -207,26 +210,26 @@                                           [e | e@(k,_) <- M.toList m, p `inside` k]  prop_searchInterval (IMI m) (II i) = sameElements (m `intersecting` i)-				                  [e | e@(k,_) <- M.toList m, k `overlaps` i]+                                                  [e | e@(k,_) <- M.toList m, k `overlaps` i]  prop_within (IMI m) (II i) = sameElements (m `M.within` i)                                           [e | e@(k,_) <- M.toList m, i `subsumes` k]  prop_findMin (IMI m) = not (M.null m) ==> let x = minimum (M.toList m)-					      (y,m') = M.deleteFindMin m-					  in M.findMin m == x &&-					     y == x &&-					     M.valid m' &&-					     sameElements (M.toList m Data.List.\\ [x]) (M.toList m') &&-					     sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMin m))+                                              (y,m') = M.deleteFindMin m+                                          in M.findMin m == x &&+                                             y == x &&+                                             M.valid m' &&+                                             sameElements (M.toList m Data.List.\\ [x]) (M.toList m') &&+                                             sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMin m))  prop_findMax (IMI m) = not (M.null m) ==> let x = maximum (M.toList m)-					      (y,m') = M.deleteFindMax m-					  in M.findMax m == x &&-					     y == x &&-					     M.valid m' &&-					     sameElements (M.toList m Data.List.\\ [x]) (M.toList m') &&-					     sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMax m))+                                              (y,m') = M.deleteFindMax m+                                          in M.findMax m == x &&+                                             y == x &&+                                             M.valid m' &&+                                             sameElements (M.toList m Data.List.\\ [x]) (M.toList m') &&+                                             sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMax m))  prop_findLast (IMI m) = not (M.null m) ==>                          M.findLast m == head (sortBy cmp (M.toList m))@@ -239,14 +242,14 @@ prop_insertWith (IMI m) (II i) v = let m' = M.insertWith (\new old -> new + old) i v m in                                    if M.member i m then                                       M.valid m' && m' M.! i == m M.! i + v && M.size m' == M.size m-				   else-				      M.valid m' && m' M.! i == v && M.size m' == M.size m + 1+                                   else+                                      M.valid m' && m' M.! i == v && M.size m' == M.size m + 1  prop_insertWith' (IMI m) (II i) v = let m' = M.insertWith' (\new old -> new + old) i v m in                                     if M.member i m then                                        M.valid m' && m' M.! i == m M.! i + v && M.size m' == M.size m-		 		    else-		 		       M.valid m' && m' M.! i == v && M.size m' == M.size m + 1+                                    else+                                       M.valid m' && m' M.! i == v && M.size m' == M.size m + 1  prop_insertLookupWithKey (IMI m) (II i) v =   case M.insertLookupWithKey (\k new old -> upperBound k + new + old) i v m of@@ -261,25 +264,25 @@  prop_foldr (IMI m) = M.foldr f z m == Prelude.foldr f z [ v | (_,v) <- M.toAscList m ]   where z = []-	f = (:)+        f = (:)  prop_adjust (II i) (IMI m) = let m' = M.adjust (13*) i m in-			     M.valid m' &&+                             M.valid m' &&                              case M.lookup i m of                                Nothing -> m == m'-			       Just v -> case M.lookup i m' of-					   Nothing -> False-					   Just v' -> v' == v * 13+                               Just v -> case M.lookup i m' of+                                           Nothing -> False+                                           Just v' -> v' == v * 13  prop_update (II i) (IMI m) = let f n = if n `rem` 2 == 0 then Nothing else Just (13 * n)-				 m' = M.update f i m-			     in-			         M.valid m' &&-			         case M.lookup i m of-				   Nothing -> m == m'-				   Just v -> case M.lookup i m' of-					       Nothing -> v `rem` 2 == 0-					       Just v' -> v' == 13 * v+                                 m' = M.update f i m+                             in+                                 M.valid m' &&+                                 case M.lookup i m of+                                   Nothing -> m == m'+                                   Just v -> case M.lookup i m' of+                                               Nothing -> v `rem` 2 == 0+                                               Just v' -> v' == 13 * v  prop_alter (IMI m) (II k) = delete && insert   where@@ -289,49 +292,51 @@  prop_union (IMI m1) (IMI m2) =  M.size m' == M.size m1 + numNotInM1 0 (M.keys m2) -- size                                 && valsM1 (M.assocs m1) -- m1 entries unchanged-				&& valsM2 (M.assocs m2) -- m2 entries not in m1 unchanged-				&& M.valid m'+                                && valsM2 (M.assocs m2) -- m2 entries not in m1 unchanged+                                && M.valid m'   where     m' = m1 `M.union` m2      valsM1 [] = True     valsM1 ((k,v):xs) = case M.lookup k m' of-			  Nothing -> False-			  Just v' -> v' == v && valsM1 xs+                          Nothing -> False+                          Just v' -> v' == v && valsM1 xs      valsM2 [] = True     valsM2 ((k,v):xs) | M.member k m1 = valsM2 xs-		      | otherwise = case M.lookup k m' of-				      Nothing -> False-				      Just v' -> v' == v && valsM2 xs+                      | otherwise = case M.lookup k m' of+                                      Nothing -> False+                                      Just v' -> v' == v && valsM2 xs      numNotInM1 n [] = n     numNotInM1 n (k:ks) | M.member k m1 = numNotInM1 n ks-			| otherwise     = numNotInM1 (n+1) ks+                        | otherwise     = numNotInM1 (n+1) ks       prop_unionWithKey (IMI m1) (IMI m2) =  M.size m' == M.size m1 + numNotInM1 0 (M.keys m2) -- size                                        && valuesCorrect (M.assocs m')-				       && M.valid m'+                                       && M.valid m'   where     f k a b = 7 * upperBound k + 3 * b + b     m' = M.unionWithKey f m1 m2      valuesCorrect [] = True     valuesCorrect ((k,v):xs) = case M.lookup k m1 of-			         Nothing -> case M.lookup k m2 of-					      Nothing -> False-					      Just v2 -> v2 == v && valuesCorrect xs-				 Just v1 -> case M.lookup k m2 of-					      Nothing -> v1 == v && valuesCorrect xs-					      Just v2 -> v == f k v1 v2 && valuesCorrect xs+                                 Nothing -> case M.lookup k m2 of+                                              Nothing -> False+                                              Just v2 -> v2 == v && valuesCorrect xs+                                 Just v1 -> case M.lookup k m2 of+                                              Nothing -> v1 == v && valuesCorrect xs+                                              Just v2 -> v == f k v1 v2 && valuesCorrect xs     numNotInM1 n [] = n     numNotInM1 n (k:ks) | M.member k m1 = numNotInM1 n ks-			| otherwise     = numNotInM1 (n+1) ks+                        | otherwise     = numNotInM1 (n+1) ks      -prop_unions (IMI m1) (IMI m2) (IMI m3) = M.unions [m1,m2,m3] == (m1 `M.union` m2 `M.union` m3)+prop_unions ims = M.unions ms == Prelude.foldl M.union empty ms+  where ms = [m | IMI m <- ims] + prop_difference (IMI m1) (IMI m2) =  M.valid m' && m' == Prelude.foldr M.delete m1 (M.keys m2)   where m' = m1 M.\\ m2 @@ -353,7 +358,7 @@ assoc :: Eq k => k -> [(k,a)] -> Maybe a assoc _ [] = Nothing assoc k ((x,v):xs) | x == k    = Just v-		   | otherwise = assoc k xs+                   | otherwise = assoc k xs  prop_mapAccum (IMI m) =  M.valid m' && acc == sum (M.elems m) && sum (M.elems m') == 2 * acc   where (acc, m') = M.mapAccum (\a v -> (a+v, 2*v)) 0 m@@ -375,33 +380,35 @@     odds = length [x | x <- M.elems m, odd x]  prop_partition (IMI m) =  M.valid m1 && M.valid m2 && all odd (M.elems m1) && all even (M.elems m2)-			  && M.size m == M.size m1 + M.size m2+                          && M.size m == M.size m1 + M.size m2    where      (m1,m2) = M.partition odd m   prop_splitLookup (IMI m) (II x) = M.valid l && M.valid r-				  && all (< x) (M.keys l) && all (> x) (M.keys r)-				  && value == M.lookup x m-				  && M.size m == M.size l + M.size r + (if M.member x m then 1 else 0)+                                  && all (< x) (M.keys l) && all (> x) (M.keys r)+                                  && value == M.lookup x m+                                  && M.size m == M.size l + M.size r + (if M.member x m then 1 else 0)   where     (l, value, r) = splitLookup x m +prop_readShow (IMI m) = m == read (show m) + checkElems :: Int -> Int -> [(Interval Int, Int)] -> Bool checkElems n len lyst = h n (n + len) lyst   where     h i n xs | i > n  = True              | otherwise = case xs of ((iv,v):xs') -> if v == i && lowerBound iv == i && upperBound iv == i-						      then h (i+1) n xs'-						      else False+                                                      then h (i+1) n xs'+                                                      else False   check p name = do r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p-		  if isSuccess r-		   then return r-		   else do putStrLn ("error: " ++ name ++ ": " ++ show r)-			   exitFailure+                  if isSuccess r+                   then return r+                   else do putStrLn ("error: " ++ name ++ ": " ++ show r)+                           exitFailure   main :: IO ()@@ -410,43 +417,48 @@           check prop_tests2 "tests2"           check prop_tests3 "tests3"           check prop_mapKeys "mapKeys"-	  check prop_valid "valid"-	  check prop_delete "delete"-	  check prop_insert "insert"-	  check prop_min "min"-	  check prop_max "max"-	  check prop_findWithDefault "findWithDefault"-	  check prop_searchPoint "searchPoint"-	  check prop_searchInterval "searchInterval"+          check prop_valid "valid"+          check prop_singleton "singleton"+          check prop_delete "delete"+          check prop_insert "insert"+          check prop_min "min"+          check prop_max "max"+          check prop_findWithDefault "findWithDefault"+          check prop_searchPoint "searchPoint"+          check prop_searchInterval "searchInterval"           check prop_within "within"-	  check prop_findMin "findMin"-	  check prop_findMax "findMax"+          check prop_findMin "findMin"+          check prop_findMax "findMax"+          check prop_findLast "findLast"           check prop_updateMin_u "updateMin update"           check prop_updateMin_d "updateMin delete"           check prop_updateMax_u "updateMax update"           check prop_updateMax_d "updateMax delete"-	  check prop_insertWith "insertWith"+          check prop_insertWith "insertWith"           check prop_insertWith' "insertWith'"-	  check prop_insertLookupWithKey "insertLookupWithKey"-	  check prop_insertLookupWithKey' "insertLookupWithKey'"-	  check prop_map "map"-	  check prop_foldr "foldr"-	  check prop_fromAscList "fromAscList"-	  check prop_adjust "adjust"-	  check prop_update "update"-	  check prop_union "union"-	  check prop_unionWithKey "unionWithKey"-	  check prop_unions "unions"-	  check prop_difference "difference"-	  check prop_intersection "intersection"-	  check prop_filter "filter"-	  check prop_partition "partition"-	  check prop_splitLookup "splitLookup"-	  check prop_mapKeysWith "mapKeysWith"+          check prop_insertLookupWithKey "insertLookupWithKey"+          check prop_insertLookupWithKey' "insertLookupWithKey'"+          check prop_map "map"+          check prop_mapAccum "mapAccum"+          check prop_foldr "foldr"+          check prop_fromAscList "fromAscList"+          check prop_adjust "adjust"+          check prop_update "update"+          check prop_alter "alter"+          check prop_union "union"+          check prop_unionWithKey "unionWithKey"+          check prop_unions "unions"+          check prop_difference "difference"+          check prop_intersection "intersection"+          check prop_filter "filter"+          check prop_partition "partition"+          check prop_splitLookup "splitLookup"+          check prop_mapKeysWith "mapKeysWith"           check prop_submap "submap"-	  putStrLn ("deep100L: " ++ show (M.showStats deep100L))-	  putStrLn ("deep100R: " ++ show (M.showStats deep100R))-	  exitSuccess+          check prop_readShow "read/show"+          putStrLn ("deep100L: " ++ show (M.showStats deep100L))+          putStrLn ("deep100R: " ++ show (M.showStats deep100R))+          exitSuccess  -- Utils ----------------- @@ -457,11 +469,11 @@ sameElements []     []    = True sameElements []     (_:_) = False sameElements (x:xs) ys    = case tryRemove x ys of-			      Nothing  -> False-			      Just ys' -> sameElements xs ys'+                              Nothing  -> False+                              Just ys' -> sameElements xs ys'   where     tryRemove _ [] = Nothing     tryRemove x (y:ys) | x == y    = Just ys-		       | otherwise = case tryRemove x ys of-				       Nothing  -> Nothing-				       Just ys' -> Just (y : ys')+                       | otherwise = case tryRemove x ys of+                                       Nothing  -> Nothing+                                       Just ys' -> Just (y : ys')

@@ -0,0 +1,212 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- module IntervalSetTests (main) where++import System.Exit (exitSuccess, exitFailure)++import Test.QuickCheck hiding (within)+import Test.QuickCheck.Test (isSuccess)+import Control.Monad (liftM)+import Prelude hiding (null, map, filter, foldr, foldl)+import qualified Data.List as L++import Data.IntervalSet+++data II = II !Int !Int deriving (Eq, Ord, Show, Read)++bump :: Int -> II -> II+bump n (II a b) = II (a+n) (b+n)++contains :: II -> Int -> Bool+contains (II a b) n = a <= n && n <= b++instance Interval II Int where+   lowerBound (II a _) = a+   upperBound (II _ b) = b++instance Arbitrary II where+  arbitrary = do x <- arbitrary+                 iv <- interval (abs x)+                 return iv++interval :: Int -> Gen II+interval x = do y <- sized (\n -> choose (x, x + abs n))+                return (II x y)++newtype IS = IS (IntervalSet II) deriving (Show)+                       +instance Arbitrary IS where+  arbitrary = do xs <- orderedList+                 return (IS (fromAscList xs))++prop_valid (IS s) =               valid s++prop_null (IS s) =                null s == (size s == 0)++prop_size (IS s) =                size s == length (toList s)++prop_singleton :: II -> Bool+prop_singleton iv =               size (singleton iv) == 1+                                  +prop_insert_member (IS s) iv =    member iv (insert iv s)++prop_notMember (IS s) iv =        notMember iv s == not (member iv s)++prop_isSubsetOf (IS s1) (IS s2) = (s1 `isSubsetOf` s2) == L.null (toList s1 L.\\ toList s2)++prop_isProperSubsetOf (IS s1) (IS s2)+                                = (s1 `isProperSubsetOf` s2) ==+                                   (L.null (toList s1 L.\\ toList s2) && s1 /= s2)+                                  +prop_insert_size (IS s) iv =+    let s' = insert iv s in+    if member iv s+      then size s' == size s+      else size s' == size s + 1++prop_delete (IS s) iv =           let s' = delete iv s in+                                  valid s' &&+                                  if notMember iv s then s' == s+                                                    else all (\e -> e `member` s' || e == iv) (toList s)++prop_list (IS s) =                s == fromList (toList s)+prop_asclist (IS s) =             s == fromAscList (toAscList s)+prop_desclist (IS s) =            toDescList s == reverse (toAscList s)+prop_elems (IS s) =               elems s == toAscList s++prop_union (IS s1) (IS s2) =      union s1 s2 == foldr insert s2 s1++prop_unions xs  =                 unions iss == L.foldl union empty iss+                                  where iss = [is | IS is <- xs]++prop_difference (IS s1) (IS s2) = (s1 \\ s2) == foldr delete s1 s2+                                      +prop_intersection (IS s1) (IS s2) =+                                  let i = intersection s1 s2 in+                                  all (\e -> member e s1 && member e s2) (toList i)+                                      +prop_minView (IS s) =             case minView s of+                                    Nothing -> null s+                                    Just (min, s') -> all (min <) (toList s')+                                  +prop_maxView (IS s) =             case maxView s of+                                    Nothing -> null s+                                    Just (max, s') -> all (max >) (toList s')+                                    +prop_findMin (IS s) =             case findMin s of+                                    Nothing  -> null s+                                    Just min -> all (min <=) (toList s)++prop_findMax (IS s) =             case findMax s of+                                     Nothing  -> null s+                                     Just max -> all (max >=) (toList s)++prop_findLast (IS s) =            case findLast s of+                                    Nothing -> null s+                                    Just x@(II _ end) ->+                                      all (\e -> upperBound e < end || (upperBound e == end && e <= x)) (toList s)+                                                      +prop_deleteMin (IS s) =           let s' = deleteMin s in+                                  case findMin s of+                                    Nothing  -> null s'+                                    Just min -> s' == delete min s++prop_deleteMax (IS s) =           let s' = deleteMax s in+                                  case findMax s of+                                    Nothing  -> null s'+                                    Just max -> s' == delete max s+                                                      +prop_map (IS s) n =               s == map (bump n) (map (bump (-n)) s)+prop_mapMonotonic (IS s) n =      s == mapMonotonic (bump n) (mapMonotonic (bump (-n)) s)++prop_filter (IS s) iv =           filter (iv /=) s == delete iv s++prop_partition (IS s) iv =        let (lo,hi) = partition (<= iv) s in+                                  valid lo && valid hi &&+                                  all (<= iv) (toList lo) &&+                                  all (> iv) (toList hi) &&+                                  union lo hi == s++prop_split (IS s) iv =            let (lo,hi) = split iv s in+                                  all (< iv) (toList lo) &&+                                  all (> iv) (toList hi) &&+                                  union lo hi == if member iv s then delete iv s else s++prop_splitMember (IS s) iv =      let (lo,m,hi) = splitMember iv s in+                                  valid lo && valid hi &&+                                  m == member iv s &&+                                  all (< iv) (toList lo) &&+                                  all (> iv) (toList hi) &&+                                  union lo hi == if m then delete iv s else s++prop_readShow (IS s) =            s == read (show s)+++prop_containing :: IS -> Int -> Bool+prop_containing (IS s) n =        let s' = s `containing` n in+                                  all (\e -> if e `contains` n then e `member` s' else e `notMember` s') (toList s)++prop_intersecting :: IS -> II -> Bool+prop_intersecting (IS s) iv =     let s' = s `intersecting` iv in+                                  all (\e -> if e `overlaps` iv then e `member` s' else e `notMember` s') (toList s)+                                      +prop_within :: IS -> II -> Bool+prop_within (IS s) iv =           let s' = s `within` iv in+                                  all (\e -> if iv `subsumes` e then e `member` s' else e `notMember` s') (toList s)+                                  +prop_foldr  (IS s) iv =           Just (foldr  (\v r -> min v r) iv s) == findMin (insert iv s)+prop_foldr' (IS s) iv =           Just (foldr' (\v r -> min v r) iv s) == findMin (insert iv s)+prop_foldl  (IS s) iv =           Just (foldl  (\r v -> min v r) iv s) == findMin (insert iv s)+prop_foldl' (IS s) iv =           Just (foldl' (\r v -> min v r) iv s) == findMin (insert iv s)++check p name = do putStrLn ("Testing " ++ name ++ ":")+                  r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p+                  if isSuccess r+                   then return r+                   else do putStrLn ("error: " ++ name ++ ": " ++ show r)+                           exitFailure+++main = do+         check prop_valid "valid"+         check prop_null "null"+         check prop_size "size"+         check prop_notMember "notMember"+         check prop_singleton "singleton"+         check prop_isSubsetOf "subsetOf"+         check prop_isProperSubsetOf "properSubsetOf"+         check prop_insert_member "insert -> member"+         check prop_insert_size "insert + size"+         check prop_delete "delete"+         check prop_list "toList/fromList"+         check prop_asclist "toAscList/fromAscList"+         check prop_desclist "toDescList"+         check prop_elems "elems"+         check prop_union "union"+         check prop_unions "unions"+         check prop_difference "difference"+         check prop_intersection "intersection"+         check prop_findMin "findMin"+         check prop_findMax "findMax"+         check prop_findLast "findLast"+         check prop_deleteMin "deleteMin"+         check prop_deleteMax "deleteMax"+         check prop_minView "minView"+         check prop_maxView "maxView"+         check prop_foldr  "foldr"+         check prop_foldr' "foldr'"+         check prop_foldl  "foldl"+         check prop_foldl' "foldl'"+         check prop_map "map"+         check prop_mapMonotonic "mapMonotonic"+         check prop_filter "filter"+         check prop_partition "partition"+         check prop_split "split"+         check prop_splitMember "splitMember"+         check prop_containing "containing"+         check prop_intersecting "intersecting"+         check prop_within "within"+         check prop_readShow "read/show"+         exitSuccess