IntervalMap (empty) → 0.2.0
raw patch · 9 files changed
+2188/−0 lines, 9 filesdep +Cabaldep +IntervalMapdep +QuickChecksetup-changed
Dependencies added: Cabal, IntervalMap, QuickCheck, base, containers, deepseq
Files
- Data/IntervalMap.hs +1180/−0
- Data/IntervalMap/Interval.hs +262/−0
- IntervalMap.cabal +39/−0
- LICENSE +30/−0
- README +18/−0
- Setup.hs +2/−0
- examples/Example.hs +45/−0
- test/IntervalMapTests.hs +457/−0
- test/IntervalTests.hs +155/−0
+ Data/IntervalMap.hs view
@@ -0,0 +1,1180 @@+-- |+-- Module : Data.IntervalMap+-- Copyright : (c) Christoph Breitkopf 2011+-- License : BSD-style+-- Maintainer : chbreitkopf@googlemail.com+-- Stability : experimental+-- Portability : portable+--+-- An implementation of maps from intervals to values. The key intervals may+-- overlap, and the implementation supports an efficient stabbing query.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.IntervalMap (IvMap)+-- > import qualified Data.IntervalMap as IvMap+--+-- It offers most of the functions in Data.Map, but 'Interval' /k/ instead of+-- just /k/ as the key type. Some of the functions need stricter type constraints to+-- maintain the additional information for efficient interval searching,+-- for example 'fromDistinctAscList' needs an 'Ord' /k/ constraint.+--+-- Index-based access and some set functions have not been implemented, and many non-core+-- functions, for example the set operations, have not been tuned for efficiency yet.+--+-- In addition, there are functions specific to maps of intervals, for example to search+-- for all keys containing a given point or contained in a given interval.+--+-- To stay compatible with standard Haskell, this implementation uses a fixed data+-- type for intervals, and not a multi-parameter type class. Thus, it's currently+-- not possible to define e.g. a 2-tuple as an instance of interval and use that+-- map key. Instead you must convert your keys to 'Data.IntervalMap.Interval'.+--+-- Closed, open, and half-open intervals can be contained in the same map.+--+-- It is an error to insert an empty interval into a map. This precondition is not+-- checked by the various insertion functions.+--+-- The implementation is a red-black tree augmented with the maximum upper bound+-- of all keys.+--+-- Parts of this implementation are based on code from the 'Data.Map' implementation,+-- (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008.+-- The red-black tree deletion is based on code from llrbtree by Kazu Yamamoto.+-- Of course, any errors are mine.+--+module Data.IntervalMap (+ -- * re-export+ Interval(..)+ -- * Map type+ , IntervalMap -- instance Eq,Show,Read++ -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault++ -- ** Interval query+ , containing+ , intersecting+ , within+ + -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWith'+ , insertWithKey+ , insertWithKey'+ , insertLookupWithKey+ , insertLookupWithKey'+ + -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union + , unionWith + , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey+ + -- ** Intersection+ , intersection + , intersectionWith+ , intersectionWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- ** Fold+ , foldr, foldl+ , foldrWithKey, foldlWithKey+ , foldl', foldr'+ , foldrWithKey', foldlWithKey'++ -- * Conversion+ , elems+ , keys+ , keysSet+ , assocs+ + -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter + , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split + , splitLookup + {-++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed + , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt+ -}++ -- * Min\/Max+ , findMin+ , findMax+ , findLast+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ {-+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey+ -}++ -- * Debugging+ , valid++ -- * Testing+ , height, maxHeight, showStats++ ) where++import Prelude hiding (null, lookup, map, filter, foldr, foldl)+import Data.Bits (shiftR, (.&.))+import Data.Monoid (Monoid(..))+import Control.Applicative (Applicative(..), (<$>))+import Data.Traversable (Traversable(traverse))+import qualified Data.Foldable as Foldable+import qualified Data.List as L+import qualified Data.Set as Set+import Control.DeepSeq (NFData(rnf))++import Data.IntervalMap.Interval++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | Lookup value for given key. Calls 'error' if the key is not in the map.+(!) :: (Ord k) => IntervalMap k v -> Interval k -> v+tree ! key = case lookup key tree of+ Just v -> v+ Nothing -> error "IntervalMap.!: key not found"++-- | Same as 'difference'.+(\\) :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+m1 \\ m2 = difference m1 m2+++data Color = R | B deriving (Eq, Read, Show)++-- | A map from intervals with endpoints of type @k@ to values of type @v@.+data IntervalMap k v = Nil+ | Node !Color+ !(Interval k) -- key+ !(Interval k) -- interval with maximum upper in tree+ v -- value+ !(IntervalMap k v) -- left subtree+ !(IntervalMap k v) -- right subtree++instance (Eq k, Eq v) => Eq (IntervalMap k v) where+ a == b = toAscList a == toAscList b++instance (Ord k, Ord v) => Ord (IntervalMap k v) where+ compare a b = compare (toAscList a) (toAscList b)++instance Functor (IntervalMap k) where+ fmap f m = map f m++instance (Ord k) => Monoid (IntervalMap k v) where+ mempty = empty+ mappend = union+ mconcat = unions++instance Traversable (IntervalMap k) where+ traverse _ Nil = pure Nil+ traverse f (Node c k m v l r)+ = flip (Node c k m) <$> traverse f l <*> f v <*> traverse f r++instance Foldable.Foldable (IntervalMap k) where+ fold Nil = mempty+ fold (Node _ _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r+ foldr = foldr+ foldl = foldl+ foldMap _ Nil = mempty+ foldMap f (Node _ _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r++instance (NFData k, NFData a) => NFData (IntervalMap k a) where+ rnf Nil = ()+ rnf (Node _ kx _ x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r++instance (Ord k, Read k, Read e) => Read (IntervalMap k e) where+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)++instance (Show k, Show a) => Show (IntervalMap k a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)+++isRed :: IntervalMap k v -> Bool+isRed (Node R _ _ _ _ _) = True+isRed _ = False++turnBlack :: IntervalMap k v -> IntervalMap k v+turnBlack (Node R k m vs l r) = Node B k m vs l r+turnBlack t = t++turnRed :: IntervalMap k v -> IntervalMap k v+turnRed Nil = error "turnRed: Leaf"+turnRed (Node B k m v l r) = Node R k m v l r+turnRed t = t++-- construct node, recomputing the upper key bound.+mNode :: (Ord k) => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v+mNode c k v l r = Node c k (maxUpper k l r) v l r++maxUpper :: Ord k => Interval k -> IntervalMap k v -> IntervalMap k v -> Interval k+maxUpper k Nil Nil = k `seq` k+maxUpper k Nil (Node _ _ m _ _ _) = maxByUpper k m+maxUpper k (Node _ _ m _ _ _) Nil = maxByUpper k m+maxUpper k (Node _ _ l _ _ _) (Node _ _ r _ _ _) = maxByUpper k (maxByUpper l r)++-- interval with the greatest upper bound. The lower bound is ignored!+maxByUpper :: Ord a => Interval a -> Interval a -> Interval a+maxByUpper a@(IntervalCO _ u) b = if u > upperBound b then a else b+maxByUpper a@(ClosedInterval _ u) b = if u >= upperBound b then a else b+maxByUpper a@(OpenInterval _ u) b = if u > upperBound b then a else b+maxByUpper a@(IntervalOC _ u) b = if u >= upperBound b then a else b+++-- ---------------------------------------------------------++-- | The empty map.+empty :: IntervalMap k v+empty = Nil++-- | A map with one entry.+singleton :: Interval k -> v -> IntervalMap k v+singleton k v = Node B k k v Nil Nil+++-- | Is the map empty?+null :: IntervalMap k v -> Bool+null Nil = True+null _ = False++-- | Number of keys in the map.+size :: IntervalMap k v -> Int+size t = h 0 t+ where+ h n m = n `seq` case m of+ Nil -> n+ Node _ _ _ _ l r -> h (h n l + 1) r++-- | The height of the tree. For testing/debugging only.+height :: IntervalMap k v -> Int+height Nil = 0+height (Node _ _ _ _ l r) = 1 + max (height l) (height r)++-- | The maximum height of a red-black tree with the given number of nodes.+maxHeight :: Int -> Int+maxHeight nodes = 2 * log2 (nodes + 1)++-- | Tree statistics (size, height, maxHeight size)+showStats :: IntervalMap k a -> (Int, Int, Int)+showStats m = (n, height m, maxHeight n)+ where n = size m++-- | Does the map contain the given key? See also 'notMember'.+member :: (Ord k) => Interval k -> IntervalMap k v -> Bool+member key tree = case lookup key tree of+ Nothing -> False+ Just _ -> True++-- | Does the map not contain the given key? See also 'member'.+notMember :: (Ord k) => Interval k -> IntervalMap k v -> Bool+notMember key tree = not (member key tree)+++-- | Look up the given key in the map, returning the value @('Just' value)@,+-- or 'Nothing if the key is not in the map.+lookup :: (Ord k) => Interval k -> IntervalMap k v -> Maybe v+lookup k Nil = k `seq` Nothing+lookup k (Node _ key _ v l r) = case compare k key of+ LT -> lookup k l+ GT -> lookup k r+ EQ -> Just v+++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++findWithDefault :: Ord k => a -> Interval k -> IntervalMap k a -> a+findWithDefault def k m = case lookup k m of+ Nothing -> def+ Just x -> x++-- | Return all key/value pairs where the key intervals contain the given point.+-- The elements are returned in ascending key order.+containing :: (Ord k) => IntervalMap k v -> k -> [(Interval k, v)]+t `containing` pt = go [] pt t+ where+ go xs p Nil = p `seq` xs+ go xs p (Node _ k m v l r)+ | p `above` m = xs -- above all interval 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 order in which the elements are returned is undefined.+intersecting :: (Ord k) => IntervalMap k v -> Interval k -> [(Interval k, v)]+t `intersecting` iv = go [] iv t+ where+ go xs i Nil = i `seq` xs+ go xs i (Node _ k m v l r)+ | i `after` m = xs+ | i `before` k = go xs i l+ | i `overlaps` k = go ((k,v) : go xs i r) i l+ | otherwise = go (go xs i r) i l++-- | Return all key/value pairs where the key intervals are completely inside the given interval.+-- The order in which the elements are returned is undefined.+within :: (Ord k) => IntervalMap k v -> Interval k -> [(Interval k, v)]+t `within` iv = go [] iv t+ where+ go xs i Nil = i `seq` xs+ go xs i (Node _ k m v l r)+ | i `after` m = xs+ | i `before` k = go xs i l+ | i `subsumes` k = go ((k,v) : go xs i r) i l+ | otherwise = go (go xs i r) i l+++-- | Insert a new key/value pair. If the map already contains the key, its value is+-- changed to the new value.+insert :: (Ord k) => Interval k -> v -> IntervalMap k v -> IntervalMap k v+insert = insertWithKey' (\_ v _ -> v)+{-# INLINE insert #-}++-- | Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+insertWith :: (Ord k) => (v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v+insertWith f = insertWithKey (\_ new old -> f new old)+{-# INLINE insertWith #-}++-- | Same as 'insertWith', but the combining function is applied strictly.+-- This is often the most desirable behavior.+insertWith' :: (Ord k) => (v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v+insertWith' f = insertWithKey' (\_ new old -> f new old)+{-# INLINE insertWith' #-}++-- | Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+insertWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v+insertWithKey f k v m = snd (insertLookupWithKey f k v m)+{-# INLINE insertWithKey #-}++-- | Same as 'insertWithKey', but the combining function is applied strictly.+insertWithKey' :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v+insertWithKey' f k v m = snd (insertLookupWithKey' f k v m)+{-# INLINE insertWithKey' #-}++-- | Combine insert with old values retrieval.+insertLookupWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v)+insertLookupWithKey f key value mp = key `seq` (oldval, turnBlack mp')+ where+ (oldval, mp') = ins mp+ singletonR k v = Node R k k v Nil Nil+ ins Nil = (Nothing, singletonR key value)+ ins (Node color k m v l r) =+ case compare key k of+ LT -> case ins l of+ (x@(Just _), t') -> (x, Node color k m v t' r)+ (Nothing, t') -> (Nothing, balanceL color k v t' r)+ GT -> case ins r of+ (x@(Just _), t') -> (x, Node color k m v l t')+ (Nothing, t') -> (Nothing, balanceR color k v l t')+ EQ -> (Just v, Node color k m (f k value v) l r)++-- | Combine insert with old values retrieval.+insertLookupWithKey' :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v)+insertLookupWithKey' f key value mp = key `seq` (oldval, turnBlack mp')+ where+ (oldval, mp') = ins mp+ singletonR k v = Node R k k v Nil Nil+ ins Nil = value `seq` (Nothing, singletonR key value)+ ins (Node color k m v l r) =+ case compare key k of+ LT -> case ins l of+ (x@(Just _), t') -> (x, Node color k m v t' r)+ (Nothing, t') -> (Nothing, balanceL color k v t' r)+ GT -> case ins r of+ (x@(Just _), t') -> (x, Node color k m v l t')+ (Nothing, t') -> (Nothing, balanceR color k v l t')+ EQ -> let v' = f k value v in v' `seq` (Just v, Node color k m v' l r)+++balanceL :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v+balanceL B zk zv (Node R yk _ yv (Node R xk _ xv a b) c) d =+ mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceL B zk zv (Node R xk _ xv a (Node R yk _ yv b c)) d =+ mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceL c xk xv l r = mNode c xk xv l r++balanceR :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v+balanceR B xk xv a (Node R yk _ yv b (Node R zk _ zv c d)) =+ mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceR B xk xv a (Node R zk _ zv (Node R yk _ yv b c) d) =+ mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d)+balanceR c xk xv l r = mNode c xk xv l r+++-- min/max++-- | Returns the smallest key and its associated value.+-- Calls 'error' if the map is empty.+findMin :: IntervalMap k v -> (Interval k, v)+findMin (Node _ k _ v Nil _) = (k,v)+findMin (Node _ _ _ _ l _) = findMin l+findMin Nil = error "IntervalMap.findMin: empty map"++-- | Returns the largest key and its associated value.+-- Calls 'error' if the map is empty.+findMax :: IntervalMap k v -> (Interval k, v)+findMax (Node _ k _ v _ Nil) = (k,v)+findMax (Node _ _ _ _ _ r) = findMax r+findMax Nil = error "IntervalMap.findMin: empty map"++-- | Returns the interval with the largest endpoint.+-- If there is more than one interval with that endpoint,+-- return the rightmost.+findLast :: Eq k => IntervalMap k v -> (Interval k, v)+findLast Nil = error "IntervalMap.findLast: empty map"+findLast t@(Node _ _ mx _ _ _) = lastMax+ where+ (lastMax : _) = go t+ go Nil = []+ go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ ((k,v) : go l)+ else go r ++ go l+ | otherwise = []+ sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b+++-- use our own Either type for readability+data DeleteResult k v = Unchanged !(IntervalMap k v)+ | Shrunk !(IntervalMap k v)+++-- | Remove the smallest key from the map. Return the empty map if the map is empty.+deleteMin :: (Ord k) => IntervalMap k v -> IntervalMap k v+deleteMin Nil = Nil+deleteMin mp = case deleteMin' mp of+ (Unchanged r, _, _) -> turnBlack r+ (Shrunk r, _, _) -> turnBlack r++deleteMin' :: Ord k => IntervalMap k v -> (DeleteResult k v, Interval k, v)+deleteMin' Nil = error "deleteMin': Nil"+deleteMin' (Node B k _ v Nil Nil) = (Shrunk Nil, k, v)+deleteMin' (Node B k _ v Nil r@(Node R _ _ _ _ _)) = (Unchanged (turnBlack r), k, v)+deleteMin' (Node R k _ v Nil r) = (Unchanged r, k, v)+deleteMin' (Node c k _ v l r) =+ case deleteMin' l of+ (Unchanged l', rk, rv) -> (Unchanged (mNode c k v l' r), rk, rv)+ (Shrunk l', rk, rv) -> (unbalancedR c k v l' r, rk, rv)++deleteMax' :: Ord k => IntervalMap k v -> (DeleteResult k v, Interval k, v)+deleteMax' Nil = error "deleteMax': Nil"+deleteMax' (Node B k _ v Nil Nil) = (Shrunk Nil, k, v)+deleteMax' (Node B k _ v l@(Node R _ _ _ _ _) Nil) = (Unchanged (turnBlack l), k, v)+deleteMax' (Node R k _ v l Nil) = (Unchanged l, k, v)+deleteMax' (Node c k _ v l r) =+ case deleteMax' r of+ (Unchanged r', rk, rv) -> (Unchanged (mNode c k v l r'), rk, rv)+ (Shrunk r', rk, rv) -> (unbalancedL c k v l r', rk, rv)++-- The left tree lacks one Black node+unbalancedR :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v+-- Decreasing one Black node in the right+unbalancedR B k v l r@(Node B _ _ _ _ _) = Shrunk (balanceR B k v l (turnRed r))+unbalancedR R k v l r@(Node B _ _ _ _ _) = Unchanged (balanceR B k v l (turnRed r))+-- Taking one Red node from the right and adding it to the right as Black+unbalancedR B k v l (Node R rk _ rv rl@(Node B _ _ _ _ _) rr)+ = Unchanged (mNode B rk rv (balanceR B k v l (turnRed rl)) rr)+unbalancedR _ _ _ _ _ = error "unbalancedR"++unbalancedL :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v+unbalancedL B k v l@(Node B _ _ _ _ _) r = Shrunk (balanceL B k v (turnRed l) r)+unbalancedL R k v l@(Node B _ _ _ _ _) r = Unchanged (balanceL B k v (turnRed l) r)+unbalancedL B k v (Node R lk _ lv ll lr@(Node B _ _ _ _ _)) r+ = Unchanged (mNode B lk lv ll (balanceL B k v (turnRed lr) r))+unbalancedL _ _ _ _ _ = error "unbalancedL"++++-- | Remove the largest key from the map. Return the empty map if the map is empty.+deleteMax :: (Ord k) => IntervalMap k v -> IntervalMap k v+deleteMax Nil = Nil+deleteMax mp = case deleteMax' mp of+ (Unchanged r, _ , _) -> turnBlack r+ (Shrunk r, _ , _) -> turnBlack r++-- | Delete and return the smallest key.+deleteFindMin :: (Ord k) => IntervalMap k v -> ((Interval k,v), IntervalMap k v)+deleteFindMin mp = case deleteMin' mp of+ (Unchanged r, k, v) -> ((k,v), turnBlack r)+ (Shrunk r, k, v) -> ((k,v), turnBlack r)++-- | Delete and return the largest key.+deleteFindMax :: (Ord k) => IntervalMap k v -> ((Interval k,v), IntervalMap k v)+deleteFindMax mp = case deleteMax' mp of+ (Unchanged r, k, v) -> ((k,v), turnBlack r)+ (Shrunk r, k, v) -> ((k,v), turnBlack r)++-- | Update or delete value at minimum key.+updateMin :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMin f m = updateMinWithKey (\_ v -> f v) m++-- | Update or delete value at maximum key.+updateMax :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMax f m = updateMaxWithKey (\_ v -> f v) m++-- | Update or delete value at minimum key.+updateMinWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMinWithKey _ Nil = Nil+updateMinWithKey f m = let (k,v) = findMin m in+ case f k v of+ Just v' -> setMinValue v' m+ Nothing -> deleteMin m++-- | Update or delete value at maximum key.+updateMaxWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v+updateMaxWithKey _ Nil = Nil+updateMaxWithKey f m = let (k,v) = findMax m in+ case f k v of+ Just v' -> setMaxValue v' m+ Nothing -> deleteMax m++setMinValue :: v -> IntervalMap k v -> IntervalMap k v+setMinValue _ Nil = Nil+setMinValue v' (Node c k m v Nil r) = Node c k m v' Nil r+setMinValue v' (Node c k m v l r) = Node c k m v (setMinValue v' l) r++setMaxValue :: v -> IntervalMap k v -> IntervalMap k v+setMaxValue _ Nil = Nil+setMaxValue v' (Node c k m v l Nil) = Node c k m v' l Nil+setMaxValue v' (Node c k m v l r) = Node c k m v l (setMaxValue v' r)++++-- folding++-- | Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+foldr :: (a -> b -> b) -> b -> IntervalMap k a -> b+foldr _ z Nil = z+foldr f z (Node _ _ _ x l r) = foldr f (f x (foldr f z r)) l++-- | A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> IntervalMap k a -> b+foldr' f z m = z `seq` case m of+ Nil -> z+ Node _ _ _ x l r -> foldr' f (f x (foldr' f z r)) l++-- | Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+foldl :: (b -> a -> b) -> b -> IntervalMap k a -> b+foldl _ z Nil = z+foldl f z (Node _ _ _ x l r) = foldl f (f (foldl f z l) x) r++-- | A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (b -> a -> b) -> b -> IntervalMap k a -> b+foldl' f z m = z `seq` case m of+ Nil -> z+ Node _ _ _ x l r -> foldl' f (f (foldl' f z l) x) r++-- | Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+foldrWithKey :: (Interval k -> v -> a -> a) -> a -> IntervalMap k v -> a+foldrWithKey _ z Nil = z+foldrWithKey f z (Node _ k _ x l r) = foldrWithKey f (f k x (foldrWithKey f z r)) l++-- | A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Interval k -> v -> a -> a) -> a -> IntervalMap k v -> a+foldrWithKey' f z m = z `seq` case m of+ Nil -> z+ Node _ k _ x l r -> foldrWithKey' f (f k x (foldrWithKey' f z r)) l++-- | Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+foldlWithKey :: (a -> Interval k -> v -> a) -> a -> IntervalMap k v -> a+foldlWithKey _ z Nil = z+foldlWithKey f z (Node _ k _ x l r) = foldlWithKey f (f (foldlWithKey f z l) k x) r++-- | A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Interval k -> v -> a) -> a -> IntervalMap k v -> a+foldlWithKey' f z m = z `seq` case m of+ Nil -> z+ Node _ k _ x l r -> foldlWithKey' f (f (foldlWithKey' f z l) k x) r++-- delete++-- | Delete a key from the map. If the map does not contain the key,+-- it is returned unchanged.+delete :: (Ord k) => Interval k -> IntervalMap k v -> IntervalMap k v+delete key mp = case delete' key mp of+ Unchanged r -> turnBlack r+ Shrunk r -> turnBlack r++delete' :: Ord k => Interval k -> IntervalMap k v -> DeleteResult k v+delete' x Nil = x `seq` Unchanged Nil+delete' x (Node c k _ v l r) =+ case compare x k of+ LT -> case delete' x l of+ (Unchanged l') -> Unchanged (mNode c k v l' r)+ (Shrunk l') -> unbalancedR c k v l' r+ GT -> case delete' x r of+ (Unchanged r') -> Unchanged (mNode c k v l r')+ (Shrunk r') -> unbalancedL c k v l r'+ EQ -> case r of+ Nil -> if c == B then blackify l else Unchanged l+ _ -> case deleteMin' r of+ (Unchanged r', rk, rv) -> Unchanged (mNode c rk rv l r')+ (Shrunk r', rk, rv) -> unbalancedL c rk rv l r'++blackify :: IntervalMap k v -> DeleteResult k v+blackify s@(Node R _ _ _ _ _) = Unchanged (turnBlack s)+blackify s = Shrunk s++-- | Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a+adjust f k m = adjustWithKey (\_ v -> f v) k m+{-# INLINE adjust #-}++-- | Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+adjustWithKey :: Ord k => (Interval k -> a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a+adjustWithKey _ _ Nil = Nil+adjustWithKey f x (Node c k m v l r) =+ case compare x k of+ LT -> Node c k m v (adjustWithKey f x l) r+ GT -> Node c k m v l (adjustWithKey f x r)+ EQ -> Node c k m (f k v) l r++-- | The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+update f k m = updateWithKey (\_ v -> f v) k m+{-# INLINE update #-}++-- | The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+updateWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+updateWithKey f k m = snd (updateLookupWithKey f k m)+{-# INLINE updateWithKey #-}++-- | Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+updateLookupWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> (Maybe a, IntervalMap k a)+updateLookupWithKey f x m = case lookup x m of+ Nothing -> (Nothing, m)+ r@(Just v) -> case f x v of+ Nothing -> (r, delete x m)+ r'@(Just v') -> (r', adjust (const v') x m)++-- | The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a+alter f x m = case lookup x m of+ Nothing -> case f Nothing of+ Nothing -> m+ Just v -> insert x v m+ y -> case f y of+ Nothing -> delete x m+ Just v' -> adjust (const v') x m+++-- | The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+union :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a+union m1 m2 = unionWith const m1 m2+{-# INLINE union #-}++-- | Union with a combining function.+unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2+{-# INLINE unionWith #-}++-- | Union with a combining function.+unionWithKey :: Ord k => (Interval k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a+unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2))++-- | The union of a list of maps:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+unions :: Ord k => [IntervalMap k a] -> IntervalMap k a+unions = L.foldl union empty++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a+unionsWith f = L.foldl (unionWith f) empty++-- | Difference of two maps. +-- Return elements of the first map not existing in the second map.+difference :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+difference m1 m2 = differenceWithKey (\_ _ _ -> Nothing) m1 m2+{-# INLINE difference #-}++-- | Difference with a combining function. +-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWith :: Ord k => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a+differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2+{-# INLINE differenceWith #-}++-- | Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWithKey :: Ord k => (Interval k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a+differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2))++-- | Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+intersection :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a+intersection m1 m2 = intersectionWithKey (\_ v _ -> v) m1 m2+{-# INLINE intersection #-}++-- | Intersection with a combining function.+intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2+{-# INLINE intersectionWith #-}++-- | Intersection with a combining function.+intersectionWithKey :: Ord k => (Interval k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c+intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2))++ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)]+ascListUnion _ [] [] = []+ascListUnion _ [] ys = ys+ascListUnion _ xs [] = xs+ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') =+ case compare xk yk of+ LT -> x : ascListUnion f xs' ys+ GT -> y : ascListUnion f xs ys'+ EQ -> (xk, f xk xv yv) : ascListUnion f xs' ys'++ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)]+ascListDifference _ [] _ = []+ascListDifference _ xs [] = xs+ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') =+ case compare xk yk of+ LT -> x : ascListDifference f xs' ys+ GT -> ascListDifference f xs ys'+ EQ -> case f xk xv yv of+ Nothing -> ascListDifference f xs' ys'+ Just v' -> (xk,v') : ascListDifference f xs' ys'++ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)]+ascListIntersection _ [] _ = []+ascListIntersection _ _ [] = []+ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') =+ case compare xk yk of+ LT -> ascListIntersection f xs' ys+ GT -> ascListIntersection f xs ys'+ EQ -> (xk, f xk xv yv) : ascListIntersection f xs' ys'+++-- --- Conversion ---++-- | The list of all key\/value pairs contained in the map, in ascending order of keys.+toAscList :: IntervalMap k v -> [(Interval k,v)]+toAscList m = foldrWithKey (\k v r -> (k,v) : r) [] m++-- | The list of all key\/value pairs contained in the map, in no particular order.+toList :: IntervalMap k v -> [(Interval k,v)]+toList m = toAscList m++-- | The list of all key\/value pairs contained in the map, in descending order of keys.+toDescList :: IntervalMap k v -> [(Interval k, v)]+toDescList m = foldlWithKey (\r k v -> (k,v) : r) [] m++-- | Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+fromList :: Ord k => [(Interval k,v)] -> IntervalMap k v+fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs++-- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a +fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs++-- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+fromListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a +fromListWithKey f xs = L.foldl' ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t++-- | Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: Ord k => [(Interval k,v)] -> IntervalMap k v+fromAscList xs = fromAscListWith (\_ b -> b) xs++-- | Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a +fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs++-- | Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+fromAscListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a +fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs)++combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)]+combineEq _ [] = []+combineEq _ xs@[_] = xs+combineEq f (x@(xk,xv) : xs@((yk,yv) : xs'))+ | xk == yk = combineEq f ((xk, f xk xv yv) : xs')+ | otherwise = x : combineEq f xs++-- | Build a map from an ascending list of elements with distinct keys in linear time.+-- /The precondition is not checked./+fromDistinctAscList :: (Ord k) => [(Interval k,v)] -> IntervalMap k v+-- exactly 2^n-1 items have height n. They can be all black+-- from 2^n - 2^n-2 items have height n+1. The lowest "row" should be red.+fromDistinctAscList lyst = case h (length lyst) lyst of+ (result, []) -> result+ _ -> error "fromDistinctAscList: list not fully consumed"+ where+ h n xs | n == 0 = (Nil, xs)+ | isPerfect n = buildB n xs+ | otherwise = buildR n (log2 n) xs++ buildB n xs | n <= 0 = error "fromDictinctAscList: buildB 0"+ | n == 1 = case xs of ((k,v):xs') -> (Node B k k v Nil Nil, xs')+ | otherwise =+ case n `quot` 2 of { n' ->+ case buildB n' xs of { (l, (k,v):xs') ->+ case buildB n' xs' of { (r, xs'') ->+ (mNode B k v l r, xs'') }}}++ buildR n d xs | d `seq` n == 0 = (Nil, xs)+ | n == 1 = case xs of ((k,v):xs') -> (Node (if d==0 then R else B) k k v Nil Nil, xs')+ | otherwise =+ case n `quot` 2 of { n' ->+ case buildR n' (d-1) xs of { (l, (k,v):xs') ->+ case buildR (n - (n' + 1)) (d-1) xs' of { (r, xs'') ->+ (mNode B k v l r, xs'') }}}++-- is n a perfect binary tree size (2^m-1)?+isPerfect :: Int -> Bool+isPerfect n = (n .&. (n + 1)) == 0+{-# INLINE isPerfect #-}++log2 :: Int -> Int+log2 m = h (-1) m+ where+ h r n | n <= 0 = r+ | otherwise = h (r + 1) (n `shiftR` 1)+++-- | List of all values in the map, in no particular order.+elems :: IntervalMap k v -> [v]+elems m = [v | (_,v) <- toList m]++-- | List of all keys in the map, in no particular order.+keys :: IntervalMap k v -> [Interval k]+keys m = [k | (k,_) <- toList m]++-- | Set of the keys.+keysSet :: (Ord k) => IntervalMap k v -> Set.Set (Interval k)+keysSet m = Set.fromList (keys m)++-- | Same as 'toList'.+assocs :: IntervalMap k v -> [(Interval k, v)]+assocs m = toList m+{-# INLINE assocs #-}++-- --- Mapping ---++-- | /O(n)/. Map a function over all values in the map.+map :: (a -> b) -> IntervalMap k a -> IntervalMap k b+map f = mapWithKey (\_ x -> f x)+{-# INLINE map #-}++-- | /O(n)/. Map a function over all values in the map.+mapWithKey :: (Interval k -> a -> b) -> IntervalMap k a -> IntervalMap k b+mapWithKey f = go+ where+ go Nil = Nil+ go (Node c k m v l r) = Node c k m (f k v) (go l) (go r)++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])+mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m+{-# INLINE mapAccum #-}++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])+mapAccumWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumWithKey f a t = mapAccumL f a t+{-# INLINE mapAccumWithKey #-}++-- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- argument throught the map in ascending order of keys.+mapAccumL :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumL f = go+ where+ go a Nil = (a,Nil)+ go a (Node c kx m x l r) =+ let (a1,l') = go a l+ (a2,x') = f a1 kx x+ (a3,r') = go a2 r+ in (a3, Node c kx m x' l' r')++-- | /O(n)/. The function 'mapAccumR' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c)+mapAccumRWithKey f = go+ where+ go a Nil = (a, Nil)+ go a (Node c kx m x l r) =+ let (a1,r') = go a r+ (a2,x') = f a1 kx x+ (a3,l') = go a2 l+ in (a3, Node c kx m x' l' r')+++-- | @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the value at the smallest of+-- these keys is retained.+mapKeys :: Ord k2 => (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeys f m = fromList [ (f k, v) | (k, v) <- toDescList m ]++-- | @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.+mapKeysWith :: Ord k2 => (a -> a -> a) -> (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ]++-- | @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+mapKeysMonotonic :: Ord k2 => (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a+mapKeysMonotonic f m = mapKeys f m++-- | Filter values satisfying a predicate.+filter :: Ord k => (a -> Bool) -> IntervalMap k a -> IntervalMap k a+filter p m = filterWithKey (\_ v -> p v) m+{-# INLINE filter #-}++-- | Filter keys\/values satisfying a predicate.+filterWithKey :: Ord k => (Interval k -> a -> Bool) -> IntervalMap k a -> IntervalMap k a+filterWithKey p m = mapMaybeWithKey (\k v -> if p k v then Just v else Nothing) m+{-# INLINE filterWithKey #-}++-- | Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partition :: Ord k => (a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)+partition p m = partitionWithKey (\_ v -> p v) m+{-# INLINE partition #-}++-- | Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+partitionWithKey :: Ord k => (Interval k -> a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)+partitionWithKey p m = mapEitherWithKey p' m+ where+ p' k v | p k v = Left v+ | otherwise = Right v+{-# INLINE partitionWithKey #-}++-- | Map values and collect the 'Just' results.+mapMaybe :: Ord k => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b+mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m+{-# INLINE mapMaybe #-}++-- | Map keys\/values and collect the 'Just' results.+mapMaybeWithKey :: Ord k => (Interval k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b+mapMaybeWithKey f m = fromDistinctAscList (mapf [] m)+ where+ mapf z Nil = z+ mapf z (Node _ k _ v l r) = mapf (f' k v z r) l+ f' k v z r = case f k v of+ Nothing -> mapf z r+ Just v' -> (k,v') : mapf z r++-- | Map values and separate the 'Left' and 'Right' results.+mapEither :: Ord k => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)+mapEither f m = mapEitherWithKey (\_ v -> f v) m+{-# INLINE mapEither #-}++-- | Map keys\/values and separate the 'Left' and 'Right' results.+mapEitherWithKey :: Ord k => (Interval k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c)+mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r)+ where+ (l, r) = part [] [] (toDescList m)+ part ls rs [] = (ls, rs)+ part ls rs ((k,v):xs) = case f k v of+ Left v' -> part ((k,v'):ls) rs xs+ Right v' -> part ls ((k,v'):rs) xs++-- | The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+split :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a)+split x m = (l, r)+ where (l, _, r) = splitLookup x m+{-# INLINE split #-}+ +-- | The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@. +splitLookup :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, Maybe a, IntervalMap k a)+splitLookup _ Nil = (Nil, Nothing, Nil)+splitLookup x (Node _ k _ v l r) = case compare x k of+ EQ -> (turnBlack l, Just v, turnBlack r)+ LT -> let (l', val, r') = splitLookup x l in (l', val, insert k v (union r r'))+ GT -> let (l', val, r') = splitLookup x r in (insert k v (union l l'), val, r')+++-- debugging++-- | Check red-black-tree and interval search augmentation invariants.+valid :: Ord k => IntervalMap k v -> Bool+valid mp = ({-# SCC "scc_test" #-} 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 = {-# SCC "scc_blackDepth" #-} blackDepth n >= 0++ -- return -1 if subtrees have diffrent black depths or two consecutive red nodes are encountered+ blackDepth :: IntervalMap k v -> Int+ blackDepth Nil = 0+ blackDepth (Node c _ _ _ l r) = case blackDepth l of+ ld -> if ld < 0 then ld+ else+ case blackDepth r of+ rd -> if rd < 0 then rd+ else if rd /= ld then -1+ else if c == R && (isRed l || isRed r) then -1+ else if c == B then rd + 1+ else rd+
+ Data/IntervalMap/Interval.hs view
@@ -0,0 +1,262 @@+-- |+-- Module : Data.IntervalMap.Interval+-- Copyright : (c) Christoph Breitkopf 2011+-- License : BSD-style+-- Maintainer : chris@chr-breitkopf.de+-- Stability : experimental+-- Portability : portable+--+-- A conservative implementation of Intervals, mostly for use as keys in+-- a 'Data.IntervalMap'.+--+-- This should really be a typeclass, so you could have a tuple be an instance+-- of Interval, but that is currently not possible in standard Haskell.+--+-- The contructor names of the half-open intervals seem somewhat clumsy,+-- and I'm open to suggestions for better names.+--+module Data.IntervalMap.Interval (+ -- * Interval type+ Interval(..),+ -- * Query+ lowerBound, upperBound, leftClosed, rightClosed, isEmpty,+ -- * Interval operations+ overlaps, subsumes, before, after,+ compareByUpper,+ -- * Point operations+ below, inside, above+ ) where++import Control.DeepSeq (NFData(rnf))++-- | Intervals with endpoints of type @a@.+--+-- 'Read' and 'Show' use mathematical notation with square brackets for closed+-- and parens for open intervals.+-- This is better for human readability, but is not a valid Haskell expression.+-- Closed intervals look like a list, open intervals look like a tuple,+-- and half-open intervals look like mismatched parens.+data Interval a = IntervalCO !a !a -- ^ Including lower bound, excluding upper+ | ClosedInterval !a !a -- ^ Closed at both ends+ | OpenInterval !a !a -- ^ Open at both ends+ | IntervalOC !a !a -- ^ Excluding lower bound, including upper+ deriving (Eq)++instance Show a => Show (Interval a) where+ showsPrec _ (IntervalCO a b) = showChar '[' . shows a . showChar ',' . shows b . showChar ')'+ showsPrec _ (ClosedInterval a b) = showChar '[' . shows a . showChar ',' . shows b . showChar ']'+ showsPrec _ (OpenInterval a b) = showChar '(' . shows a . showChar ',' . shows b . showChar ')'+ showsPrec _ (IntervalOC a b) = showChar '(' . shows a . showChar ',' . shows b . showChar ']'++instance Read a => Read (Interval a) where+ readsPrec _ = readParen False+ (\r -> [(ClosedInterval a b, w) | ("[", s) <- lex r,+ (a, t) <- reads s,+ (",", u) <- lex t,+ (b, v) <- reads u,+ ("]", w) <- lex v]+ +++ [(OpenInterval a b, w) | ("(", s) <- lex r,+ (a, t) <- reads s,+ (",", u) <- lex t,+ (b, v) <- reads u,+ (")", w) <- lex v]+ +++ [(IntervalCO a b, w) | ("[", s) <- lex r,+ (a, t) <- reads s,+ (",", u) <- lex t,+ (b, v) <- reads u,+ (")", w) <- lex v]+ +++ [(IntervalOC a b, w) | ("(", s) <- lex r,+ (a, t) <- reads s,+ (",", u) <- lex t,+ (b, v) <- reads u,+ ("]", w) <- lex v]+ )+++-- compare only the lower bound+compareL :: Ord a => Interval a -> Interval a -> Ordering+compareL (IntervalCO a _) (IntervalCO b _) = compare a b+compareL (IntervalCO a _) (ClosedInterval b _) = compare a b+compareL (IntervalCO a _) (OpenInterval b _) = if a <= b then LT else GT+compareL (IntervalCO a _) (IntervalOC b _) = if a <= b then LT else GT+compareL (ClosedInterval a _) (IntervalCO b _) = compare a b+compareL (ClosedInterval a _) (ClosedInterval b _) = compare a b+compareL (ClosedInterval a _) (OpenInterval b _) = if a <= b then LT else GT+compareL (ClosedInterval a _) (IntervalOC b _) = if a <= b then LT else GT+compareL (OpenInterval a _) (IntervalCO b _) = if a < b then LT else GT+compareL (OpenInterval a _) (ClosedInterval b _) = if a < b then LT else GT+compareL (OpenInterval a _) (OpenInterval b _) = compare a b+compareL (OpenInterval a _) (IntervalOC b _) = compare a b+compareL (IntervalOC a _) (IntervalCO b _) = if a < b then LT else GT+compareL (IntervalOC a _) (ClosedInterval b _) = if a < b then LT else GT+compareL (IntervalOC a _) (OpenInterval b _) = compare a b+compareL (IntervalOC a _) (IntervalOC b _) = compare a b+{-# INLINE compareL #-}++-- compare only the upper bound+compareU :: Ord a => Interval a -> Interval a -> Ordering+compareU (IntervalCO _ a) (IntervalCO _ b) = compare a b+compareU (IntervalCO _ a) (ClosedInterval _ b) = if a <= b then LT else GT+compareU (IntervalCO _ a) (OpenInterval _ b) = compare a b+compareU (IntervalCO _ a) (IntervalOC _ b) = if a <= b then LT else GT+compareU (ClosedInterval _ a) (IntervalCO _ b) = if a < b then LT else GT+compareU (ClosedInterval _ a) (ClosedInterval _ b) = compare a b+compareU (ClosedInterval _ a) (OpenInterval _ b) = if a < b then LT else GT+compareU (ClosedInterval _ a) (IntervalOC _ b) = compare a b+compareU (OpenInterval _ a) (IntervalCO _ b) = compare a b+compareU (OpenInterval _ a) (ClosedInterval _ b) = if a <= b then LT else GT+compareU (OpenInterval _ a) (OpenInterval _ b) = compare a b+compareU (OpenInterval _ a) (IntervalOC _ b) = if a <= b then LT else GT+compareU (IntervalOC _ a) (IntervalCO _ b) = if a < b then LT else GT+compareU (IntervalOC _ a) (ClosedInterval _ b) = compare a b+compareU (IntervalOC _ a) (OpenInterval _ b) = if a < b then LT else GT+compareU (IntervalOC _ a) (IntervalOC _ b) = compare a b+{-# INLINE compareU #-}++instance Ord a => Ord (Interval a) where+ compare a b = case compareL a b of+ EQ -> compareU a b+ r -> r++instance Functor Interval where+ fmap f (IntervalCO a b) = IntervalCO (f a) (f b)+ fmap f (ClosedInterval a b) = ClosedInterval (f a) (f b)+ fmap f (OpenInterval a b) = OpenInterval (f a) (f b)+ fmap f (IntervalOC a b) = IntervalOC (f a) (f b)++instance NFData a => NFData (Interval a) where+ rnf (IntervalCO a b) = rnf a `seq` rnf b+ rnf (ClosedInterval a b) = rnf a `seq` rnf b+ rnf (OpenInterval a b) = rnf a `seq` rnf b+ rnf (IntervalOC a b) = rnf a `seq` rnf b++-- | Like 'compare', but considering the upper bound first.+compareByUpper :: Ord a => Interval a -> Interval a -> Ordering+compareByUpper a b = case compareU a b of+ EQ -> compareL a b+ r -> r++-- | Get the lower bound.+lowerBound :: Interval a -> a+lowerBound (ClosedInterval lo _) = lo+lowerBound (OpenInterval lo _) = lo+lowerBound (IntervalCO lo _) = lo+lowerBound (IntervalOC lo _) = lo++-- | Get the upper bound.+upperBound :: Interval a -> a+upperBound (ClosedInterval _ hi) = hi+upperBound (OpenInterval _ hi) = hi+upperBound (IntervalCO _ hi) = hi+upperBound (IntervalOC _ hi) = hi+++-- | Is the interval empty?+isEmpty :: (Ord a) => Interval a -> Bool+isEmpty (ClosedInterval a b) = a > b+isEmpty iv = lowerBound iv >= upperBound iv++-- | Does the interval include its lower bound?+leftClosed :: Interval a -> Bool+leftClosed (ClosedInterval _ _) = True+leftClosed (IntervalCO _ _) = True+leftClosed _ = False++-- | Does the interval include its upper bound?+rightClosed :: Interval a -> Bool+rightClosed (ClosedInterval _ _) = True+rightClosed (IntervalOC _ _) = True+rightClosed _ = False+++-- | Do the two intervals overlap?+overlaps :: (Ord a) => Interval a -> Interval a -> Bool++overlaps (ClosedInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= hi2 && hi1 >= lo2+overlaps (ClosedInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (ClosedInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 >= lo2+overlaps (ClosedInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= hi2 && hi1 > lo2++overlaps (OpenInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (OpenInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (OpenInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (OpenInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 < hi2 && hi1 > lo2++overlaps (IntervalCO lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= hi2 && hi1 > lo2+overlaps (IntervalCO lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (IntervalCO lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (IntervalCO lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= hi2 && hi1 > lo2++overlaps (IntervalOC lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < hi2 && hi1 >= lo2+overlaps (IntervalOC lo1 hi1) (OpenInterval lo2 hi2) = lo1 < hi2 && hi1 > lo2+overlaps (IntervalOC lo1 hi1) (IntervalCO lo2 hi2) = lo1 < hi2 && hi1 >= lo2+overlaps (IntervalOC lo1 hi1) (IntervalOC lo2 hi2) = lo1 < hi2 && hi1 > lo2+++-- | Does the first interval completely contain the second?+subsumes :: (Ord a) => Interval a -> Interval a -> Bool++subsumes (ClosedInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (ClosedInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (ClosedInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (ClosedInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 >= hi2++subsumes (OpenInterval lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < lo2 && hi1 > hi2+subsumes (OpenInterval lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (OpenInterval lo1 hi1) (IntervalCO lo2 hi2) = lo1 < lo2 && hi1 >= hi2+subsumes (OpenInterval lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 > hi2++subsumes (IntervalCO lo1 hi1) (ClosedInterval lo2 hi2) = lo1 <= lo2 && hi1 > hi2+subsumes (IntervalCO lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (IntervalCO lo1 hi1) (IntervalCO lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (IntervalCO lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 > hi2++subsumes (IntervalOC lo1 hi1) (ClosedInterval lo2 hi2) = lo1 < lo2 && hi1 >= hi2+subsumes (IntervalOC lo1 hi1) (OpenInterval lo2 hi2) = lo1 <= lo2 && hi1 >= hi2+subsumes (IntervalOC lo1 hi1) (IntervalCO lo2 hi2) = lo1 < lo2 && hi1 >= hi2+subsumes (IntervalOC lo1 hi1) (IntervalOC lo2 hi2) = lo1 <= lo2 && hi1 >= hi2++-- | Interval strictly before another?+-- True if the upper bound of the first interval is below the lower bound of the second.+before :: Ord a => Interval a -> Interval a -> Bool+IntervalCO _ l `before` r = l <= lowerBound r+ClosedInterval _ l `before` IntervalCO r _ = l < r+ClosedInterval _ l `before` ClosedInterval r _ = l < r+ClosedInterval _ l `before` OpenInterval r _ = l <= r+ClosedInterval _ l `before` IntervalOC r _ = l <= r+OpenInterval _ l `before` r = l <= lowerBound r+IntervalOC _ l `before` IntervalCO r _ = l < r+IntervalOC _ l `before` ClosedInterval r _ = l < r+IntervalOC _ l `before` OpenInterval r _ = l <= r+IntervalOC _ l `before` IntervalOC r _ = l <= r+ +-- | Interval strictly after another?+-- Same as 'flip before'.+after :: Ord a => Interval a -> Interval a -> Bool+r `after` l = l `before` r+{-# INLINE after #-}+++-- | Does the interval contain a given point?+inside :: (Ord a) => a -> Interval a -> Bool+p `inside` (IntervalCO lo hi) = lo <= p && p < hi+p `inside` (ClosedInterval lo hi) = lo <= p && p <= hi+p `inside` (OpenInterval lo hi) = lo < p && p < hi+p `inside` (IntervalOC lo hi) = lo < p && p <= hi++-- | Is a point strictly less than lower bound?+below :: (Ord a) => a -> Interval a -> Bool+p `below` (IntervalCO l _) = p < l+p `below` (ClosedInterval l _) = p < l+p `below` (OpenInterval l _) = p <= l+p `below` (IntervalOC l _) = p <= l++-- | Is a point strictly greater than upper bound?+above :: (Ord a) => a -> Interval a -> Bool+p `above` (IntervalCO _ u) = p >= u+p `above` (ClosedInterval _ u) = p > u+p `above` (OpenInterval _ u) = p >= u+p `above` (IntervalOC _ u) = p > u
+ IntervalMap.cabal view
@@ -0,0 +1,39 @@+Name: IntervalMap+Version: 0.2.0+Synopsis: Maps from Intervals to values, with efficient search.+Homepage: http://www.chr-breitkopf.de/comp/IntervalMap+License: BSD3+License-file: LICENSE+Author: Christoph Breitkopf+Maintainer: Christoph Breitkopf <chbreitkopf@googlemail.com>+Copyright: Copyright 2011 Christoph Breitkopf+Category: Data+Build-type: Simple+Cabal-version: >=1.8+Description:+ A map from intervals to values, with efficient search+ for all keys containing a point or overlapping an interval.++extra-source-files:+ README+ test/*.hs+ examples/*.hs++Library+ Exposed-modules: Data.IntervalMap, Data.IntervalMap.Interval+ Build-depends: base >= 4 && < 5, containers, deepseq+ ghc-options: -Wall+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++Test-Suite TestInterval+ type: exitcode-stdio-1.0+ main-is: IntervalTests.hs+ hs-source-dirs: test+ build-depends: IntervalMap, base, QuickCheck, Cabal >= 1.9.2++Test-Suite TestIntervalMap+ type: exitcode-stdio-1.0+ main-is: IntervalMapTests.hs+ hs-source-dirs: test+ build-depends: IntervalMap, base, QuickCheck, Cabal >= 1.9.2
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Christoph Breitkopf++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Christoph Breitkopf nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,18 @@+Maps with intervals as keys offering efficient search.++Home page:+http://www.chr-breitkopf.de/comp/haskell/index.html#IntervalMap+++Install from hackage with cabal install.++To run the tests, do extract the archive, and do++$ cabal configure --enable-tests+$ cabal build+$ cabal test++--+Christoph Breitkopf <chbreitkopf@googlemail.com>+Last edit: 2011-12-09+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Example.hs view
@@ -0,0 +1,45 @@+import Data.IntervalMap as IM++type Person = String+type Details = String++-- For readability, represent timestamps as strings. Also, to keep it shorter,+-- we will only use time of the day in this example.+type Time = String+type TimeSpan = Interval Time++-- We have a time span include its start time but not its end time.+mkTimeSpan :: Time -> Time -> TimeSpan+mkTimeSpan from to = IntervalCO from to++type Appointments = IM.IntervalMap Time [(Person, Details)]++noAppointments :: Appointments+noAppointments = IM.empty++addAppointment :: Person -> Time -> Time -> Details -> Appointments -> Appointments+addAppointment who from to what apps = IM.insertWith (++) (mkTimeSpan from to) [(who, what)] apps++sampleApps :: Appointments+sampleApps = addAppointment "Paul" "09:00" "11:00" "Dentist" $+ addAppointment "John" "10:00" "11:30" "Meeting" $+ addAppointment "Rosy" "10:00" "11:30" "Shopping" $+ addAppointment "Lisa" "08:45" "09:15" "Bank" $+ noAppointments++appointmentsAt :: Time -> Appointments -> [(TimeSpan, Person, Details)]+appointmentsAt t apps = [ (ts, p, d) | (ts, ps) <- hits, (p,d) <- ps ]+ where+ hits :: [(TimeSpan, [(Person, Details)])]+ hits = apps `containing` t++appointmentsDuring :: Time -> Time -> Appointments -> [(TimeSpan, Person, Details)]+appointmentsDuring from to apps = [ (ts, p, d) | (ts, ps) <- hits, (p,d) <- ps ]+ where+ hits :: [(TimeSpan, [(Person, Details)])]+ hits = apps `intersecting` mkTimeSpan from to++main :: IO ()+main = do putStrLn (show (appointmentsAt "09:00" sampleApps))+ putStrLn (show (appointmentsDuring "09:30" "10:30" sampleApps))+ putStrLn (show (IM.toAscList sampleApps))
+ test/IntervalMapTests.hs view
@@ -0,0 +1,457 @@+-- module Data.IntervalMapTests (main) where++import System.Exit (exitSuccess, exitFailure)++import Test.QuickCheck+import Test.QuickCheck.Test (isSuccess)+import Data.List ((\\), sort, sortBy)+import Control.Monad (liftM, foldM)++import Data.IntervalMap as M+import Data.IntervalMap.Interval+++newtype IMI = IMI (IntervalMap Int Int) deriving (Show)+newtype II = II (Interval Int) deriving (Eq, Ord, Show)++instance Arbitrary II where+ arbitrary = do x <- arbitrary+ 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)]++instance Arbitrary IMI where+ arbitrary = do xs <- orderedList+ return (IMI (fromAscList [(v, lowerBound v) | (II v) <- xs]))+++emptyM, single46 :: M.IntervalMap Int String+emptyM = M.empty+single46 = M.singleton (ClosedInterval 4 6) "single46"+++prop_tests1 = + M.null emptyM &&+ 0 == M.size emptyM &&+ 1 == M.size single46 &&+ 0 == M.height emptyM &&+ 1 == M.height single46 &&+ 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+++bal3 :: M.IntervalMap Int String+bal3 = let m1 = M.insert (ClosedInterval 1 4) "14" single46+ 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++prop_tests2 =+ 3 == M.size bal3 &&+ 2 == M.height bal3 &&+ "single46" == bal3 M.! ClosedInterval 4 6 &&+ "14" == bal3 M.! ClosedInterval 1 4 &&+ "58" == bal3 M.! ClosedInterval 5 8 &&+ "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]+++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)++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)+++prop_tests3 =+ 68 == deep100L M.! (ClosedInterval 68 68) &&+ [17] == Prelude.map snd (deep100L `containing` 17) &&+ 100 == M.size deep100L &&+ (M.height deep100L <= 12) &&+ 68 == deep100R M.! (ClosedInterval 68 68) &&+ [17] == Prelude.map snd (deep100R `containing` 17) &&+ 100 == M.size deep100R &&+ (M.height deep100R <= 12) &&+ M.valid deep100L &&+ M.valid deep100R &&+ 99 == M.size (M.delete (ClosedInterval 23 23) deep100L) &&+ 99 == M.size (M.delete (ClosedInterval 23 23) deep100R) &&+ M.valid (M.delete (ClosedInterval 23 23) deep100L) &&+ 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))+ 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+ + + ++-- check that our generator yields valid maps.+prop_valid (IMI m) = M.valid m++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++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++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'++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'++prop_updateMin_u (IMI m) =+ let m' = M.updateMin (\v -> Just (v+1)) m in+ if M.null m then+ M.null m'+ else+ let (k, v) = M.findMin m+ (k', v') = M.findMin m'+ in+ M.valid m' &&+ M.size m' == M.size m &&+ k' == k &&+ v' == v + 1++prop_updateMin_d (IMI m) =+ let m' = M.updateMin (const Nothing) m in+ if M.null m then+ M.null m'+ else+ let (k,v) = M.findMin m in+ M.valid m' &&+ M.size m' == M.size m - 1 &&+ M.notMember k m'++prop_updateMax_u (IMI m) =+ let m' = M.updateMax (\v -> Just (v+1)) m in+ if M.null m then+ M.null m'+ else+ let (k, v) = M.findMax m+ (k', v') = M.findMax m'+ in+ M.valid m' &&+ M.size m' == M.size m &&+ k' == k &&+ v' == v + 1++prop_updateMax_d (IMI m) =+ let m' = M.updateMax (const Nothing) m in+ if M.null m then+ M.null m'+ else+ let (k,v) = M.findMax m in+ M.valid m' &&+ M.size m' == M.size m - 1 &&+ M.notMember k m'++prop_map (IMI m) = let m' = M.map (1+) m in+ M.valid m' &&+ M.size m' == M.size m &&+ all (\k -> m' M.! k == m M.! k + 1) (M.keys m)++prop_findWithDefault (IMI m) (II k) = M.findWithDefault (lowerBound k) k m == lowerBound k++prop_searchPoint (IMI m) p = sameElements (m `containing` p)+ [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]++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))++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))++prop_findLast (IMI m) = not (M.null m) ==>+ M.findLast m == head (sortBy cmp (M.toList m))+ where cmp (a,_) (b,_) = invert (compareByUpper a b)+ invert LT = GT+ invert GT = LT+ invert EQ = EQ+++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++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++prop_insertLookupWithKey (IMI m) (II i) v =+ case M.insertLookupWithKey (\k new old -> upperBound k + new + old) i v m of+ (Nothing, m') -> M.valid m' && M.notMember i m && m' M.! i == v+ (Just old, m') -> M.valid m' && m M.! i == old && m' M.! i == upperBound i + v + old++prop_insertLookupWithKey' (IMI m) (II i) v =+ case M.insertLookupWithKey' (\k new old -> upperBound k + new + old) i v m of+ (Nothing, m') -> M.valid m' && M.notMember i m && m' M.! i == v+ (Just old, m') -> M.valid m' && m M.! i == old && m' M.! i == upperBound i + v + old+++prop_foldr (IMI m) = M.foldr f z m == Prelude.foldr f z [ v | (_,v) <- M.toAscList m ]+ where z = []+ f = (:)++prop_adjust (II i) (IMI m) = let m' = M.adjust (13*) i m in+ 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++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++prop_alter (IMI m) (II k) = delete && insert+ where+ delete = let m' = M.alter (const Nothing) k m in M.valid m' && M.notMember k m'+ insert = let m' = M.alter (const (Just 4711)) k m in M.valid m' && M.lookup k m' == Just 4711+++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'+ 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++ 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++ numNotInM1 n [] = n+ numNotInM1 n (k:ks) | M.member k m1 = numNotInM1 n 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'+ 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+ numNotInM1 n [] = n+ numNotInM1 n (k:ks) | M.member k m1 = numNotInM1 n 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_difference (IMI m1) (IMI m2) = M.valid m' && m' == Prelude.foldr M.delete m1 (M.keys m2)+ where m' = m1 M.\\ m2++prop_intersection (IMI m1) (IMI m2) = M.valid m' && all inBoth (M.keys m')+ where+ m' = M.intersection m1 m2+ inBoth k = M.member k m1 && M.member k m2++prop_fromAscList :: [(II,Int)] -> Bool+prop_fromAscList lyst = M.valid m && all correctVal [k | (II k, _) <- lyst]+ where+ xs = sort [(k,v) | (II k,v) <- lyst]+ rs = reverse xs+ m = M.fromAscList xs+ correctVal k = case assoc k rs of+ Nothing -> False+ Just v -> m M.! k == v++assoc :: Eq k => k -> [(k,a)] -> Maybe a+assoc _ [] = Nothing+assoc k ((x,v):xs) | x == k = Just v+ | 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++-- filter++prop_filter (IMI m) = M.valid m' && all odd (M.elems m') && M.size m' == odds+ where+ m' = M.filter odd m+ 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+ 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)+ where+ (l, value, r) = splitLookup x 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+++check p name = do r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p+ if isSuccess r+ then return r+ else do putStrLn ("error: " ++ name ++ ": " ++ show r)+ exitFailure+++main :: IO ()+main = do+ check prop_tests1 "tests1"+ 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_within "within"+ check prop_findMin "findMin"+ check prop_findMax "findMax"+ 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_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"+ putStrLn ("deep100L: " ++ show (M.showStats deep100L))+ putStrLn ("deep100R: " ++ show (M.showStats deep100R))+ exitSuccess++-- Utils -----------------++equalMap :: (Eq a) => [a] -> IntervalMap k a -> Bool+equalMap xs m = sameElements xs (M.elems m)++sameElements :: Eq a => [a] -> [a] -> Bool+sameElements [] [] = True+sameElements [] (_:_) = False+sameElements (x:xs) ys = case tryRemove x ys of+ 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')
+ test/IntervalTests.hs view
@@ -0,0 +1,155 @@+-- module IntervalTests (main) where++import System.Exit (exitSuccess, exitFailure)++import Test.QuickCheck+import Test.QuickCheck.Test (isSuccess)+import Control.Monad (liftM)++import Data.IntervalMap.Interval+++c15, o15, co15, oc15 :: Interval Int+c15 = ClosedInterval 1 5+o15 = OpenInterval 1 5+co15 = IntervalCO 1 5+oc15 = IntervalOC 1 5+++prop_boundsC, prop_boundsO, prop_boundsCO, prop_boundsOC :: Int -> Int -> Bool+prop_boundsC lo hi = let iv = ClosedInterval lo hi in lowerBound iv == lo && upperBound iv == hi+prop_boundsO lo hi = let iv = OpenInterval lo hi in lowerBound iv == lo && upperBound iv == hi+prop_boundsCO lo hi = let iv = IntervalCO lo hi in lowerBound iv == lo && upperBound iv == hi+prop_boundsOC lo hi = let iv = IntervalOC lo hi in lowerBound iv == lo && upperBound iv == hi++prop_empty = + isEmpty (OpenInterval 1 1) &&+ isEmpty (IntervalCO 1 1) &&+ isEmpty (IntervalOC 1 1) &&+ not (isEmpty (ClosedInterval 1 1))++prop_ord =+ ClosedInterval 1 2 < OpenInterval 1 2 &&+ ClosedInterval 2 3 > OpenInterval 1 2+ ++contains :: Ord a => Interval a -> a -> Bool+contains = flip inside++prop_contains1 =+ (c15 `contains` 3) &&+ (o15 `contains` 3) &&+ (co15 `contains` 3) &&+ (oc15 `contains` 3) &&+ (c15 `contains` 1) &&+ (c15 `contains` 5) &&+ not (o15 `contains` 1) &&+ not (o15 `contains` 5) &&+ (co15 `contains` 1) &&+ not (co15 `contains` 5) &&+ not (oc15 `contains` 1) &&+ (oc15 `contains` 5)+++prop_overlaps = + (c15 `overlaps` ClosedInterval 5 6) &&+ not (c15 `overlaps` OpenInterval 5 6) &&+ (c15 `overlaps` IntervalCO 5 6) &&+ not (c15 `overlaps` IntervalOC 5 6) &&+ (c15 `overlaps` ClosedInterval 0 1) &&+ not (c15 `overlaps` OpenInterval 0 1) &&+ (c15 `overlaps` IntervalOC 0 1) &&+ not (c15 `overlaps` IntervalCO 0 1)++prop_subsumes1 = (c15 `subsumes` o15) && -- closed subsumes open+ not (o15 `subsumes` c15) && -- ~? "open does not subsume closed",+ not (co15 `subsumes` c15) && -- "open does not subsume closed",+ not (oc15 `subsumes` c15) -- "open does not subsume closed"++ivGen :: Int -> Int -> Gen II+ivGen lo hi = do start <- choose (lo, hi)+ size <- choose (0, hi - start)+ if size == 0+ then return (II (ClosedInterval start start))+ else oneof [+ return (II (ClosedInterval start (start + size))),+ return (II (OpenInterval start (start + size))),+ return (II (IntervalCO start (start + size))),+ return (II (IntervalOC start (start + size))) ]++newtype II = II (Interval Int) deriving (Show)++instance Arbitrary II where+ arbitrary = do x <- arbitrary+ liftM II (interval (abs x))++interval x = do+ y <- sized (\n -> choose (x, x + abs n))+ if x == y then return (ClosedInterval x y)+ else oneof [return (ClosedInterval x y),+ return (OpenInterval x y),+ return (IntervalCO x y),+ return (IntervalOC x y)]++-- our generator will never generate empty intervals+prop_not_empty (II iv) = not (isEmpty iv)++prop_leftClosed = leftClosed (ClosedInterval 1 2) &&+ leftClosed (IntervalCO 1 2) &&+ not (leftClosed (OpenInterval 1 2)) &&+ not (leftClosed (IntervalOC 1 2))++prop_rightClosed = rightClosed (ClosedInterval 1 2) &&+ rightClosed (IntervalOC 1 2) &&+ not (rightClosed (OpenInterval 1 2)) &&+ not (rightClosed (IntervalCO 1 2))+++prop_overlaps_symmetric (II i1) (II i2) = (i1 `overlaps` i2) == (i2 `overlaps` i1)++prop_compare1 (II i1) (II i2) =+ case compare (lowerBound i1) (lowerBound i2) of+ LT -> compare i1 i2 == LT+ GT -> compare i1 i2 == GT+ EQ -> True++prop_contains (II i) p =+ if p `inside` i then+ lowerBound i <= p && upperBound i >= p+ else+ p <= lowerBound i || p >= upperBound i++prop_subsumes (II i1) = forAll subIv (\(II i2) -> (i1 `subsumes` i2) ==>+ ((i1 == i2) || not (i2 `subsumes` i1)))+ where+ subIv = ivGen (lowerBound i1) (upperBound i1)+ +prop_equals (II a) (II b) =+ (lowerBound a /= lowerBound b || upperBound a /= upperBound b) ==> (a /= b)++check p name = do r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p+ if isSuccess r+ then return r+ else do putStrLn ("error: " ++ name ++ ": " ++ show r)+ exitFailure+++main = do+ check prop_boundsO "boundsO"+ check prop_boundsC "boundsC"+ check prop_boundsOC "boundsOC"+ check prop_boundsCO "boundsCO"+ check prop_empty "empty"+ check prop_leftClosed "leftClosed"+ check prop_rightClosed "rightClosed"+ check prop_ord "ord"+ check prop_compare1 "compare1"+ check prop_contains1 "contains1"+ check prop_overlaps "overlaps"+ check prop_subsumes1 "subsumes1"+ check prop_not_empty "not empty"+ check prop_overlaps_symmetric "overlaps symmetric"+ check prop_contains "contains"+ check prop_subsumes "subsumes"+ check prop_equals "equals"+ exitSuccess