IntervalMap 0.4.1.1 → 0.5.0.0

raw patch · 22 files changed

+695/−130 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/IntervalMap/Generic/Base.hs +133/−26
• Data/IntervalMap/Generic/Lazy.hs +3/−0
• Data/IntervalMap/Generic/Strict.hs +4/−1
• Data/IntervalMap/Interval.hs +21/−1
• Data/IntervalMap/Lazy.hs +14/−1
• Data/IntervalMap/Strict.hs +14/−1
• Data/IntervalSet.hs +149/−34
• IntervalMap.cabal +11/−2
• README.md +5/−2
• bench/BenchAll.hs +6/−6
• bench/BenchIntervalSet.hs +127/−0
• bench/CompareRBImpl.hs +14/−9
• bench/CompareTypes.hs +1/−1
• bench/GenericLazyVsStrict.hs +6/−6
• bench/RBColorIntBase.hs +6/−6
• bench/RBColorNodeBase.hs +6/−6
• changelog +4/−0
• examples/Example.lhs +5/−4
• examples/GenericExample.lhs +5/−4
• test/IntervalMapTests.hs +77/−17
• test/IntervalSetTests.hs +51/−3
• test/IntervalTests.hs +33/−0

@@ -121,6 +121,9 @@             , foldl', foldr'             , foldrWithKey', foldlWithKey' +            -- * Flatten+            , flattenWith, flattenWithMonotonic+             -- * Conversion             , elems             , keys@@ -154,6 +157,8 @@              , split             , splitLookup+            , splitAt+            , splitIntersecting              -- * Submap             , isSubmapOf, isSubmapOfBy@@ -190,7 +195,7 @@              ) where -import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import Prelude hiding (null, lookup, map, filter, foldr, foldl, splitAt) import Data.Bits (shiftR, (.&.)) import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..), (<$>))@@ -374,45 +379,48 @@     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.+-- | Return the submap of key intervals containing the given point.+-- This is the second element of the value of 'splitAt': --+-- > m `containing` p == let (_,m',_) = m `splitAt` p in m'+-- -- /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+containing :: (Interval k e) => IntervalMap k v -> e -> IntervalMap k v+t `containing` pt = pt `seq` fromDistinctAscList (go [] pt t)   where-    go xs p Nil = p `seq` xs+    go xs _ Nil = 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.+-- | Return the submap of key intervals overlapping (intersecting) the given interval.+-- This is the second element of the value of 'splitIntersecting': --+-- > m `intersecting` i == let (_,m',_) = m `splitIntersecting` i in m'+-- -- /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+intersecting :: (Interval k e) => IntervalMap k v -> k -> IntervalMap k v+t `intersecting` iv = iv `seq` fromDistinctAscList (go [] iv t)   where-    go xs i Nil = i `seq` xs+    go xs _ Nil = 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.+-- | Return the submap of key intervals completely inside the given interval. -- -- /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+within :: (Interval k e) => IntervalMap k v -> k -> IntervalMap k v+t `within` iv = iv `seq` fromDistinctAscList (go [] iv t)   where-    go xs i Nil = i `seq` xs+    go xs _ Nil = xs     go xs i (Node _ k m v l r)        | i `after` m     =  xs        | i `before` k    =  go xs i l@@ -725,6 +733,25 @@                                 Nil -> z                                 Node _ k _ x l r -> foldlWithKey' f (f (foldlWithKey' f z l) k x) r +-- | /O(n log n)/. Build a new map by combining successive key/value pairs.+flattenWith :: (Ord k, Interval k e) => ((k,v) -> (k,v) -> Maybe (k,v)) -> IntervalMap k v -> IntervalMap k v+flattenWith combine m = fromList (combineSuccessive combine m)++-- | /O(n)/. Build a new map by combining successive key/value pairs.+-- Same as 'flattenWith', but works only when the combining functions returns+-- strictly monotonic key values.+flattenWithMonotonic :: (Interval k e) => ((k,v) -> (k,v) -> Maybe (k,v)) -> IntervalMap k v -> IntervalMap k v+flattenWithMonotonic combine m = fromDistinctAscList (combineSuccessive combine m)++combineSuccessive :: ((k,v) -> (k,v) -> Maybe (k,v)) -> IntervalMap k v -> [(k,v)]+combineSuccessive combine m = go (toAscList m)+  where+    go (x : xs@(y:ys)) = case combine x y of+                           Nothing -> x : go xs+                           Just x' -> go (x' : ys)+    go xs = xs++ -- delete  -- | /O(log n)/. Delete a key from the map. If the map does not contain the key,@@ -907,6 +934,9 @@ toAscList :: IntervalMap k v -> [(k,v)] toAscList m = foldrWithKey (\k v r -> (k,v) : r) [] m +toAscList' :: IntervalMap k v -> [(k,v)] -> [(k,v)]+toAscList' m xs = foldrWithKey (\k v r -> (k,v) : r) xs 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@@ -1156,6 +1186,74 @@                     (lt, ge@((k,v):gt)) | k == x    -> (fromDistinctAscList lt, Just v, fromDistinctAscList gt)                                         | otherwise -> (fromDistinctAscList lt, Nothing, fromDistinctAscList ge) ++-- | /O(n)/. Split around a point.+-- Splits the map into three submaps: intervals below the point,+-- intervals containing the point, and intervals above the point.+splitAt :: (Interval i k, Ord i) => IntervalMap i a -> k -> (IntervalMap i a, IntervalMap i a, IntervalMap i a)+splitAt mp p = (fromUnion (lower mp), mp `containing` p, fromUnion (higher mp))+  where+    lower Nil = UEmpty+    lower s@(Node _ k m v l r)+      | p `above`  m  =  UAppend s UEmpty+      | p `below`  k  =  lower l+      | p `inside` k  =  mkUnion (lower l) (lower r)+      | otherwise     =  mkUnion (lower l) (UCons k v (lower r))+    higher Nil = UEmpty+    higher (Node _ k m v l r)+      | p `above`  m  =  UEmpty+      | p `below`  k  =  mkUnion (higher l) (UCons k v (UAppend r UEmpty))+      | otherwise     =  higher r++-- | /O(n)/. Split around an interval.+-- Splits the set into three subsets: intervals below the given interval,+-- intervals intersecting the given interval, and intervals above the+-- given interval.+splitIntersecting :: (Interval i k, Ord i) => IntervalMap i a -> i -> (IntervalMap i a, IntervalMap i a, IntervalMap i a)+splitIntersecting mp i = (fromUnion (lower mp), mp `intersecting` i, fromUnion (higher mp))+  where+    lower Nil = UEmpty+    lower s@(Node _ k m v l r)+      -- whole set lower: all+      | i `after`  m   =  UAppend s UEmpty+      -- interval before key: only from left subtree+      | i <= k         =  lower l+      -- interval intersects key to the right: both subtrees could contain lower intervals+      | i `overlaps` k =  mkUnion (lower l) (lower r)+      -- interval to the right of the key: key and both subtrees+      | otherwise      =  mkUnion (lower l) (UCons k v (lower r))+    higher Nil = UEmpty+    higher (Node _ k m v l r)+      -- whole set lower: nothing+      | i `after` m    =  UEmpty+      -- interval before key: node and complete right subtree + maybe part of the left subtree+      | i `before`  k  =  mkUnion (higher l) (UCons k v (UAppend r UEmpty))+      -- interval overlaps or to the right of key: only from right subtree+      | otherwise      =  higher r+++-- Helper for building sets from distinct ascending keys and submaps+data Union k v = UEmpty | Union !(Union k v) !(Union k v)+               | UCons !k v !(Union k v)+               | UAppend !(IntervalMap k v) !(Union k v)++mkUnion :: Union k v -> Union k v -> Union k v+mkUnion UEmpty u = u+mkUnion u UEmpty = u+mkUnion u1 u2 = Union u1 u2++fromUnion :: Interval k e => Union k v -> IntervalMap k v+fromUnion UEmpty               = empty+fromUnion (UCons key v UEmpty) = singleton key v+fromUnion (UAppend mp UEmpty)  = turnBlack mp+fromUnion x                    = fromDistinctAscList (unfold x [])+  where+    unfold UEmpty        r = r+    unfold (Union a b)   r = unfold a (unfold b r)+    unfold (UCons k v u) r = (k,v) : unfold u r+    unfold (UAppend s u) r = toAscList' s (unfold u r)++ -- submaps  -- | /O(n+m)/. This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).@@ -1168,16 +1266,17 @@  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+isSubmapOfBy f m1 m2 = ascListSubset f (toAscList m1) (toAscList m2) +ascListSubset :: Ord k => (a -> b -> Bool) -> [(k,a)] -> [(k,b)] -> Bool+ascListSubset _ []    _  =  True+ascListSubset _ (_:_) [] =  False+ascListSubset f s1@((k1,v1):r1) ((k2,v2):r2) =+  case compare k1 k2 of+    GT -> ascListSubset f s1 r2+    EQ -> f v1 v2 && ascListSubset f 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@@ -1190,7 +1289,15 @@  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+isProperSubmapOfBy 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 -> ascListSubset f s1 r2+         EQ -> f v1 v2 && go r1 r2+         LT -> False   -- debugging

@@ -88,6 +88,7 @@             -- ** Fold             , M.foldr, M.foldl             , foldrWithKey, foldlWithKey+            , flattenWith, flattenWithMonotonic              -- * Conversion             , elems@@ -122,6 +123,8 @@              , split             , splitLookup+            , M.splitAt+            , splitIntersecting              -- * Submap             , isSubmapOf, isSubmapOfBy

@@ -123,6 +123,7 @@             -- ** Fold             , foldr, foldl             , foldrWithKey, foldlWithKey+            , flattenWith, flattenWithMonotonic              -- * Conversion             , elems@@ -157,6 +158,8 @@              , split             , splitLookup+            , splitAt+            , splitIntersecting              -- * Submap             , isSubmapOf, isSubmapOfBy@@ -187,7 +190,7 @@              ) where -import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import Prelude hiding (null, lookup, map, filter, foldr, foldl, splitAt) import qualified Data.List as L import Data.IntervalMap.Generic.Base as M hiding (       singleton

@@ -22,12 +22,13 @@     lowerBound, upperBound, leftClosed, rightClosed, isEmpty,     -- * Interval operations     overlaps, subsumes, before, after,-    compareByUpper,+    compareByUpper, combine,     -- * Point operations     below, inside, above   ) where  import Control.DeepSeq (NFData(rnf))+import Data.List (maximumBy)  -- | Intervals with endpoints of type @a@. --@@ -257,3 +258,22 @@ p `above` (ClosedInterval _ u)  =  p >  u p `above` (OpenInterval   _ u)  =  p >= u p `above` (IntervalOC     _ u)  =  p >  u++-- | If the intervals overlap combine them into one.+combine :: (Ord a) => Interval a -> Interval a -> Maybe (Interval a)+combine a b =+  if a `overlaps` b+    then let lowerBoundInterval = min a b+             upperBoundInterval = maximumBy compareByUpper [a, b]+             newLowerBound = lowerBound lowerBoundInterval+             newUpperBound = upperBound upperBoundInterval+             interval =+               if leftClosed lowerBoundInterval+                 then if rightClosed upperBoundInterval+                        then ClosedInterval newLowerBound newUpperBound+                        else IntervalCO     newLowerBound newUpperBound+                 else if rightClosed upperBoundInterval+                        then IntervalOC     newLowerBound newUpperBound+                        else OpenInterval   newLowerBound newUpperBound+         in Just interval+    else Nothing

@@ -89,6 +89,9 @@             , M.foldr, M.foldl             , foldrWithKey, foldlWithKey +            -- * Flatten+            , flattenWith+             -- * Conversion             , elems             , keys@@ -122,6 +125,8 @@              , split             , splitLookup+            , M.splitAt+            , splitIntersecting              -- * Submap             , isSubmapOf, isSubmapOfBy@@ -153,8 +158,16 @@             ) where  import Data.IntervalMap.Interval as I-import Data.IntervalMap.Generic.Lazy hiding (IntervalMap, null, filter, lookup, map, foldr, foldl)+import Data.IntervalMap.Generic.Lazy hiding (IntervalMap, null, filter, lookup, map, foldr, foldl, flattenWith) import qualified Data.IntervalMap.Generic.Lazy as M   type IntervalMap k v = M.IntervalMap (I.Interval k) v++-- | /O(n)/. The list of all key\/value pairs contained in the map, in descending order of keys.+flattenWith :: (Ord k) => (v -> v -> v) -> IntervalMap k v -> IntervalMap k v+flattenWith f m = M.flattenWithMonotonic f' m+  where+    f' (k1,v1) (k2,v2) = case combine k1 k2 of+                           Nothing -> Nothing+                           Just k' -> Just (k', f v1 v2)

@@ -133,6 +133,9 @@             , foldr, foldl             , foldrWithKey, foldlWithKey +            -- * Flatten+            , flattenWith+             -- * Conversion             , elems             , keys@@ -166,6 +169,8 @@              , split             , splitLookup+            , M.splitAt+            , splitIntersecting              -- * Submap             , isSubmapOf, isSubmapOfBy@@ -198,8 +203,16 @@   import Data.IntervalMap.Interval as I-import Data.IntervalMap.Generic.Strict hiding (IntervalMap, null, filter, lookup, map, foldr, foldl)+import Data.IntervalMap.Generic.Strict hiding (IntervalMap, null, filter, lookup, map, foldr, foldl, flattenWith) import qualified Data.IntervalMap.Generic.Strict as M   type IntervalMap k v = M.IntervalMap (I.Interval k) v++-- | /O(n)/. Combine overlapping intervals.+flattenWith :: (Ord k) => (v -> v -> v) -> IntervalMap k v -> IntervalMap k v+flattenWith f m = M.flattenWithMonotonic f' m+  where+    f' (k1,v1) (k2,v2) = case combine k1 k2 of+                           Nothing -> Nothing+                           Just k' -> let v' = f v1 v2 in v' `seq` Just (k', v')

@@ -85,6 +85,9 @@             , foldr, foldl             , foldl', foldr' +            -- * Flatten+            , flattenWith, flattenWithMonotonic+             -- * Conversion             , elems @@ -104,6 +107,8 @@              , split             , splitMember+            , splitAt+            , splitIntersecting              -- * Subset             , isSubsetOf, isProperSubsetOf@@ -124,7 +129,7 @@              ) where -import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import Prelude hiding (null, lookup, map, filter, foldr, foldl, splitAt) import Data.Bits (shiftR, (.&.)) import Data.Monoid (Monoid(..)) import qualified Data.Foldable as Foldable@@ -144,6 +149,7 @@ m1 \\ m2 = difference m1 m2  +-- | The Color of a tree node. data Color = R | B deriving (Eq)  -- | A set of intervals of type @k@.@@ -257,46 +263,52 @@ notMember key tree = not (member key tree)  -- | Return the set of all intervals containing the given point.+-- This is the second element of the value of 'splitAt': --+-- > set `containing` p == let (_,s,_) = set `splitAt` p in s+-- -- /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)+t `containing` p = p `seq` fromDistinctAscList (go [] t)   where-    go xs p Nil = p `seq` xs-    go xs p (Node _ k m l r)+    go xs Nil = xs+    go xs (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+       | p `below` k  =  go xs l    -- to the left of the lower bound: can't be in right subtree+       | p `inside` k =  go (k : go xs r) l+       | otherwise    =  go (go xs r) l  -- | Return the set of all intervals overlapping (intersecting) the given interval.+-- This is the second element of the result of 'splitIntersecting': --+-- > set `intersecting` i == let (_,s,_) = set `splitIntersecting` i in s+-- -- /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)+t `intersecting` i = i `seq` fromDistinctAscList (go [] t)   where-    go xs i Nil = i `seq` xs-    go xs i (Node _ k m l r)+    go xs Nil = xs+    go xs (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+       | i `before` k    =  go xs l+       | i `overlaps` k  =  go (k : go xs r) l+       | otherwise       =  go (go xs r) 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)+t `within` i = i `seq` fromDistinctAscList (go [] t)   where-    go xs i Nil = i `seq` xs-    go xs i (Node _ k m l r)+    go xs Nil = xs+    go xs (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+       | i `before` k    =  go xs l+       | i `subsumes` k  =  go (k : go xs r) l+       | otherwise       =  go (go xs r) l   -- | /O(log n)/. Insert a new value. If the set already contains an element equal to the value,@@ -329,13 +341,13 @@  -- min/max --- | /O(log n)/. Returns the least interval in the set.+-- | /O(log n)/. Returns the minimal value 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.+-- | /O(log n)/. Returns the maximal value in the set. findMax :: IntervalSet k -> Maybe k findMax (Node _ k _ _ Nil) = Just k findMax (Node _ _ _ _ r) = findMax r@@ -351,13 +363,13 @@ 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+    go (Node _ k m l r) | sameU m mx = if sameU k m then go r `orElse` Just k+                                                    else go r `orElse` 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+    Nothing `orElse` x = x+    x       `orElse` _ = x   -- Type to indicate whether the number of black nodes changed or stayed the same.@@ -574,6 +586,11 @@ toAscList :: IntervalSet k -> [k] toAscList m = foldr (\k r -> k : r) [] m +toAscList' :: IntervalSet k -> [k] -> [k]+toAscList' m xs = foldr (\k r -> k : r) xs m+++ -- | /O(n)/. The list of all values in the set, in no particular order. toList :: IntervalSet k -> [k] toList s = go s []@@ -703,26 +720,124 @@                     (lt, ge@(y:gt)) | y == x    -> (fromDistinctAscList lt, True, fromDistinctAscList gt)                                     | otherwise -> (fromDistinctAscList lt, False, fromDistinctAscList ge) +-- Helper for building sets from distinct ascending values and subsets+data Union k = UEmpty | Union !(Union k) !(Union k)+             | UCons !k !(Union k)+             | UAppend !(IntervalSet k) !(Union k)++mkUnion :: Union a -> Union a -> Union a+mkUnion UEmpty u = u+mkUnion u UEmpty = u+mkUnion u1 u2 = Union u1 u2++fromUnion :: Interval k e => Union k -> IntervalSet k+fromUnion UEmpty               = empty+fromUnion (UCons key UEmpty)   = singleton key+fromUnion (UAppend set UEmpty) = turnBlack set+fromUnion x                    = fromDistinctAscList (unfold x [])+  where+    unfold UEmpty        r = r+    unfold (Union a b)   r = unfold a (unfold b r)+    unfold (UCons k u)   r = k : unfold u r+    unfold (UAppend s u) r = toAscList' s (unfold u r)+++-- | /O(n)/. Split around a point.+-- Splits the set into three subsets: intervals below the point,+-- intervals containing the point, and intervals above the point.+splitAt :: (Interval i k, Ord i) => IntervalSet i -> k -> (IntervalSet i, IntervalSet i, IntervalSet i)+splitAt set p = (fromUnion (lower set), set `containing` p, fromUnion (higher set))+  where+    lower Nil = UEmpty+    lower s@(Node _ k m l r)+      | p `above`  m  =  UAppend s UEmpty+      | p `below`  k  =  lower l+      | p `inside` k  =  mkUnion (lower l) (lower r)+      | otherwise     =  mkUnion (lower l) (UCons k (lower r))+    higher Nil = UEmpty+    higher (Node _ k m l r)+      | p `above`  m  =  UEmpty+      | p `below`  k  =  mkUnion (higher l) (UCons k (UAppend r UEmpty))+      | otherwise     =  higher r++-- | /O(n)/. Split around an interval.+-- Splits the set into three subsets: intervals below the given interval,+-- intervals intersecting the given interval, and intervals above the+-- given interval.+splitIntersecting :: (Interval i k, Ord i) => IntervalSet i -> i -> (IntervalSet i, IntervalSet i, IntervalSet i)+splitIntersecting set i = (fromUnion (lower set), set `intersecting` i, fromUnion (higher set))+  where+    lower Nil = UEmpty+    lower s@(Node _ k m l r)+      -- whole set lower: all+      | i `after`  m   =  UAppend s UEmpty+      -- interval before key: only from left subtree+      | i <= k         =  lower l+      -- interval intersects key to the right: both subtrees could contain lower intervals+      | i `overlaps` k =  mkUnion (lower l) (lower r)+      -- interval to the right of the key: key and both subtrees+      | otherwise      =  mkUnion (lower l) (UCons k (lower r))+    higher Nil = UEmpty+    higher (Node _ k m l r)+      -- whole set lower: nothing+      | i `after` m    =  UEmpty+      -- interval before key: node and complete right subtree + maybe part of the left subtree+      | i `before`  k  =  mkUnion (higher l) (UCons k (UAppend r UEmpty))+      -- interval overlaps or to the right of key: only from right subtree+      | otherwise      =  higher r++ -- subsets --- | /O(n+m)/.+-- | /O(n+m)/. Is the first set a subset of the second set?+-- This is always true for equal sets. isSubsetOf :: (Ord k) => IntervalSet k -> IntervalSet k -> Bool-isSubsetOf m1 m2 = go (toAscList m1) (toAscList m2)+isSubsetOf set1 set2 = ascListSubset (toAscList set1) (toAscList set2)++ascListSubset :: (Ord a) => [a] -> [a] -> Bool+ascListSubset []    _  =  True+ascListSubset (_:_) [] =  False+ascListSubset s1@(k1:r1) (k2:r2) =+  case compare k1 k2 of+    GT -> ascListSubset s1 r2+    EQ -> ascListSubset r1 r2+    LT -> False++-- | /O(n+m)/. Is the first set a proper subset of the second set?+-- (i.e. a subset but not equal).+isProperSubsetOf :: (Ord k) => IntervalSet k -> IntervalSet k -> Bool+isProperSubsetOf set1 set2 = go (toAscList set1) (toAscList set2)   where-    go []    _  =  True-    go (_:_) [] =  False+    go [] (_:_) = True+    go _  []    = False     go s1@(k1:r1) (k2:r2) =        case compare k1 k2 of-         GT -> go s1 r2+         GT -> ascListSubset 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+-- | /O(n log n)/. Build a new set by combining successive values.+flattenWith :: (Ord a, Interval a e) => (a -> a -> Maybe a) -> IntervalSet a -> IntervalSet a+flattenWith combine set = fromList (combineSuccessive combine set) --- debugging+-- | /O(n)/. Build a new set by combining successive values.+-- Same as 'flattenWith', but works only when the combining functions returns+-- strictly monotonic values.+flattenWithMonotonic :: (Interval a e) => (a -> a -> Maybe a) -> IntervalSet a -> IntervalSet a+flattenWithMonotonic combine set = fromDistinctAscList (combineSuccessive combine set) +combineSuccessive :: (a -> a -> Maybe a) -> IntervalSet a -> [a]+combineSuccessive combine set = go (toAscList set)+  where+    go (x : xs@(_:_)) = go1 x xs+    go xs             = xs+    go1 x (y:ys) = case combine x y of+                     Nothing -> x : go1 y ys+                     Just x' -> go1 x' ys+    go1 x []     = [x]+++-- debugging  -- | The height of the tree. For testing/debugging only. height :: IntervalSet k -> Int

@@ -1,7 +1,7 @@ Name:                IntervalMap-Version:             0.4.1.1+Version:             0.5.0.0 Stability:           experimental-Synopsis:            Maps from Intervals to values, with efficient search.+Synopsis:            Containers for intervals, with efficient search. Homepage:            http://www.chr-breitkopf.de/comp/IntervalMap License:             BSD3 License-file:        LICENSE@@ -100,6 +100,15 @@   type:               exitcode-stdio-1.0   hs-source-dirs:     . bench   main-is:            GenericLazyVsStrict.hs+  Build-depends:      base >= 4 && < 5,+                      containers, random, deepseq,+                      criterion >= 1.0+  ghc-options: -Wall -with-rtsopts=-K1K++benchmark bench-set+  type:               exitcode-stdio-1.0+  hs-source-dirs:     . bench+  main-is:            BenchIntervalSet.hs   Build-depends:      base >= 4 && < 5,                       containers, random, deepseq,                       criterion >= 1.0

@@ -1,9 +1,12 @@ # IntervalMap [![Build Status](https://travis-ci.org/bokesan/IntervalMap.svg?branch=master)](https://travis-ci.org/bokesan/IntervalMap) -Containers for intervals offering efficient search.+*@GitHub users:* please base pull requests on the *develop* branch. Thanks. -Home page and documentation: [http://www.chr-breitkopf.de/comp/IntervalMap/index.html](http://www.chr-breitkopf.de/comp/IntervalMap/index.html)+Containers for intervals. Like `Data.Set` and `Data.Map` with+Intervals as keys and functions for efficiently getting the subset+of all intervals containing a point, intersecting an interval, and more. +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. 

@@ -85,13 +85,13 @@          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 "containing"      $ nf (\m -> sum [v | p <- rndInts, v <- M.elems (m `M.containing` p)]) dIvMap,+           bench "intersecting"    $ nf (\m -> sum [v | p <- rndInts, v <- M.elems (m `M.intersecting` (ClosedInterval p (p+15)))]) dIvMap,+           bench "within" $ nf (\m -> sum [v | p <- rndInts, v <- M.elems (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+           bench "G containing"      $ nf (\m -> sum [v | p <- rndInts, v <- G.elems (m `G.containing` p)]) gIvMap,+           bench "G intersecting"    $ nf (\m -> sum [v | p <- rndInts, v <- G.elems (m `G.intersecting` (p, p+15))]) gIvMap,+           bench "G within" $ nf (\m -> sum [v | p <- rndInts, v <- G.elems (m `G.within` (p, p+15))]) gIvMap          ],          bgroup "mapKeys" [            bench "Data.Map"              $ nf (D.mapKeys (move 1)) dMap,

@@ -0,0 +1,127 @@+{-# 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, foldl')++import Data.IntervalMap.Generic.Interval+import qualified Data.IntervalSet 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-set.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 50 cDATA_SIZE+      ivsP   <- ensure $ [IV lo hi | (lo,hi) <- ivs]+      oIvsP  <- ensure $ sort ivsP+      let lookupKeys = ivsP+      set <- ensure $ S.fromList ivsP+      rndInts <- ensure (genRandomInts 1 cDATA_SIZE cDATA_SIZE)+      rndInts2 <- ensure (take (2 * log2 cDATA_SIZE) rndInts)+      rndIvs <- ensure [IV (p - 500) (p + 500) | p <- rndInts2]+      defaultMainWith benchConfig [+         bgroup "fromList" [+           bench "fromList"     $ nf S.fromList ivsP,+           bench "fromAscList"  $ nf S.fromAscList oIvsP+         ],+         bench "size"           $ whnf S.size set,+         bench "member"         $ whnf (\s -> sum [bval (S.member i s) | i <- lookupKeys]) set,+         bgroup "points" [+           bench "containing"   $ whnf (\s -> sum [maxValue (S.containing s p) | p <- rndInts]) set,+           bench "splitAt lo"   $ whnf (\s -> sum [maxValue (splitAt1 s p) | p <- rndInts2]) set,+           bench "splitAt c"    $ whnf (\s -> sum [maxValue (splitAt2 s p) | p <- rndInts]) set,+           bench "splitAt hi"   $ whnf (\s -> sum [minValue (splitAt3 s p) | p <- rndInts2]) set+         ],+         bgroup "intervals" [+           bench "intersecting" $ whnf (\s -> sum [maxValue (s `S.intersecting` i) | i <- rndIvs]) set,+           bench "within"       $ whnf (\s -> sum [maxValue (s `S.within`       i) | i <- rndIvs]) set,+           bench "spi1"         $ whnf (\s -> sum [maxValue (spi1 s i) | i <- rndIvs]) set,+           bench "spi2"         $ whnf (\s -> sum [maxValue (spi2 s i) | i <- rndIvs]) set,+           bench "spi3"         $ whnf (\s -> sum [maxValue (spi3 s i) | i <- rndIvs]) set+         ],+         bgroup "mapKeys" [+           bench "mapKeys"      $ nf (S.map (move 1)) set,+           bench "monotonic"    $ nf (S.mapMonotonic (move 1)) set+         ]+       ]+++log2 :: Int -> Int+log2 m = h (-1) m+  where+    h r n | r `seq` n <= 0 = r+          | otherwise      = h (r + 1) (n `quot` 2)++bval :: Bool -> Int+bval False = 0+bval True  = 1++minValue :: S.IntervalSet IV -> Int+minValue s = case S.findMin s of+               Nothing -> 0+               Just (IV lo _) -> lo++maxValue :: S.IntervalSet IV -> Int+maxValue s = case S.findMax s of+               Nothing -> 0+               Just (IV lo _) -> lo+             +splitAt1, splitAt2, splitAt3 :: (Interval i e, Ord i) => S.IntervalSet i -> e -> S.IntervalSet i+splitAt1 s p = case S.splitAt s p of (lo,_,_) -> lo+splitAt2 s p = case S.splitAt s p of (_,c,_) -> c+splitAt3 s p = case S.splitAt s p of (_,_,hi) -> hi++spi1, spi2, spi3 :: (Interval i e, Ord i) => S.IntervalSet i -> i -> S.IntervalSet i+spi1 s i = case S.splitIntersecting s i of (x,_,_) -> x+spi2 s i = case S.splitIntersecting s i of (_,x,_) -> x+spi3 s i = case S.splitIntersecting s i of (_,_,x) -> x

@@ -75,24 +75,29 @@            bench "int"     $ nf L.fromAscList oIvsP,            bench "node"    $ nf N.fromAscList oIvsP          ],+         bgroup "size" [+           bench "reg"    $ nf S.size sMap,+           bench "int"    $ nf L.size lMap,+           bench "node"   $ nf N.size nMap+         ],          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+           bench "reg"    $ nf (\m -> sum [v | p <- rndInts, v <- S.elems (m `S.containing` p)]) sMap,+           bench "int"    $ nf (\m -> sum [v | p <- rndInts, v <- L.elems (m `L.containing` p)]) lMap,+           bench "node"   $ nf (\m -> sum [v | p <- rndInts, v <- N.elems (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+           bench "reg"    $ nf (\m -> sum [v | p <- rndInts, v <- S.elems (m `S.intersecting` (IV p (p+15)))]) sMap,+           bench "int"    $ nf (\m -> sum [v | p <- rndInts, v <- L.elems (m `L.intersecting` (IV p (p+15)))]) lMap,+           bench "node"   $ nf (\m -> sum [v | p <- rndInts, v <- N.elems (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+           bench "reg"    $ nf (\m -> sum [v | p <- rndInts, v <- S.elems (m `S.within` (IV p (p+15)))]) sMap,+           bench "int"    $ nf (\m -> sum [v | p <- rndInts, v <- L.elems (m `L.within` (IV p (p+15)))]) lMap,+           bench "node"   $ nf (\m -> sum [v | p <- rndInts, v <- N.elems (m `N.within` (IV p (p+15)))]) nMap          ]        ]

@@ -131,7 +131,7 @@ 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+benchRB = benchIV "RedBlackTree" RB.insert RB.lookup (\m p -> RB.toAscList (RB.containing m p))  benchFT :: ([FT.Interval Int], FT.IntervalMap Int Int) -> Benchmark benchFT ~(keys,m) = bgroup "FingerTree" [

@@ -81,12 +81,12 @@          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+           bench "containing lazy"      $ nf (\m -> sum [v | p <- rndInts, v <- L.elems (m `L.containing` p)]) lMap,+           bench "containing strict"      $ nf (\m -> sum [v | p <- rndInts, v <- S.elems (m `S.containing` p)]) sMap,+           bench "intersecting lazy"    $ nf (\m -> sum [v | p <- rndInts, v <- L.elems (m `L.intersecting` (IV p (p+15)))]) lMap,+           bench "intersecting strict"    $ nf (\m -> sum [v | p <- rndInts, v <- S.elems (m `S.intersecting` (IV p (p+15)))]) sMap,+           bench "within lazy" $ nf (\m -> sum [v | p <- rndInts, v <- L.elems (m `L.within` (IV p (p+15)))]) lMap,+           bench "within strict" $ nf (\m -> sum [v | p <- rndInts, v <- S.elems (m `S.within` (IV p (p+15)))]) sMap          ],          bgroup "mapKeys" [            bench "lazy"             $ nf (L.mapKeys (move 1)) lMap,

@@ -242,8 +242,8 @@ -- -- /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+containing :: (Interval k e) => IntervalMap k v -> e -> IntervalMap k v+t `containing` pt = fromDistinctAscList (go [] pt t)   where     go xs p Nil = p `seq` xs     go xs p (Node _ k m v l r)@@ -257,8 +257,8 @@ -- -- /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+intersecting :: (Interval k e) => IntervalMap k v -> k -> IntervalMap k v +t `intersecting` iv = fromDistinctAscList (go [] iv t)   where     go xs i Nil = i `seq` xs     go xs i (Node _ k m v l r)@@ -272,8 +272,8 @@ -- -- /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+within :: (Interval k e) => IntervalMap k v -> k -> IntervalMap k v+t `within` iv = fromDistinctAscList (go [] iv t)   where     go xs i Nil = i `seq` xs     go xs i (Node _ k m v l r)

@@ -250,8 +250,8 @@ -- -- /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+containing :: (Interval k e) => IntervalMap k v -> e -> IntervalMap k v+t `containing` pt = fromDistinctAscList (go [] pt t)   where     go xs p Nil = p `seq` xs     go xs p (NodeR k m v l r)@@ -270,8 +270,8 @@ -- -- /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+intersecting :: (Interval k e) => IntervalMap k v -> k -> IntervalMap k v+t `intersecting` iv = fromDistinctAscList (go [] iv t)   where     go xs i Nil = i `seq` xs     go xs i (NodeR k m v l r)@@ -290,8 +290,8 @@ -- -- /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+within :: (Interval k e) => IntervalMap k v -> k -> IntervalMap k v+t `within` iv = fromDistinctAscList (go [] iv t)   where     go xs i Nil = i `seq` xs     go xs i (NodeR k m v l r)

@@ -1,3 +1,7 @@+0.5.0.0  Change return type of containing, ... to a map.+         Add splitAt, splitIntersecting, flatten... functions.+         Minor performance tweaks.+ 0.4.1.1  Fix bug in benchmark.  0.4.1.0  Add IntervalSet.

@@ -60,16 +60,17 @@  > appointmentsAt :: Time -> Appointments -> [Appointment] > appointmentsAt t apps = [ (time, person, details)->                           | (time, pds) <- apps `containing` t,+>                           | (time, pds) <- toAscList (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 ]+> appointmentsDuring from to apps =+>     [ (time, person, details)+>       | (time, pds) <- toAscList (apps `intersecting` mkTimeSpan from to),+>         (person, details) <- pds ]  Here is a sample set of appointments and a main function to show some test results: 

@@ -70,16 +70,17 @@  > appointmentsAt :: Time -> Appointments -> [Appointment] > appointmentsAt t apps = [ (time, person, details)->                           | (time, pds) <- apps `containing` t,+>                           | (time, pds) <- toAscList (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 ]+> appointmentsDuring from to apps =+>     [ (time, person, details)+>       | (time, pds) <- toAscList (apps `intersecting` mkTimeSpan from to),+>         (person, details) <- pds ]  Here is a sample set of appointments and a main function to show some test results: 

@@ -46,7 +46,7 @@   Just "single46" == M.lookup (ClosedInterval 4 6) single46 &&   "single46" == single46 M.! ClosedInterval 4 6 &&   Nothing == M.lookup (OpenInterval 4 6) single46 &&-  [(ClosedInterval 4 6, "single46")] == single46 `containing` 5+  single46 == single46 `containing` 5   bal3 :: M.IntervalMap Int String@@ -66,17 +66,17 @@   "o58" == bal3' M.! OpenInterval 5 8 &&   Nothing == M.lookup (OpenInterval 5 8) bal3 &&   Just "o58" == M.lookup (OpenInterval 5 8) bal3' &&-  [] == bal3 `containing` 0 &&-  [] == bal3 `containing` 9 &&-  [(ClosedInterval 1 4, "14")] == bal3 `containing` 1 &&-  [(ClosedInterval 5 8, "58")] == bal3 `containing` 8 &&-  [] == bal3' `containing` 8 &&-  [(OpenInterval 5 8, "o58")] == bal3' `containing` 7 &&-  sameElements ["14", "single46"] [v|(_,v) <- bal3 `containing` 4] &&-  sameElements ["58", "single46"] [v|(_,v) <- bal3 `containing` 5] &&-  sameElements ["58", "single46"] [v|(_,v) <- bal3 `containing` 6] &&-  sameElements ["single46"] [v|(_,v) <- bal3' `containing` 5] &&-  sameElements ["o58", "single46"] [v|(_,v) <- bal3' `containing` 6]+  M.null (bal3 `containing` 0) &&+  M.null (bal3 `containing` 9) &&+  [(ClosedInterval 1 4, "14")] == toAscList (bal3 `containing` 1) &&+  [(ClosedInterval 5 8, "58")] == toAscList (bal3 `containing` 8) &&+  M.null (bal3' `containing` 8) &&+  [(OpenInterval 5 8, "o58")] == toAscList (bal3' `containing` 7) &&+  sameElements ["14", "single46"] [v|(_,v) <- toAscList (bal3 `containing` 4)] &&+  sameElements ["58", "single46"] [v|(_,v) <- toAscList (bal3 `containing` 5)] &&+  sameElements ["58", "single46"] [v|(_,v) <- toAscList (bal3 `containing` 6)] &&+  sameElements ["single46"] [v|(_,v) <- toAscList (bal3' `containing` 5)] &&+  sameElements ["o58", "single46"] [v|(_,v) <- toAscList (bal3' `containing` 6)]   deep100L :: M.IntervalMap Int Int@@ -92,11 +92,11 @@  prop_tests3 =    68 == deep100L M.! (ClosedInterval 68 68) &&-   [17] == Prelude.map snd (deep100L `containing` 17) &&+   [17] == Prelude.map snd (toAscList (deep100L `containing` 17)) &&    100 == M.size deep100L &&    (M.height deep100L <= 12) &&    68 == deep100R M.! (ClosedInterval 68 68) &&-   [17] == Prelude.map snd (deep100R `containing` 17) &&+   [17] == Prelude.map snd (toAscList (deep100R `containing` 17)) &&    100 == M.size deep100R &&    (M.height deep100R <= 12) &&    M.valid deep100L &&@@ -153,6 +153,22 @@                                       in notMember k m' && M.size m == M.size m' + 1                                          && k == maximum (M.keys m) && valid m' +prop_minViewWithKey (IMI m) = case minViewWithKey m of+                                Nothing -> M.null m+                                Just (kv, m') -> kv == findMin m && valid m' && m' == deleteMin m++prop_maxViewWithKey (IMI m) = case maxViewWithKey m of+                                Nothing -> M.null m+                                Just (kv, m') -> kv == findMax m && valid m' && m' == deleteMax m++prop_minView (IMI m) = case minView m of+                         Nothing -> M.null m+                         Just (v, m') -> v == snd (findMin m) && valid m' && m' == deleteMin m++prop_maxView (IMI m) = case maxView m of+                         Nothing -> M.null m+                         Just (v, m') -> v == snd (findMax m) && valid m' && m' == deleteMax m+ prop_updateMin_u (IMI m) =    let m' = M.updateMin (\v -> Just (v+1)) m in    if M.null m then@@ -206,13 +222,13 @@  prop_findWithDefault (IMI m) (II k) = M.findWithDefault (lowerBound k) k m == lowerBound k -prop_searchPoint (IMI m) p = sameElements (m `containing` p)+prop_searchPoint (IMI m) p = sameElements (toList (m `containing` p))                                           [e | e@(k,_) <- M.toList m, p `inside` k] -prop_searchInterval (IMI m) (II i) = sameElements (m `intersecting` i)+prop_searchInterval (IMI m) (II i) = sameElements (toList (m `intersecting` i))                                                   [e | e@(k,_) <- M.toList m, k `overlaps` i] -prop_within (IMI m) (II i) = sameElements (m `M.within` i)+prop_within (IMI m) (II i) = sameElements (toList (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)@@ -371,7 +387,13 @@   | otherwise            = M.size m1 > M.size m2                            || any (==True) [k `M.notMember` m2 || m1 M.! k /= m2 M.! k | k <- M.keys m1] +prop_properSubmap (IMI m1) (IMI m2)+  | m1 `M.isProperSubmapOf` m2 = M.size m1 < M.size m2+                                 && all (==True) [k `M.member` m2 && m1 M.! k == m2 M.! k | k <- M.keys m1]+  | otherwise                  = M.size m1 >= M.size m2+                                 || any (==True) [k `M.notMember` m2 || m1 M.! k /= m2 M.! k | k <- M.keys m1] + -- filter  prop_filter (IMI m) =  M.valid m' && all odd (M.elems m') && M.size m' == odds@@ -392,9 +414,39 @@   where     (l, value, r) = splitLookup x m +prop_splitAt p (IMI m) =          let (lo,c,hi) = M.splitAt m p in+                                  M.valid lo && M.valid c && M.valid hi &&+                                  lo == mfilter (p `above`) m &&+                                  c  == mfilter (p `inside`) m &&+                                  hi == mfilter (p `below`) m &&+                                  M.unions [lo,c,hi] == m &&+                                  M.size lo + M.size c + M.size hi == M.size m++prop_splitIntersecting (II i) (IMI m) =+                                  let (lo,c,hi) = M.splitIntersecting m i in+                                  M.valid lo && M.valid c && M.valid hi &&+                                  lo == mfilter (i `after`) m &&+                                  c  == mfilter (i `overlaps`) m &&+                                  hi == mfilter (i `before`) m &&+                                  M.unions [lo,c,hi] == m &&+                                  M.size lo + M.size c + M.size hi == M.size m++mfilter :: (Ord k) => (Interval k -> Bool) -> IntervalMap k a -> IntervalMap k a+mfilter p m = M.filterWithKey (\k _ -> p k) m+     prop_readShow (IMI m) = m == read (show m) +prop_flatten (IMI m) = let m' = M.flattenWith (+) m in+                       M.valid m' &&+                       sum (M.elems m) == sum (M.elems m') &&+                       nonOverlapping (M.keys m') +nonOverlapping :: [Interval Int] -> Bool+nonOverlapping (x:y:xs) | x `overlaps` y = False+                        | otherwise      = nonOverlapping (y:xs)+nonOverlapping _ = True++ checkElems :: Int -> Int -> [(Interval Int, Int)] -> Bool checkElems n len lyst = h n (n + len) lyst   where@@ -430,6 +482,10 @@           check prop_findMin "findMin"           check prop_findMax "findMax"           check prop_findLast "findLast"+          check prop_minViewWithKey "minViewWithKey"+          check prop_maxViewWithKey "maxViewWithKey"+          check prop_minView "minView"+          check prop_maxView "maxView"           check prop_updateMin_u "updateMin update"           check prop_updateMin_d "updateMin delete"           check prop_updateMax_u "updateMax update"@@ -453,8 +509,12 @@           check prop_filter "filter"           check prop_partition "partition"           check prop_splitLookup "splitLookup"+          check prop_splitAt "splitAt"+          check prop_splitIntersecting "splitIntersecting"           check prop_mapKeysWith "mapKeysWith"           check prop_submap "submap"+          check prop_properSubmap "proper submap"+          check prop_flatten "flattenWith"           check prop_readShow "read/show"           putStrLn ("deep100L: " ++ show (M.showStats deep100L))           putStrLn ("deep100R: " ++ show (M.showStats deep100R))

@@ -8,7 +8,7 @@ import Test.QuickCheck hiding (within) import Test.QuickCheck.Test (isSuccess) import Control.Monad (liftM)-import Prelude hiding (null, map, filter, foldr, foldl)+import Prelude hiding (null, map, filter, foldr, foldl, splitAt) import qualified Data.List as L  import Data.IntervalSet@@ -26,6 +26,10 @@    lowerBound (II a _) = a    upperBound (II _ b) = b +combine :: II -> II -> Maybe II+combine i1@(II a b) i2@(II c d) | i1 `overlaps` i2 = Just (II (min a c) (max b d))+                                | otherwise = Nothing+ instance Arbitrary II where   arbitrary = do x <- arbitrary                  iv <- interval (abs x)@@ -85,15 +89,16 @@                                        prop_intersection (IS s1) (IS s2) =                                   let i = intersection s1 s2 in+                                  valid i &&                                   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')+                                    Just (min, s') -> valid s' && all (min <) (toList s')                                    prop_maxView (IS s) =             case maxView s of                                     Nothing -> null s-                                    Just (max, s') -> all (max >) (toList s')+                                    Just (max, s') -> valid s' && all (max >) (toList s')                                      prop_findMin (IS s) =             case findMin s of                                     Nothing  -> null s@@ -109,11 +114,13 @@                                       all (\e -> upperBound e < end || (upperBound e == end && e <= x)) (toList s)                                                        prop_deleteMin (IS s) =           let s' = deleteMin s in+                                  valid s' &&                                   case findMin s of                                     Nothing  -> null s'                                     Just min -> s' == delete min s  prop_deleteMax (IS s) =           let s' = deleteMax s in+                                  valid s' &&                                   case findMax s of                                     Nothing  -> null s'                                     Just max -> s' == delete max s@@ -141,19 +148,39 @@                                   all (> iv) (toList hi) &&                                   union lo hi == if m then delete iv s else s +prop_splitAt1 p (IS s) =          let (lo,_,_) = splitAt s p in+                                  valid lo && lo == filter (p `above`) s++prop_splitAt2 p (IS s) =          let (_,c,_) = splitAt s p in+                                  valid c && c == filter (p `inside`) s++prop_splitAt3 p (IS s) =          let (_,_,hi) = splitAt s p in+                                  valid hi && hi == filter (p `below`) s++prop_splitIntersecting i (IS s) = let (lo,c,hi) = splitIntersecting s i in+                                  valid lo && valid c && valid hi &&+                                  lo == filter (i `after`) s &&+                                  c  == filter (i `overlaps`) s &&+                                  hi == filter (i `before`) s &&+                                  unions [lo,c,hi] == s &&+                                  size lo + size c + size hi == size 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+                                  valid s' &&                                   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+                                  valid s' &&                                   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+                                  valid s' &&                                   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)@@ -161,6 +188,22 @@ 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) +prop_flattenWithMonotonic (IS s) = let s' = flattenWithMonotonic combine s in+                                   valid s' &&+                                   size s' <= size s &&+                                   nonOverlapping (toAscList s') &&+                                   (null s || (let Just a = findMin s+                                                   Just b = findMin s'+                                                   Just c = findLast s+                                                   Just d = findLast s'+                                               in lowerBound a == lowerBound b &&+                                                  upperBound c == upperBound d))++nonOverlapping :: (Interval i e) => [i] -> Bool+nonOverlapping (x:y:xs) | x `overlaps` y = False+                        | otherwise      = nonOverlapping (y:xs)+nonOverlapping _ = True+ check p name = do putStrLn ("Testing " ++ name ++ ":")                   r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p                   if isSuccess r@@ -205,8 +248,13 @@          check prop_partition "partition"          check prop_split "split"          check prop_splitMember "splitMember"+         check prop_splitAt1 "splitAt lower"+         check prop_splitAt2 "splitAt containing"+         check prop_splitAt3 "splitAt higher"+         check prop_splitIntersecting "splitIntersecting"          check prop_containing "containing"          check prop_intersecting "intersecting"          check prop_within "within"+         check prop_flattenWithMonotonic "flattenWithMonotonic"          check prop_readShow "read/show"          exitSuccess

@@ -5,6 +5,7 @@ import Test.QuickCheck import Test.QuickCheck.Test (isSuccess) import Control.Monad (liftM)+import Data.List (maximumBy)  import Data.IntervalMap.Interval @@ -113,6 +114,34 @@     GT -> compare i1 i2 == GT     EQ -> True +prop_compare_openness_closedness_lower_bound (II i1) (II i2) =+  if lowerBound i1 == lowerBound i2 then+    let smaller = minimum [i1, i2]+        leftOpen = not . leftClosed+    in leftClosed smaller || (leftOpen i1 && leftOpen i2)+  else+    lowerBound i1 /= lowerBound i2++prop_compare_openness_closedness_upper_bound (II i1) (II i2) =+  if upperBound i1 == upperBound i2 then+    let bigger = maximumBy compareByUpper [i1, i2]+        rightOpen = not. rightClosed+    in rightClosed bigger || (rightOpen i1 && rightOpen i2)+  else+    upperBound i1 /= upperBound i2++prop_combine_closedness =+  let maybeTest = maybe False+  in maybeTest (c15 ==) (combine co15 oc15) &&+     maybeTest (c15 ==) (combine c15 o15) &&+     maybeTest (o15 ==) (combine o15 o15) &&+     maybeTest (co15 ==) (combine co15 o15) &&+     maybeTest (oc15 ==) (combine oc15 o15)++prop_combine_reflexive (II i) =+  let maybeTest = maybe False+  in maybeTest (i ==) (combine i i)+ prop_contains (II i) p =   if p `inside` i then     lowerBound i <= p && upperBound i >= p@@ -144,11 +173,15 @@ 	 check prop_rightClosed "rightClosed"          check prop_ord "ord" 	 check prop_compare1 "compare1"+	 check prop_compare_openness_closedness_lower_bound "compare_openness_closedness_lower_bound"+	 check prop_compare_openness_closedness_upper_bound "compare_openness_closedness_upper_bound" 	 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_combine_closedness "combine_closedness"+	 check prop_combine_reflexive "combine_reflexive" 	 check prop_contains "contains" 	 check prop_subsumes "subsumes" 	 check prop_equals "equals"