diff --git a/Data/IntervalMap/Base.hs b/Data/IntervalMap/Base.hs deleted file mode 100644 --- a/Data/IntervalMap/Base.hs +++ /dev/null @@ -1,1230 +0,0 @@ --- | --- Module : Data.IntervalMap.Base --- Copyright : (c) Christoph Breitkopf 2011 --- License : BSD-style --- Maintainer : chbreitkopf@gmail.com --- Stability : experimental --- Portability : portable --- --- An implementation of maps from intervals to values. The key intervals may --- overlap, and the implementation contains efficient search functions --- for all keys containing a point or overlapping an interval. --- Closed, open, and half-open intervals can be contained in the same map. --- --- An IntervalMap cannot contain duplicate keys - if you need to map a key --- to muiltiple values, use a collection as the value type, for --- example: @IntervalMap /k/ [/v/]@. --- --- It is an error to insert an empty interval into a map. This precondition is not --- checked by the various construction functions. --- --- Since many function names (but not the type name) clash with --- /Prelude/ names, this module is usually imported @qualified@, e.g. --- --- > import Data.IntervalMap (IvMap) --- > import qualified Data.IntervalMap as IvMap --- --- It offers most of the same functions as 'Data.Map', but uses 'Interval' /k/ instead of --- just /k/ as the key type. Some of the functions need stricter type constraints to --- maintain the additional information for efficient interval searching, --- for example 'fromDistinctAscList' needs an 'Ord' /k/ constraint. --- Also, some functions differ in asymptotic performance (for example 'size') or have not --- been tuned for efficiency as much as their equivalents in 'Data.Map' (in --- particular the various set functions). --- --- In addition, there are functions specific to maps of intervals, for example to search --- for all keys containing a given point or contained in a given interval. --- --- To stay compatible with standard Haskell, this implementation uses a fixed data --- type for intervals, and not a multi-parameter type class. Thus, it's currently --- not possible to define e.g. a 2-tuple as an instance of interval and use that --- map key. Instead, you must convert your keys to 'Interval'. --- --- The implementation is a red-black tree augmented with the maximum upper bound --- of all keys. --- --- Parts of this implementation are based on code from the 'Data.Map' implementation, --- (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008. --- The red-black tree deletion is based on code from llrbtree by Kazu Yamamoto. --- Of course, any errors are mine. --- -module Data.IntervalMap.Base ( - -- * re-export - Interval(..) - -- * Map type - , IntervalMap(..) -- instance Eq,Show,Read - - -- * Operators - , (!), (\\) - - -- * Query - , null - , size - , member - , notMember - , lookup - , findWithDefault - - -- ** Interval query - , containing - , intersecting - , within - - -- * Construction - , empty - , singleton - - -- ** Insertion - , insert - , insertWith - , insertWithKey - , insertLookupWithKey - - -- ** Delete\/Update - , delete - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - - -- * Combine - - -- ** Union - , union - , unionWith - , unionWithKey - , unions - , unionsWith - - -- ** Difference - , difference - , differenceWith - , differenceWithKey - - -- ** Intersection - , intersection - , intersectionWith - , intersectionWithKey - - -- * Traversal - -- ** Map - , map - , mapWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeys - , mapKeysWith - , mapKeysMonotonic - - -- ** Fold - , foldr, foldl - , foldrWithKey, foldlWithKey - , foldl', foldr' - , foldrWithKey', foldlWithKey' - - -- * Conversion - , elems - , keys - , keysSet - , assocs - - -- ** Lists - , toList - , fromList - , fromListWith - , fromListWithKey - - -- ** Ordered lists - , toAscList - , toDescList - , fromAscList - , fromAscListWith - , fromAscListWithKey - , fromDistinctAscList - - -- * Filter - , filter - , filterWithKey - , partition - , partitionWithKey - - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - - , split - , splitLookup - - -- * Submap - , isSubmapOf, isSubmapOfBy - , isProperSubmapOf, isProperSubmapOfBy - - -- * Min\/Max - , findMin - , findMax - , findLast - , deleteMin - , deleteMax - , deleteFindMin - , deleteFindMax - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - , minView - , maxView - , minViewWithKey - , maxViewWithKey - - -- * Internal, not re-exported by Data.IntervalMap.{Lazy,Strict} - , Color(..) - , balanceL, balanceR - , turnBlack - , setMinValue, setMaxValue - - -- * Debugging - , valid - - -- * Testing - , height, maxHeight, showStats - - ) where - -import Prelude hiding (null, lookup, map, filter, foldr, foldl) -import Data.Bits (shiftR, (.&.)) -import Data.Monoid (Monoid(..)) -import Control.Applicative (Applicative(..), (<$>)) -import Data.Traversable (Traversable(traverse)) -import qualified Data.Foldable as Foldable -import qualified Data.List as L -import qualified Data.Set as Set -import Control.DeepSeq (NFData(rnf)) - -import Data.IntervalMap.Interval - -{-------------------------------------------------------------------- - Operators ---------------------------------------------------------------------} -infixl 9 !,\\ -- - --- | /O(log n)/. Lookup value for given key. Calls 'error' if the key is not in the map. -(!) :: (Ord k) => IntervalMap k v -> Interval k -> v -tree ! key = case lookup key tree of - Just v -> v - Nothing -> error "IntervalMap.!: key not found" - --- | Same as 'difference'. -(\\) :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a -m1 \\ m2 = difference m1 m2 - - -data Color = R | B deriving (Eq, Read, Show) - --- | A map from intervals with endpoints of type @k@ to values of type @v@. -data IntervalMap k v = Nil - | Node !Color - !(Interval k) -- key - !(Interval k) -- interval with maximum upper in tree - v -- value - !(IntervalMap k v) -- left subtree - !(IntervalMap k v) -- right subtree - -instance (Eq k, Eq v) => Eq (IntervalMap k v) where - a == b = toAscList a == toAscList b - -instance (Ord k, Ord v) => Ord (IntervalMap k v) where - compare a b = compare (toAscList a) (toAscList b) - -instance Functor (IntervalMap k) where - fmap f m = map f m - -instance (Ord k) => Monoid (IntervalMap k v) where - mempty = empty - mappend = union - mconcat = unions - -instance Traversable (IntervalMap k) where - traverse _ Nil = pure Nil - traverse f (Node c k m v l r) - = flip (Node c k m) <$> traverse f l <*> f v <*> traverse f r - -instance Foldable.Foldable (IntervalMap k) where - fold Nil = mempty - fold (Node _ _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r - foldr = foldr - foldl = foldl - foldMap _ Nil = mempty - foldMap f (Node _ _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r - -instance (NFData k, NFData a) => NFData (IntervalMap k a) where - rnf Nil = () - rnf (Node _ kx _ x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r - -instance (Ord k, Read k, Read e) => Read (IntervalMap k e) where - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromList",s) <- lex r - (xs,t) <- reads s - return (fromList xs,t) - -instance (Show k, Show a) => Show (IntervalMap k a) where - showsPrec d m = showParen (d > 10) $ - showString "fromList " . shows (toList m) - - -isRed :: IntervalMap k v -> Bool -isRed (Node R _ _ _ _ _) = True -isRed _ = False - -turnBlack :: IntervalMap k v -> IntervalMap k v -turnBlack (Node R k m vs l r) = Node B k m vs l r -turnBlack t = t - -turnRed :: IntervalMap k v -> IntervalMap k v -turnRed Nil = error "turnRed: Leaf" -turnRed (Node B k m v l r) = Node R k m v l r -turnRed t = t - --- construct node, recomputing the upper key bound. -mNode :: (Ord k) => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v -mNode c k v l r = Node c k (maxUpper k l r) v l r - -maxUpper :: Ord k => Interval k -> IntervalMap k v -> IntervalMap k v -> Interval k -maxUpper k Nil Nil = k `seq` k -maxUpper k Nil (Node _ _ m _ _ _) = maxByUpper k m -maxUpper k (Node _ _ m _ _ _) Nil = maxByUpper k m -maxUpper k (Node _ _ l _ _ _) (Node _ _ r _ _ _) = maxByUpper k (maxByUpper l r) - --- interval with the greatest upper bound. The lower bound is ignored! -maxByUpper :: Ord a => Interval a -> Interval a -> Interval a -maxByUpper a@(IntervalCO _ u) b = if u > upperBound b then a else b -maxByUpper a@(ClosedInterval _ u) b = if u >= upperBound b then a else b -maxByUpper a@(OpenInterval _ u) b = if u > upperBound b then a else b -maxByUpper a@(IntervalOC _ u) b = if u >= upperBound b then a else b - - --- --------------------------------------------------------- - --- | /O(1)/. The empty map. -empty :: IntervalMap k v -empty = Nil - --- | /O(1)/. A map with one entry. -singleton :: Interval k -> v -> IntervalMap k v -singleton k v = Node B k k v Nil Nil - - --- | /O(1)/. Is the map empty? -null :: IntervalMap k v -> Bool -null Nil = True -null _ = False - --- | /O(n)/. Number of keys in the map. --- --- Caution: unlike 'Data.Map.size', which takes constant time, this is linear in the --- number of keys! -size :: IntervalMap k v -> Int -size t = h 0 t - where - h n m = n `seq` case m of - Nil -> n - Node _ _ _ _ l r -> h (h n l + 1) r - --- | The height of the tree. For testing/debugging only. -height :: IntervalMap k v -> Int -height Nil = 0 -height (Node _ _ _ _ l r) = 1 + max (height l) (height r) - --- | The maximum height of a red-black tree with the given number of nodes. --- For testing/debugging only. -maxHeight :: Int -> Int -maxHeight nodes = 2 * log2 (nodes + 1) - --- | Tree statistics (size, height, maxHeight size). --- For testing/debugging only. -showStats :: IntervalMap k a -> (Int, Int, Int) -showStats m = (n, height m, maxHeight n) - where n = size m - --- | /O(log n)/. Does the map contain the given key? See also 'notMember'. -member :: (Ord k) => Interval k -> IntervalMap k v -> Bool -member key tree = case lookup key tree of - Nothing -> False - Just _ -> True - --- | /O(log n)/. Does the map not contain the given key? See also 'member'. -notMember :: (Ord k) => Interval k -> IntervalMap k v -> Bool -notMember key tree = not (member key tree) - - --- | /O(log n)/. Look up the given key in the map, returning the value @('Just' value)@, --- or 'Nothing' if the key is not in the map. -lookup :: (Ord k) => Interval k -> IntervalMap k v -> Maybe v -lookup k Nil = k `seq` Nothing -lookup k (Node _ key _ v l r) = case compare k key of - LT -> lookup k l - GT -> lookup k r - EQ -> Just v - - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns default value @def@ --- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' --- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' - -findWithDefault :: Ord k => a -> Interval k -> IntervalMap k a -> a -findWithDefault def k m = case lookup k m of - Nothing -> def - Just x -> x - --- | Return all key/value pairs where the key intervals contain the given point. --- The elements are returned in ascending key order. --- --- /O(n)/, since potentially all keys could contain the point. --- /O(log n)/ average case. This is also the worst case for maps containing no overlapping keys. -containing :: (Ord k) => IntervalMap k v -> k -> [(Interval k, v)] -t `containing` pt = go [] pt t - where - go xs p Nil = p `seq` xs - go xs p (Node _ k m v l r) - | p `above` m = xs -- above all intervals in the tree: no result - | p `below` k = go xs p l -- to the left of the lower bound: can't be in right subtree - | p `inside` k = go ((k,v) : go xs p r) p l - | otherwise = go (go xs p r) p l - --- | Return all key/value pairs where the key intervals overlap (intersect) the given interval. --- The elements are returned in ascending key order. --- --- /O(n)/, since potentially all keys could intersect the interval. --- /O(log n)/ average case, if few keys intersect the interval. -intersecting :: (Ord k) => IntervalMap k v -> Interval k -> [(Interval k, v)] -t `intersecting` iv = go [] iv t - where - go xs i Nil = i `seq` xs - go xs i (Node _ k m v l r) - | i `after` m = xs - | i `before` k = go xs i l - | i `overlaps` k = go ((k,v) : go xs i r) i l - | otherwise = go (go xs i r) i l - --- | Return all key/value pairs where the key intervals are completely inside the given interval. --- The elements are returned in ascending key order. --- --- /O(n)/, since potentially all keys could be inside the interval. --- /O(log n)/ average case, if few keys are inside the interval. -within :: (Ord k) => IntervalMap k v -> Interval k -> [(Interval k, v)] -t `within` iv = go [] iv t - where - go xs i Nil = i `seq` xs - go xs i (Node _ k m v l r) - | i `after` m = xs - | i `before` k = go xs i l - | i `subsumes` k = go ((k,v) : go xs i r) i l - | otherwise = go (go xs i r) i l - - --- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is --- changed to the new value. -insert :: (Ord k) => Interval k -> v -> IntervalMap k v -> IntervalMap k v -insert = insertWithKey (\_ v _ -> v) - --- | /O(log n)/. Insert with a function, combining new value and old value. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key, f new_value old_value)@. -insertWith :: (Ord k) => (v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -insertWith f = insertWithKey (\_ new old -> f new old) - --- | /O(log n)/. Insert with a function, combining key, new value and old value. --- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key, f key new_value old_value)@. --- Note that the key passed to f is the same key passed to 'insertWithKey'. -insertWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -insertWithKey f key value mp = key `seq` turnBlack (ins mp) - where - singletonR k v = Node R k k v Nil Nil - ins Nil = singletonR key value - ins (Node color k m v l r) = - case compare key k of - LT -> balanceL color k v (ins l) r - GT -> balanceR color k v l (ins r) - EQ -> Node color k m (f k value v) l r - --- | /O(log n)/. Combine insert with old values retrieval. -insertLookupWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v) -insertLookupWithKey f key value mp = key `seq` (oldval, turnBlack mp') - where - (oldval, mp') = ins mp - singletonR k v = Node R k k v Nil Nil - ins Nil = (Nothing, singletonR key value) - ins (Node color k m v l r) = - case compare key k of - LT -> case ins l of - (x@(Just _), t') -> (x, Node color k m v t' r) - (Nothing, t') -> (Nothing, balanceL color k v t' r) - GT -> case ins r of - (x@(Just _), t') -> (x, Node color k m v l t') - (Nothing, t') -> (Nothing, balanceR color k v l t') - EQ -> (Just v, Node color k m (f k value v) l r) - - -balanceL :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v -balanceL B zk zv (Node R yk _ yv (Node R xk _ xv a b) c) d = - mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) -balanceL B zk zv (Node R xk _ xv a (Node R yk _ yv b c)) d = - mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) -balanceL c xk xv l r = mNode c xk xv l r - -balanceR :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v -balanceR B xk xv a (Node R yk _ yv b (Node R zk _ zv c d)) = - mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) -balanceR B xk xv a (Node R zk _ zv (Node R yk _ yv b c) d) = - mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) -balanceR c xk xv l r = mNode c xk xv l r - - --- min/max - --- | /O(log n)/. Returns the smallest key and its associated value. --- Calls 'error' if the map is empty. -findMin :: IntervalMap k v -> (Interval k, v) -findMin (Node _ k _ v Nil _) = (k,v) -findMin (Node _ _ _ _ l _) = findMin l -findMin Nil = error "IntervalMap.findMin: empty map" - --- | /O(log n)/. Returns the largest key and its associated value. --- Calls 'error' if the map is empty. -findMax :: IntervalMap k v -> (Interval k, v) -findMax (Node _ k _ v _ Nil) = (k,v) -findMax (Node _ _ _ _ _ r) = findMax r -findMax Nil = error "IntervalMap.findMin: empty map" - --- | Returns the interval with the largest endpoint. --- If there is more than one interval with that endpoint, --- return the rightmost. --- --- /O(n)/, since all keys could have the same endpoint. --- /O(log n)/ average case. -findLast :: Eq k => IntervalMap k v -> (Interval k, v) -findLast Nil = error "IntervalMap.findLast: empty map" -findLast t@(Node _ _ mx _ _ _) = lastMax - where - (lastMax : _) = go t - go Nil = [] - go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ ((k,v) : go l) - else go r ++ go l - | otherwise = [] - sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b - - --- Type to indicate whether the number of black nodes changed or stayed the same. -data DeleteResult k v = U !(IntervalMap k v) -- Unchanged - | S !(IntervalMap k v) -- Shrunk - -unwrap :: DeleteResult k v -> IntervalMap k v -unwrap (U m) = m -unwrap (S m) = m - --- DeleteResult with value -data DeleteResult' k v a = U' !(IntervalMap k v) a - | S' !(IntervalMap k v) a - -unwrap' :: DeleteResult' k v a -> IntervalMap k v -unwrap' (U' m _) = m -unwrap' (S' m _) = m - --- annotate DeleteResult with value -annotate :: DeleteResult k v -> a -> DeleteResult' k v a -annotate (U m) x = U' m x -annotate (S m) x = S' m x - - --- | /O(log n)/. Remove the smallest key from the map. Return the empty map if the map is empty. -deleteMin :: (Ord k) => IntervalMap k v -> IntervalMap k v -deleteMin Nil = Nil -deleteMin m = turnBlack (unwrap' (deleteMin' m)) - -deleteMin' :: Ord k => IntervalMap k v -> DeleteResult' k v (Interval k, v) -deleteMin' Nil = error "deleteMin': Nil" -deleteMin' (Node B k _ v Nil Nil) = S' Nil (k,v) -deleteMin' (Node B k _ v Nil r@(Node R _ _ _ _ _)) = U' (turnBlack r) (k,v) -deleteMin' (Node R k _ v Nil r) = U' r (k,v) -deleteMin' (Node c k _ v l r) = - case deleteMin' l of - (U' l' kv) -> U' (mNode c k v l' r) kv - (S' l' kv) -> annotate (unbalancedR c k v l' r) kv - -deleteMax' :: Ord k => IntervalMap k v -> DeleteResult' k v (Interval k, v) -deleteMax' Nil = error "deleteMax': Nil" -deleteMax' (Node B k _ v Nil Nil) = S' Nil (k,v) -deleteMax' (Node B k _ v l@(Node R _ _ _ _ _) Nil) = U' (turnBlack l) (k,v) -deleteMax' (Node R k _ v l Nil) = U' l (k,v) -deleteMax' (Node c k _ v l r) = - case deleteMax' r of - (U' r' kv) -> U' (mNode c k v l r') kv - (S' r' kv) -> annotate (unbalancedL c k v l r') kv - --- The left tree lacks one Black node -unbalancedR :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v --- Decreasing one Black node in the right -unbalancedR B k v l r@(Node B _ _ _ _ _) = S (balanceR B k v l (turnRed r)) -unbalancedR R k v l r@(Node B _ _ _ _ _) = U (balanceR B k v l (turnRed r)) --- Taking one Red node from the right and adding it to the right as Black -unbalancedR B k v l (Node R rk _ rv rl@(Node B _ _ _ _ _) rr) - = U (mNode B rk rv (balanceR B k v l (turnRed rl)) rr) -unbalancedR _ _ _ _ _ = error "unbalancedR" - -unbalancedL :: Ord k => Color -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v -unbalancedL R k v l@(Node B _ _ _ _ _) r = U (balanceL B k v (turnRed l) r) -unbalancedL B k v l@(Node B _ _ _ _ _) r = S (balanceL B k v (turnRed l) r) -unbalancedL B k v (Node R lk _ lv ll lr@(Node B _ _ _ _ _)) r - = U (mNode B lk lv ll (balanceL B k v (turnRed lr) r)) -unbalancedL _ _ _ _ _ = error "unbalancedL" - - - --- | /O(log n)/. Remove the largest key from the map. Return the empty map if the map is empty. -deleteMax :: (Ord k) => IntervalMap k v -> IntervalMap k v -deleteMax Nil = Nil -deleteMax m = turnBlack (unwrap' (deleteMax' m)) - --- | /O(log n)/. Delete and return the smallest key. -deleteFindMin :: (Ord k) => IntervalMap k v -> ((Interval k,v), IntervalMap k v) -deleteFindMin mp = case deleteMin' mp of - (U' r v) -> (v, turnBlack r) - (S' r v) -> (v, turnBlack r) - --- | /O(log n)/. Delete and return the largest key. -deleteFindMax :: (Ord k) => IntervalMap k v -> ((Interval k,v), IntervalMap k v) -deleteFindMax mp = case deleteMax' mp of - (U' r v) -> (v, turnBlack r) - (S' r v) -> (v, turnBlack r) - --- | /O(log n)/. Update or delete value at minimum key. -updateMin :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMin f m = updateMinWithKey (\_ v -> f v) m - --- | /O(log n)/. Update or delete value at maximum key. -updateMax :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMax f m = updateMaxWithKey (\_ v -> f v) m - --- | /O(log n)/. Update or delete value at minimum key. -updateMinWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMinWithKey _ Nil = Nil -updateMinWithKey f m = let (k,v) = findMin m in - case f k v of - Just v' -> setMinValue v' m - Nothing -> deleteMin m - --- | /O(log n)/. Update or delete value at maximum key. -updateMaxWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMaxWithKey _ Nil = Nil -updateMaxWithKey f m = let (k,v) = findMax m in - case f k v of - Just v' -> setMaxValue v' m - Nothing -> deleteMax m - --- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and --- the map stripped of that element, or 'Nothing' if passed an empty map. --- --- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") --- > minViewWithKey empty == Nothing - -minViewWithKey :: Ord k => IntervalMap k a -> Maybe ((Interval k, a), IntervalMap k a) -minViewWithKey Nil = Nothing -minViewWithKey x = Just (deleteFindMin x) - --- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and --- the map stripped of that element, or 'Nothing' if passed an empty map. -maxViewWithKey :: Ord k => IntervalMap k a -> Maybe ((Interval k, a), IntervalMap k a) -maxViewWithKey Nil = Nothing -maxViewWithKey x = Just (deleteFindMax x) - --- | /O(log n)/. Retrieves the value associated with minimal key of the --- map, and the map stripped of that element, or 'Nothing' if passed an --- empty map. -minView :: Ord k => IntervalMap k a -> Maybe (a, IntervalMap k a) -minView Nil = Nothing -minView x = case deleteFindMin x of ((_,a), x') -> Just (a, x') - --- | /O(log n)/. Retrieves the value associated with maximal key of the --- map, and the map stripped of that element, or 'Nothing' if passed an --- empty map. -maxView :: Ord k => IntervalMap k a -> Maybe (a, IntervalMap k a) -maxView Nil = Nothing -maxView x = case deleteFindMax x of ((_,a), x') -> Just (a, x') - - -setMinValue :: v -> IntervalMap k v -> IntervalMap k v -setMinValue _ Nil = Nil -setMinValue v' (Node c k m _ Nil r) = Node c k m v' Nil r -setMinValue v' (Node c k m v l r) = Node c k m v (setMinValue v' l) r - -setMaxValue :: v -> IntervalMap k v -> IntervalMap k v -setMaxValue _ Nil = Nil -setMaxValue v' (Node c k m _ l Nil) = Node c k m v' l Nil -setMaxValue v' (Node c k m v l r) = Node c k m v l (setMaxValue v' r) - - - --- folding - --- | /O(n)/. Fold the values in the map using the given right-associative --- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. -foldr :: (a -> b -> b) -> b -> IntervalMap k a -> b -foldr _ z Nil = z -foldr f z (Node _ _ _ x l r) = foldr f (f x (foldr f z r)) l - --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldr' :: (a -> b -> b) -> b -> IntervalMap k a -> b -foldr' f z m = z `seq` case m of - Nil -> z - Node _ _ _ x l r -> foldr' f (f x (foldr' f z r)) l - --- | /O(n)/. Fold the values in the map using the given left-associative --- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. -foldl :: (b -> a -> b) -> b -> IntervalMap k a -> b -foldl _ z Nil = z -foldl f z (Node _ _ _ x l r) = foldl f (f (foldl f z l) x) r - --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldl' :: (b -> a -> b) -> b -> IntervalMap k a -> b -foldl' f z m = z `seq` case m of - Nil -> z - Node _ _ _ x l r -> foldl' f (f (foldl' f z l) x) r - --- | /O(n)/. Fold the keys and values in the map using the given right-associative --- binary operator, such that --- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. -foldrWithKey :: (Interval k -> v -> a -> a) -> a -> IntervalMap k v -> a -foldrWithKey _ z Nil = z -foldrWithKey f z (Node _ k _ x l r) = foldrWithKey f (f k x (foldrWithKey f z r)) l - --- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldrWithKey' :: (Interval k -> v -> a -> a) -> a -> IntervalMap k v -> a -foldrWithKey' f z m = z `seq` case m of - Nil -> z - Node _ k _ x l r -> foldrWithKey' f (f k x (foldrWithKey' f z r)) l - --- | /O(n)/. Fold the keys and values in the map using the given left-associative --- binary operator, such that --- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. -foldlWithKey :: (a -> Interval k -> v -> a) -> a -> IntervalMap k v -> a -foldlWithKey _ z Nil = z -foldlWithKey f z (Node _ k _ x l r) = foldlWithKey f (f (foldlWithKey f z l) k x) r - --- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is --- evaluated before using the result in the next application. This --- function is strict in the starting value. -foldlWithKey' :: (a -> Interval k -> v -> a) -> a -> IntervalMap k v -> a -foldlWithKey' f z m = z `seq` case m of - Nil -> z - Node _ k _ x l r -> foldlWithKey' f (f (foldlWithKey' f z l) k x) r - --- delete - --- | /O(log n)/. Delete a key from the map. If the map does not contain the key, --- it is returned unchanged. -delete :: (Ord k) => Interval k -> IntervalMap k v -> IntervalMap k v -delete key mp = turnBlack (unwrap (delete' key mp)) - -delete' :: Ord k => Interval k -> IntervalMap k v -> DeleteResult k v -delete' x Nil = x `seq` U Nil -delete' x (Node c k _ v l r) = - case compare x k of - LT -> case delete' x l of - (U l') -> U (mNode c k v l' r) - (S l') -> unbalancedR c k v l' r - GT -> case delete' x r of - (U r') -> U (mNode c k v l r') - (S r') -> unbalancedL c k v l r' - EQ -> case r of - Nil -> if c == B then blackify l else U l - _ -> case deleteMin' r of - (U' r' (rk,rv)) -> U (mNode c rk rv l r') - (S' r' (rk,rv)) -> unbalancedL c rk rv l r' - -blackify :: IntervalMap k v -> DeleteResult k v -blackify (Node R k m v l r) = U (Node B k m v l r) -blackify s = S s - --- | /O(log n)/. Update a value at a specific key with the result of the provided function. --- When the key is not --- a member of the map, the original map is returned. -adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a -adjust f k m = adjustWithKey (\_ v -> f v) k m - --- | /O(log n)/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. -adjustWithKey :: Ord k => (Interval k -> a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a -adjustWithKey _ _ Nil = Nil -adjustWithKey f x (Node c k m v l r) = - case compare x k of - LT -> Node c k m v (adjustWithKey f x l) r - GT -> Node c k m v l (adjustWithKey f x r) - EQ -> Node c k m (f k v) l r - --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a -update f k m = updateWithKey (\_ v -> f v) k m - --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the --- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', --- the element is deleted. If it is (@'Just' y@), the key @k@ is bound --- to the new value @y@. -updateWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a -updateWithKey f k m = snd (updateLookupWithKey f k m) - --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. --- The function returns changed value, if it is updated. --- Returns the original key value if the map entry is deleted. -updateLookupWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> (Maybe a, IntervalMap k a) -updateLookupWithKey f x m = case lookup x m of - Nothing -> (Nothing, m) - r@(Just v) -> case f x v of - Nothing -> (r, delete x m) - r'@(Just v') -> (r', adjust (const v') x m) - --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. --- 'alter' can be used to insert, delete, or update a value in a 'Map'. --- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a -alter f x m = case lookup x m of - Nothing -> case f Nothing of - Nothing -> m - Just v -> insert x v m - y -> case f y of - Nothing -> delete x m - Just v' -> adjust (const v') x m - - --- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. --- It prefers @t1@ when duplicate keys are encountered, --- i.e. (@'union' == 'unionWith' 'const'@). -union :: Ord k => IntervalMap k a -> IntervalMap k a -> IntervalMap k a -union m1 m2 = unionWithKey (\_ v _ -> v) m1 m2 - --- | /O(n+m)/. Union with a combining function. -unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a -unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 - --- | /O(n+m)/. Union with a combining function. -unionWithKey :: Ord k => (Interval k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a -unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2)) - --- | The union of a list of maps: --- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). -unions :: Ord k => [IntervalMap k a] -> IntervalMap k a -unions = L.foldl union empty - --- | The union of a list of maps, with a combining operation: --- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). -unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a -unionsWith f = L.foldl (unionWith f) empty - --- | /O(n+m)/. Difference of two maps. --- Return elements of the first map not existing in the second map. -difference :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a -difference m1 m2 = differenceWithKey (\_ _ _ -> Nothing) m1 m2 - --- | /O(n+m)/. Difference with a combining function. --- When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWith :: Ord k => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a -differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2 - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWithKey :: Ord k => (Interval k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a -differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2)) - --- | /O(n+m)/. Intersection of two maps. --- Return data in the first map for the keys existing in both maps. --- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). -intersection :: Ord k => IntervalMap k a -> IntervalMap k b -> IntervalMap k a -intersection m1 m2 = intersectionWithKey (\_ v _ -> v) m1 m2 - --- | /O(n+m)/. Intersection with a combining function. -intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c -intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 - --- | /O(n+m)/. Intersection with a combining function. -intersectionWithKey :: Ord k => (Interval k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c -intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2)) - -ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)] -ascListUnion _ [] [] = [] -ascListUnion _ [] ys = ys -ascListUnion _ xs [] = xs -ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') = - case compare xk yk of - LT -> x : ascListUnion f xs' ys - GT -> y : ascListUnion f xs ys' - EQ -> (xk, f xk xv yv) : ascListUnion f xs' ys' - -ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)] -ascListDifference _ [] _ = [] -ascListDifference _ xs [] = xs -ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') = - case compare xk yk of - LT -> x : ascListDifference f xs' ys - GT -> ascListDifference f xs ys' - EQ -> case f xk xv yv of - Nothing -> ascListDifference f xs' ys' - Just v' -> (xk,v') : ascListDifference f xs' ys' - -ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)] -ascListIntersection _ [] _ = [] -ascListIntersection _ _ [] = [] -ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') = - case compare xk yk of - LT -> ascListIntersection f xs' ys - GT -> ascListIntersection f xs ys' - EQ -> (xk, f xk xv yv) : ascListIntersection f xs' ys' - - --- --- Conversion --- - --- | /O(n)/. The list of all key\/value pairs contained in the map, in ascending order of keys. -toAscList :: IntervalMap k v -> [(Interval k,v)] -toAscList m = foldrWithKey (\k v r -> (k,v) : r) [] m - --- | /O(n)/. The list of all key\/value pairs contained in the map, in no particular order. -toList :: IntervalMap k v -> [(Interval k,v)] -toList m = toAscList m - --- | /O(n)/. The list of all key\/value pairs contained in the map, in descending order of keys. -toDescList :: IntervalMap k v -> [(Interval k, v)] -toDescList m = foldlWithKey (\r k v -> (k,v) : r) [] m - --- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. --- If the list contains more than one value for the same key, the last value --- for the key is retained. -fromList :: Ord k => [(Interval k,v)] -> IntervalMap k v -fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs - --- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -fromListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs - --- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -fromListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWithKey f xs = L.foldl' ins empty xs - where - ins t (k,x) = insertWithKey f k x t - --- | /O(n)/. Build a map from an ascending list in linear time. --- /The precondition (input list is ascending) is not checked./ -fromAscList :: Ord k => [(Interval k,v)] -> IntervalMap k v -fromAscList xs = fromAscListWith (\_ b -> b) xs - --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ -fromAscListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs - --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ -fromAscListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) - -combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -combineEq _ [] = [] -combineEq _ xs@[_] = xs -combineEq f (x@(xk,xv) : xs@((yk,yv) : xs')) - | xk == yk = combineEq f ((xk, f xk xv yv) : xs') - | otherwise = x : combineEq f xs - - --- Strict tuple -data T2 a b = T2 !a !b - - --- | /O(n)/. Build a map from an ascending list of elements with distinct keys in linear time. --- /The precondition is not checked./ -fromDistinctAscList :: (Ord k) => [(Interval k,v)] -> IntervalMap k v --- exactly 2^n-1 items have height n. They can be all black --- from 2^n - 2^n-2 items have height n+1. The lowest "row" should be red. -fromDistinctAscList lyst = case h (length lyst) lyst of - (T2 result []) -> result - _ -> error "fromDistinctAscList: list not fully consumed" - where - h n xs | n == 0 = T2 Nil xs - | isPerfect n = buildB n xs - | otherwise = buildR n (log2 n) xs - - buildB n xs | xs `seq` n <= 0 = error "fromDictinctAscList: buildB 0" - | n == 1 = case xs of ((k,v):xs') -> T2 (Node B k k v Nil Nil) xs' - | otherwise = - case n `quot` 2 of { n' -> - case buildB n' xs of { (T2 l ((k,v):xs')) -> - case buildB n' xs' of { (T2 r xs'') -> - T2 (mNode B k v l r) xs'' }}} - - buildR n d xs | d `seq` xs `seq` n == 0 = T2 Nil xs - | n == 1 = case xs of ((k,v):xs') -> T2 (Node (if d==0 then R else B) k k v Nil Nil) xs' - | otherwise = - case n `quot` 2 of { n' -> - case buildR n' (d-1) xs of { (T2 l ((k,v):xs')) -> - case buildR (n - (n' + 1)) (d-1) xs' of { (T2 r xs'') -> - T2 (mNode B k v l r) xs'' }}} - - --- is n a perfect binary tree size (2^m-1)? -isPerfect :: Int -> Bool -isPerfect n = (n .&. (n + 1)) == 0 - -log2 :: Int -> Int -log2 m = h (-1) m - where - h r n | r `seq` n <= 0 = r - | otherwise = h (r + 1) (n `shiftR` 1) - - --- | /O(n)/. List of all values in the map, in ascending order of their keys. -elems :: IntervalMap k v -> [v] -elems m = [v | (_,v) <- toAscList m] - --- | /O(n)/. List of all keys in the map, in ascending order. -keys :: IntervalMap k v -> [Interval k] -keys m = [k | (k,_) <- toAscList m] - --- | /O(n)/. Set of the keys. -keysSet :: (Ord k) => IntervalMap k v -> Set.Set (Interval k) -keysSet m = Set.fromDistinctAscList (keys m) - --- | Same as 'toAscList'. -assocs :: IntervalMap k v -> [(Interval k, v)] -assocs m = toAscList m - --- --- Mapping --- - --- | /O(n)/. Map a function over all values in the map. -map :: (a -> b) -> IntervalMap k a -> IntervalMap k b -map f = mapWithKey (\_ x -> f x) - --- | /O(n)/. Map a function over all values in the map. -mapWithKey :: (Interval k -> a -> b) -> IntervalMap k a -> IntervalMap k b -mapWithKey f = go - where - go Nil = Nil - go (Node c k m v l r) = Node c k m (f k v) (go l) (go r) - --- | /O(n)/. The function 'mapAccum' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) -mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) -mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m - --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) -mapAccumWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) -mapAccumWithKey f = go - where - go a Nil = (a,Nil) - go a (Node c kx m x l r) = - let (a1,l') = go a l - (a2,x') = f a1 kx x - (a3,r') = go a2 r - in (a3, Node c kx m x' l' r') - --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) -mapAccumRWithKey f = go - where - go a Nil = (a, Nil) - go a (Node c kx m x l r) = - let (a1,r') = go a r - (a2,x') = f a1 kx x - (a3,l') = go a2 l - in (a3, Node c kx m x' l' r') - - --- | /O(n log n)/. @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the value at the smallest of --- these keys is retained. -mapKeys :: Ord k2 => (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a -mapKeys f m = fromList [ (f k, v) | (k, v) <- toDescList m ] - --- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. -mapKeysWith :: Ord k2 => (a -> a -> a) -> (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a -mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ] - --- | /O(n log n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ --- is strictly monotonic. --- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. --- /The precondition is not checked./ -mapKeysMonotonic :: Ord k2 => (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a -mapKeysMonotonic _ Nil = Nil -mapKeysMonotonic f (Node c k _ x l r) = - mNode c (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) - --- | /O(n)/. Filter values satisfying a predicate. -filter :: Ord k => (a -> Bool) -> IntervalMap k a -> IntervalMap k a -filter p m = filterWithKey (\_ v -> p v) m - --- | /O(n)/. Filter keys\/values satisfying a predicate. -filterWithKey :: Ord k => (Interval k -> a -> Bool) -> IntervalMap k a -> IntervalMap k a -filterWithKey p m = mapMaybeWithKey (\k v -> if p k v then Just v else Nothing) m - --- | /O(n)/. Partition the map according to a predicate. The first --- map contains all elements that satisfy the predicate, the second all --- elements that fail the predicate. See also 'split'. -partition :: Ord k => (a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a) -partition p m = partitionWithKey (\_ v -> p v) m - --- | /O(n)/. Partition the map according to a predicate. The first --- map contains all elements that satisfy the predicate, the second all --- elements that fail the predicate. See also 'split'. -partitionWithKey :: Ord k => (Interval k -> a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a) -partitionWithKey p m = mapEitherWithKey p' m - where - p' k v | p k v = Left v - | otherwise = Right v - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybe :: Ord k => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b -mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m - --- | /O(n)/. Map keys\/values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (Interval k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b -mapMaybeWithKey f m = fromDistinctAscList (mapf [] m) - where - mapf z Nil = z - mapf z (Node _ k _ v l r) = mapf (f' k v z r) l - f' k v z r = case f k v of - Nothing -> mapf z r - Just v' -> (k,v') : mapf z r - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEither :: Ord k => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) -mapEither f m = mapEitherWithKey (\_ v -> f v) m - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (Interval k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) -mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r) - where - (l, r) = part [] [] (toDescList m) - part ls rs [] = (ls, rs) - part ls rs ((k,v):xs) = case f k v of - Left v' -> part ((k,v'):ls) rs xs - Right v' -> part ls ((k,v'):rs) xs - --- | /O(n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where --- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. --- Any key equal to @k@ is found in neither @map1@ nor @map2@. -split :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a) -split x m = (l, r) - where (l, _, r) = splitLookup x m - --- | /O(n)/. The expression (@'splitLookup' k map@) splits a map just --- like 'split' but also returns @'lookup' k map@. -splitLookup :: Ord k => Interval k -> IntervalMap k a -> (IntervalMap k a, Maybe a, IntervalMap k a) -splitLookup x m = (fromDistinctAscList less, lookup x m, fromDistinctAscList greater) - where - less = [e | e@(k,_) <- toAscList m, k < x] - greater = [e | e@(k,_) <- toAscList m, k > x] - --- submaps - --- | /O(n+m)/. This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -isSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool -isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 - -{- | /O(n+m)/. - The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if - all keys in @t1@ are in tree @t2@, and @f@ returns 'True' when - applied to their respective values. --} -isSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool -isSubmapOfBy f m1 m2 = go (toAscList m1) (toAscList m2) - where - go [] _ = True - go (_:_) [] = False - go s1@((k1,v1):r1) ((k2,v2):r2) = - case compare k1 k2 of - GT -> go s1 r2 - EQ -> f v1 v2 && go r1 r2 - LT -> False - --- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). --- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). -isProperSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool -isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2 - -{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). - The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when - @m1@ and @m2@ are not equal, - all keys in @m1@ are in @m2@, and when @f@ returns 'True' when - applied to their respective values. --} -isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool -isProperSubmapOfBy f t1 t2 = size t1 < size t2 && isSubmapOfBy f t1 t2 - - --- debugging - --- | Check red-black-tree and interval search augmentation invariants. --- For testing/debugging only. -valid :: Ord k => IntervalMap k v -> Bool -valid mp = test mp && height mp <= maxHeight (size mp) && validColor mp - where - test Nil = True - test n@(Node _ _ _ _ l r) = validOrder n && validMax n && test l && test r - validMax (Node _ k m _ lo hi) = m == maxUpper k lo hi - validMax Nil = True - - validOrder (Node _ _ _ _ Nil Nil) = True - validOrder (Node _ k1 _ _ Nil (Node _ k2 _ _ _ _)) = k1 < k2 - validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) Nil) = k1 < k2 - validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) (Node _ k3 _ _ _ _)) = k1 < k2 && k2 < k3 - validOrder Nil = True - - -- validColor parentColor blackCount tree - validColor n = blackDepth n >= 0 - - -- return -1 if subtrees have diffrent black depths or two consecutive red nodes are encountered - blackDepth :: IntervalMap k v -> Int - blackDepth Nil = 0 - blackDepth (Node c _ _ _ l r) = case blackDepth l of - ld -> if ld < 0 then ld - else - case blackDepth r of - rd -> if rd < 0 then rd - else if rd /= ld then -1 - else if c == R && (isRed l || isRed r) then -1 - else if c == B then rd + 1 - else rd - diff --git a/Data/IntervalMap/Generic/Base.hs b/Data/IntervalMap/Generic/Base.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalMap/Generic/Base.hs @@ -0,0 +1,1229 @@ +-- | +-- Module : Data.IntervalMap.Generic.Base +-- Copyright : (c) Christoph Breitkopf 2014 +-- License : BSD-style +-- Maintainer : chbreitkopf@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- An implementation of maps from intervals to values. The key intervals may +-- overlap, and the implementation contains efficient search functions +-- for all keys containing a point or overlapping an interval. +-- Closed, open, and half-open intervals can be contained in the same map. +-- +-- An IntervalMap cannot contain duplicate keys - if you need to map a key +-- to muiltiple values, use a collection as the value type, for +-- example: @IntervalMap /k/ [/v/]@. +-- +-- It is an error to insert an empty interval into a map. This precondition is not +-- checked by the various construction functions. +-- +-- Since many function names (but not the type name) clash with +-- /Prelude/ names, this module is usually imported @qualified@, e.g. +-- +-- > import Data.IntervalMap (IvMap) +-- > import qualified Data.IntervalMap as IvMap +-- +-- It offers most of the same functions as 'Data.Map', but the key type must be an +-- instance of 'Interval'. Some of the functions need stricter type constraints to +-- maintain the additional information for efficient interval searching, +-- for example 'fromDistinctAscList' needs an 'Ord' /k/ constraint. +-- Also, some functions differ in asymptotic performance (for example 'size') or have not +-- been tuned for efficiency as much as their equivalents in 'Data.Map' (in +-- particular the various set functions). +-- +-- In addition, there are functions specific to maps of intervals, for example to search +-- for all keys containing a given point or contained in a given interval. +-- +-- The implementation is a red-black tree augmented with the maximum upper bound +-- of all keys. +-- +-- Parts of this implementation are based on code from the 'Data.Map' implementation, +-- (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008. +-- The red-black tree deletion is based on code from llrbtree by Kazu Yamamoto. +-- Of course, any errors are mine. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.IntervalMap.Generic.Base ( + -- * re-export + Interval(..) + -- * Map type + , IntervalMap(..) -- instance Eq,Show,Read + + -- * Operators + , (!), (\\) + + -- * Query + , null + , size + , member + , notMember + , lookup + , findWithDefault + + -- ** Interval query + , containing + , intersecting + , within + + -- * Construction + , empty + , singleton + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- ** Fold + , foldr, foldl + , foldrWithKey, foldlWithKey + , foldl', foldr' + , foldrWithKey', foldlWithKey' + + -- * Conversion + , elems + , keys + , keysSet + , assocs + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , toDescList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , partition + , partitionWithKey + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , findMin + , findMax + , findLast + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + + -- * Internal, not re-exported by Data.IntervalMap.{Lazy,Strict} + , Color(..) + , balanceL, balanceR + , turnBlack + , setMinValue, setMaxValue + + -- * Debugging + , valid + + -- * Testing + , height, maxHeight, showStats + + ) where + +import Prelude hiding (null, lookup, map, filter, foldr, foldl) +import Data.Bits (shiftR, (.&.)) +import Data.Monoid (Monoid(..)) +import Control.Applicative (Applicative(..), (<$>)) +import Data.Traversable (Traversable(traverse)) +import qualified Data.Foldable as Foldable +import qualified Data.List as L +import qualified Data.Set as Set +import Control.DeepSeq (NFData(rnf)) + +import Data.IntervalMap.Generic.Interval + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 !,\\ -- + +-- | /O(log n)/. Lookup value for given key. Calls 'error' if the key is not in the map. +(!) :: (Interval k e, Ord k) => IntervalMap k v -> k -> v +tree ! key = case lookup key tree of + Just v -> v + Nothing -> error "IntervalMap.!: key not found" + +-- | Same as 'difference'. +(\\) :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k b -> IntervalMap k a +m1 \\ m2 = difference m1 m2 + + +data Color = R | B deriving (Eq, Read, Show) + +-- | A map from intervals of type @k@ to values of type @v@. +data IntervalMap k v = Nil + | Node !Color + !k -- key + !k -- interval with maximum upper in tree + v -- value + !(IntervalMap k v) -- left subtree + !(IntervalMap k v) -- right subtree + +instance (Eq k, Eq v) => Eq (IntervalMap k v) where + a == b = toAscList a == toAscList b + +instance (Ord k, Ord v) => Ord (IntervalMap k v) where + compare a b = compare (toAscList a) (toAscList b) + +instance Functor (IntervalMap k) where + fmap f m = map f m + +instance (Interval i k, Ord i) => Monoid (IntervalMap i v) where + mempty = empty + mappend = union + mconcat = unions + +instance Traversable (IntervalMap k) where + traverse _ Nil = pure Nil + traverse f (Node c k m v l r) + = flip (Node c k m) <$> traverse f l <*> f v <*> traverse f r + +instance Foldable.Foldable (IntervalMap k) where + fold Nil = mempty + fold (Node _ _ _ v l r) = Foldable.fold l `mappend` v `mappend` Foldable.fold r + foldr = foldr + foldl = foldl + foldMap _ Nil = mempty + foldMap f (Node _ _ _ v l r) = Foldable.foldMap f l `mappend` f v `mappend` Foldable.foldMap f r + +instance (NFData k, NFData a) => NFData (IntervalMap k a) where + rnf Nil = () + rnf (Node _ kx _ x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r + +instance (Ord k, Read k, Read e, Interval i k, Ord i, Read i) => Read (IntervalMap i e) where + readsPrec p = readParen (p > 10) $ \ r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) + +instance (Show k, Show a) => Show (IntervalMap k a) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + + +isRed :: IntervalMap k v -> Bool +isRed (Node R _ _ _ _ _) = True +isRed _ = False + +turnBlack :: IntervalMap k v -> IntervalMap k v +turnBlack (Node R k m vs l r) = Node B k m vs l r +turnBlack t = t + +turnRed :: IntervalMap k v -> IntervalMap k v +turnRed Nil = error "turnRed: Leaf" +turnRed (Node B k m v l r) = Node R k m v l r +turnRed t = t + +-- construct node, recomputing the upper key bound. +mNode :: (Interval k e) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v +mNode c k v l r = Node c k (maxUpper k l r) v l r + +maxUpper :: (Interval i k) => i -> IntervalMap i v -> IntervalMap i v -> i +maxUpper k Nil Nil = k `seq` k +maxUpper k Nil (Node _ _ m _ _ _) = maxByUpper k m +maxUpper k (Node _ _ m _ _ _) Nil = maxByUpper k m +maxUpper k (Node _ _ l _ _ _) (Node _ _ r _ _ _) = maxByUpper k (maxByUpper l r) + +-- interval with the greatest upper bound. The lower bound is ignored! +maxByUpper :: (Interval i e) => i -> i -> i +maxByUpper a b | rightClosed a = if upperBound a >= upperBound b then a else b + | otherwise = if upperBound a > upperBound b then a else b + +-- --------------------------------------------------------- + +-- | /O(1)/. The empty map. +empty :: IntervalMap k v +empty = Nil + +-- | /O(1)/. A map with one entry. +singleton :: k -> v -> IntervalMap k v +singleton k v = Node B k k v Nil Nil + + +-- | /O(1)/. Is the map empty? +null :: IntervalMap k v -> Bool +null Nil = True +null _ = False + +-- | /O(n)/. Number of keys in the map. +-- +-- Caution: unlike 'Data.Map.size', which takes constant time, this is linear in the +-- number of keys! +size :: IntervalMap k v -> Int +size t = h 0 t + where + h n m = n `seq` case m of + Nil -> n + Node _ _ _ _ l r -> h (h n l + 1) r + +-- | The height of the tree. For testing/debugging only. +height :: IntervalMap k v -> Int +height Nil = 0 +height (Node _ _ _ _ l r) = 1 + max (height l) (height r) + +-- | The maximum height of a red-black tree with the given number of nodes. +-- For testing/debugging only. +maxHeight :: Int -> Int +maxHeight nodes = 2 * log2 (nodes + 1) + +-- | Tree statistics (size, height, maxHeight size). +-- For testing/debugging only. +showStats :: IntervalMap k a -> (Int, Int, Int) +showStats m = (n, height m, maxHeight n) + where n = size m + +-- | /O(log n)/. Does the map contain the given key? See also 'notMember'. +member :: (Ord k) => k -> IntervalMap k v -> Bool +member key tree = case lookup key tree of + Nothing -> False + Just _ -> True + +-- | /O(log n)/. Does the map not contain the given key? See also 'member'. +notMember :: (Ord k) => k -> IntervalMap k v -> Bool +notMember key tree = not (member key tree) + + +-- | /O(log n)/. Look up the given key in the map, returning the value @('Just' value)@, +-- or 'Nothing' if the key is not in the map. +lookup :: (Ord k) => k -> IntervalMap k v -> Maybe v +lookup k Nil = k `seq` Nothing +lookup k (Node _ key _ v l r) = case compare k key of + LT -> lookup k l + GT -> lookup k r + EQ -> Just v + + +-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- the value at key @k@ or returns default value @def@ +-- when the key is not in the map. +-- +-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' +-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' + +findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a +findWithDefault def k m = case lookup k m of + Nothing -> def + Just x -> x + +-- | Return all key/value pairs where the key intervals contain the given point. +-- The elements are returned in ascending key order. +-- +-- /O(n)/, since potentially all keys could contain the point. +-- /O(log n)/ average case. This is also the worst case for maps containing no overlapping keys. +containing :: (Interval k e) => IntervalMap k v -> e -> [(k, v)] +t `containing` pt = go [] pt t + where + go xs p Nil = p `seq` xs + go xs p (Node _ k m v l r) + | p `above` m = xs -- above all intervals in the tree: no result + | p `below` k = go xs p l -- to the left of the lower bound: can't be in right subtree + | p `inside` k = go ((k,v) : go xs p r) p l + | otherwise = go (go xs p r) p l + +-- | Return all key/value pairs where the key intervals overlap (intersect) the given interval. +-- The elements are returned in ascending key order. +-- +-- /O(n)/, since potentially all keys could intersect the interval. +-- /O(log n)/ average case, if few keys intersect the interval. +intersecting :: (Interval k e) => IntervalMap k v -> k -> [(k, v)] +t `intersecting` iv = go [] iv t + where + go xs i Nil = i `seq` xs + go xs i (Node _ k m v l r) + | i `after` m = xs + | i `before` k = go xs i l + | i `overlaps` k = go ((k,v) : go xs i r) i l + | otherwise = go (go xs i r) i l + +-- | Return all key/value pairs where the key intervals are completely inside the given interval. +-- The elements are returned in ascending key order. +-- +-- /O(n)/, since potentially all keys could be inside the interval. +-- /O(log n)/ average case, if few keys are inside the interval. +within :: (Interval k e) => IntervalMap k v -> k -> [(k, v)] +t `within` iv = go [] iv t + where + go xs i Nil = i `seq` xs + go xs i (Node _ k m v l r) + | i `after` m = xs + | i `before` k = go xs i l + | i `subsumes` k = go ((k,v) : go xs i r) i l + | otherwise = go (go xs i r) i l + + +-- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is +-- changed to the new value. +insert :: (Interval k e, Ord k) => k -> v -> IntervalMap k v -> IntervalMap k v +insert = insertWithKey (\_ v _ -> v) + +-- | /O(log n)/. Insert with a function, combining new value and old value. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert the pair @(key, f new_value old_value)@. +insertWith :: (Interval k e, Ord k) => (v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v +insertWith f = insertWithKey (\_ new old -> f new old) + +-- | /O(log n)/. Insert with a function, combining key, new value and old value. +-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert the pair @(key, f key new_value old_value)@. +-- Note that the key passed to f is the same key passed to 'insertWithKey'. +insertWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v +insertWithKey f key value mp = key `seq` turnBlack (ins mp) + where + singletonR k v = Node R k k v Nil Nil + ins Nil = singletonR key value + ins (Node color k m v l r) = + case compare key k of + LT -> balanceL color k v (ins l) r + GT -> balanceR color k v l (ins r) + EQ -> Node color k m (f k value v) l r + +-- | /O(log n)/. Combine insert with old values retrieval. +insertLookupWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v) +insertLookupWithKey f key value mp = key `seq` (oldval, turnBlack mp') + where + (oldval, mp') = ins mp + singletonR k v = Node R k k v Nil Nil + ins Nil = (Nothing, singletonR key value) + ins (Node color k m v l r) = + case compare key k of + LT -> case ins l of + (x@(Just _), t') -> (x, Node color k m v t' r) + (Nothing, t') -> (Nothing, balanceL color k v t' r) + GT -> case ins r of + (x@(Just _), t') -> (x, Node color k m v l t') + (Nothing, t') -> (Nothing, balanceR color k v l t') + EQ -> (Just v, Node color k m (f k value v) l r) + + +balanceL :: (Interval k e) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v +balanceL B zk zv (Node R yk _ yv (Node R xk _ xv a b) c) d = + mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) +balanceL B zk zv (Node R xk _ xv a (Node R yk _ yv b c)) d = + mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) +balanceL c xk xv l r = mNode c xk xv l r + +balanceR :: (Interval k e) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> IntervalMap k v +balanceR B xk xv a (Node R yk _ yv b (Node R zk _ zv c d)) = + mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) +balanceR B xk xv a (Node R zk _ zv (Node R yk _ yv b c) d) = + mNode R yk yv (mNode B xk xv a b) (mNode B zk zv c d) +balanceR c xk xv l r = mNode c xk xv l r + + +-- min/max + +-- | /O(log n)/. Returns the smallest key and its associated value. +-- Calls 'error' if the map is empty. +findMin :: IntervalMap k v -> (k, v) +findMin (Node _ k _ v Nil _) = (k,v) +findMin (Node _ _ _ _ l _) = findMin l +findMin Nil = error "IntervalMap.findMin: empty map" + +-- | /O(log n)/. Returns the largest key and its associated value. +-- Calls 'error' if the map is empty. +findMax :: IntervalMap k v -> (k, v) +findMax (Node _ k _ v _ Nil) = (k,v) +findMax (Node _ _ _ _ _ r) = findMax r +findMax Nil = error "IntervalMap.findMin: empty map" + +-- | Returns the interval with the largest endpoint. +-- If there is more than one interval with that endpoint, +-- return the rightmost. +-- +-- /O(n)/, since all keys could have the same endpoint. +-- /O(log n)/ average case. +findLast :: (Interval k e) => IntervalMap k v -> (k, v) +findLast Nil = error "IntervalMap.findLast: empty map" +findLast t@(Node _ _ mx _ _ _) = lastMax + where + (lastMax : _) = go t + go Nil = [] + go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ ((k,v) : go l) + else go r ++ go l + | otherwise = [] + sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b + + +-- Type to indicate whether the number of black nodes changed or stayed the same. +data DeleteResult k v = U !(IntervalMap k v) -- Unchanged + | S !(IntervalMap k v) -- Shrunk + +unwrap :: DeleteResult k v -> IntervalMap k v +unwrap (U m) = m +unwrap (S m) = m + +-- DeleteResult with value +data DeleteResult' k v a = U' !(IntervalMap k v) a + | S' !(IntervalMap k v) a + +unwrap' :: DeleteResult' k v a -> IntervalMap k v +unwrap' (U' m _) = m +unwrap' (S' m _) = m + +-- annotate DeleteResult with value +annotate :: DeleteResult k v -> a -> DeleteResult' k v a +annotate (U m) x = U' m x +annotate (S m) x = S' m x + + +-- | /O(log n)/. Remove the smallest key from the map. Return the empty map if the map is empty. +deleteMin :: (Interval k e, Ord k) => IntervalMap k v -> IntervalMap k v +deleteMin Nil = Nil +deleteMin m = turnBlack (unwrap' (deleteMin' m)) + +deleteMin' :: (Interval k e, Ord k) => IntervalMap k v -> DeleteResult' k v (k, v) +deleteMin' Nil = error "deleteMin': Nil" +deleteMin' (Node B k _ v Nil Nil) = S' Nil (k,v) +deleteMin' (Node B k _ v Nil r@(Node R _ _ _ _ _)) = U' (turnBlack r) (k,v) +deleteMin' (Node R k _ v Nil r) = U' r (k,v) +deleteMin' (Node c k _ v l r) = + case deleteMin' l of + (U' l' kv) -> U' (mNode c k v l' r) kv + (S' l' kv) -> annotate (unbalancedR c k v l' r) kv + +deleteMax' :: (Interval k e, Ord k) => IntervalMap k v -> DeleteResult' k v (k, v) +deleteMax' Nil = error "deleteMax': Nil" +deleteMax' (Node B k _ v Nil Nil) = S' Nil (k,v) +deleteMax' (Node B k _ v l@(Node R _ _ _ _ _) Nil) = U' (turnBlack l) (k,v) +deleteMax' (Node R k _ v l Nil) = U' l (k,v) +deleteMax' (Node c k _ v l r) = + case deleteMax' r of + (U' r' kv) -> U' (mNode c k v l r') kv + (S' r' kv) -> annotate (unbalancedL c k v l r') kv + +-- The left tree lacks one Black node +unbalancedR :: (Interval k e, Ord k) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v +-- Decreasing one Black node in the right +unbalancedR B k v l r@(Node B _ _ _ _ _) = S (balanceR B k v l (turnRed r)) +unbalancedR R k v l r@(Node B _ _ _ _ _) = U (balanceR B k v l (turnRed r)) +-- Taking one Red node from the right and adding it to the right as Black +unbalancedR B k v l (Node R rk _ rv rl@(Node B _ _ _ _ _) rr) + = U (mNode B rk rv (balanceR B k v l (turnRed rl)) rr) +unbalancedR _ _ _ _ _ = error "unbalancedR" + +unbalancedL :: (Interval k e, Ord k) => Color -> k -> v -> IntervalMap k v -> IntervalMap k v -> DeleteResult k v +unbalancedL R k v l@(Node B _ _ _ _ _) r = U (balanceL B k v (turnRed l) r) +unbalancedL B k v l@(Node B _ _ _ _ _) r = S (balanceL B k v (turnRed l) r) +unbalancedL B k v (Node R lk _ lv ll lr@(Node B _ _ _ _ _)) r + = U (mNode B lk lv ll (balanceL B k v (turnRed lr) r)) +unbalancedL _ _ _ _ _ = error "unbalancedL" + + + +-- | /O(log n)/. Remove the largest key from the map. Return the empty map if the map is empty. +deleteMax :: (Interval k e, Ord k) => IntervalMap k v -> IntervalMap k v +deleteMax Nil = Nil +deleteMax m = turnBlack (unwrap' (deleteMax' m)) + +-- | /O(log n)/. Delete and return the smallest key. +deleteFindMin :: (Interval k e, Ord k) => IntervalMap k v -> ((k,v), IntervalMap k v) +deleteFindMin mp = case deleteMin' mp of + (U' r v) -> (v, turnBlack r) + (S' r v) -> (v, turnBlack r) + +-- | /O(log n)/. Delete and return the largest key. +deleteFindMax :: (Interval k e, Ord k) => IntervalMap k v -> ((k,v), IntervalMap k v) +deleteFindMax mp = case deleteMax' mp of + (U' r v) -> (v, turnBlack r) + (S' r v) -> (v, turnBlack r) + +-- | /O(log n)/. Update or delete value at minimum key. +updateMin :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMin f m = updateMinWithKey (\_ v -> f v) m + +-- | /O(log n)/. Update or delete value at maximum key. +updateMax :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMax f m = updateMaxWithKey (\_ v -> f v) m + +-- | /O(log n)/. Update or delete value at minimum key. +updateMinWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMinWithKey _ Nil = Nil +updateMinWithKey f m = let (k,v) = findMin m in + case f k v of + Just v' -> setMinValue v' m + Nothing -> deleteMin m + +-- | /O(log n)/. Update or delete value at maximum key. +updateMaxWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMaxWithKey _ Nil = Nil +updateMaxWithKey f m = let (k,v) = findMax m in + case f k v of + Just v' -> setMaxValue v' m + Nothing -> deleteMax m + +-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and +-- the map stripped of that element, or 'Nothing' if passed an empty map. +-- +-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a") +-- > minViewWithKey empty == Nothing + +minViewWithKey :: (Interval k e, Ord k) => IntervalMap k a -> Maybe ((k, a), IntervalMap k a) +minViewWithKey Nil = Nothing +minViewWithKey x = Just (deleteFindMin x) + +-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and +-- the map stripped of that element, or 'Nothing' if passed an empty map. +maxViewWithKey :: (Interval k e, Ord k) => IntervalMap k a -> Maybe ((k, a), IntervalMap k a) +maxViewWithKey Nil = Nothing +maxViewWithKey x = Just (deleteFindMax x) + +-- | /O(log n)/. Retrieves the value associated with minimal key of the +-- map, and the map stripped of that element, or 'Nothing' if passed an +-- empty map. +minView :: (Interval k e, Ord k) => IntervalMap k a -> Maybe (a, IntervalMap k a) +minView Nil = Nothing +minView x = case deleteFindMin x of ((_,a), x') -> Just (a, x') + +-- | /O(log n)/. Retrieves the value associated with maximal key of the +-- map, and the map stripped of that element, or 'Nothing' if passed an +-- empty map. +maxView :: (Interval k e, Ord k) => IntervalMap k a -> Maybe (a, IntervalMap k a) +maxView Nil = Nothing +maxView x = case deleteFindMax x of ((_,a), x') -> Just (a, x') + + +setMinValue :: v -> IntervalMap k v -> IntervalMap k v +setMinValue _ Nil = Nil +setMinValue v' (Node c k m _ Nil r) = Node c k m v' Nil r +setMinValue v' (Node c k m v l r) = Node c k m v (setMinValue v' l) r + +setMaxValue :: v -> IntervalMap k v -> IntervalMap k v +setMaxValue _ Nil = Nil +setMaxValue v' (Node c k m _ l Nil) = Node c k m v' l Nil +setMaxValue v' (Node c k m v l r) = Node c k m v l (setMaxValue v' r) + + + +-- folding + +-- | /O(n)/. Fold the values in the map using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +foldr :: (a -> b -> b) -> b -> IntervalMap k a -> b +foldr _ z Nil = z +foldr f z (Node _ _ _ x l r) = foldr f (f x (foldr f z r)) l + +-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr' :: (a -> b -> b) -> b -> IntervalMap k a -> b +foldr' f z m = z `seq` case m of + Nil -> z + Node _ _ _ x l r -> foldr' f (f x (foldr' f z r)) l + +-- | /O(n)/. Fold the values in the map using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +foldl :: (b -> a -> b) -> b -> IntervalMap k a -> b +foldl _ z Nil = z +foldl f z (Node _ _ _ x l r) = foldl f (f (foldl f z l) x) r + +-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl' :: (b -> a -> b) -> b -> IntervalMap k a -> b +foldl' f z m = z `seq` case m of + Nil -> z + Node _ _ _ x l r -> foldl' f (f (foldl' f z l) x) r + +-- | /O(n)/. Fold the keys and values in the map using the given right-associative +-- binary operator, such that +-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +foldrWithKey :: (k -> v -> a -> a) -> a -> IntervalMap k v -> a +foldrWithKey _ z Nil = z +foldrWithKey f z (Node _ k _ x l r) = foldrWithKey f (f k x (foldrWithKey f z r)) l + +-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldrWithKey' :: (k -> v -> a -> a) -> a -> IntervalMap k v -> a +foldrWithKey' f z m = z `seq` case m of + Nil -> z + Node _ k _ x l r -> foldrWithKey' f (f k x (foldrWithKey' f z r)) l + +-- | /O(n)/. Fold the keys and values in the map using the given left-associative +-- binary operator, such that +-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@. +foldlWithKey :: (a -> k -> v -> a) -> a -> IntervalMap k v -> a +foldlWithKey _ z Nil = z +foldlWithKey f z (Node _ k _ x l r) = foldlWithKey f (f (foldlWithKey f z l) k x) r + +-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldlWithKey' :: (a -> k -> v -> a) -> a -> IntervalMap k v -> a +foldlWithKey' f z m = z `seq` case m of + Nil -> z + Node _ k _ x l r -> foldlWithKey' f (f (foldlWithKey' f z l) k x) r + +-- delete + +-- | /O(log n)/. Delete a key from the map. If the map does not contain the key, +-- it is returned unchanged. +delete :: (Interval k e, Ord k) => k -> IntervalMap k v -> IntervalMap k v +delete key mp = turnBlack (unwrap (delete' key mp)) + +delete' :: (Interval k e, Ord k) => k -> IntervalMap k v -> DeleteResult k v +delete' x Nil = x `seq` U Nil +delete' x (Node c k _ v l r) = + case compare x k of + LT -> case delete' x l of + (U l') -> U (mNode c k v l' r) + (S l') -> unbalancedR c k v l' r + GT -> case delete' x r of + (U r') -> U (mNode c k v l r') + (S r') -> unbalancedL c k v l r' + EQ -> case r of + Nil -> if c == B then blackify l else U l + _ -> case deleteMin' r of + (U' r' (rk,rv)) -> U (mNode c rk rv l r') + (S' r' (rk,rv)) -> unbalancedL c rk rv l r' + +blackify :: IntervalMap k v -> DeleteResult k v +blackify (Node R k m v l r) = U (Node B k m v l r) +blackify s = S s + +-- | /O(log n)/. Update a value at a specific key with the result of the provided function. +-- When the key is not +-- a member of the map, the original map is returned. +adjust :: Ord k => (a -> a) -> k -> IntervalMap k a -> IntervalMap k a +adjust f k m = adjustWithKey (\_ v -> f v) k m + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: Ord k => (k -> a -> a) -> k -> IntervalMap k a -> IntervalMap k a +adjustWithKey _ _ Nil = Nil +adjustWithKey f x (Node c k m v l r) = + case compare x k of + LT -> Node c k m v (adjustWithKey f x l) r + GT -> Node c k m v l (adjustWithKey f x r) + EQ -> Node c k m (f k v) l r + +-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +update :: (Interval k e, Ord k) => (a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a +update f k m = updateWithKey (\_ v -> f v) k m + +-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', +-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound +-- to the new value @y@. +updateWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a +updateWithKey f k m = snd (updateLookupWithKey f k m) + +-- | /O(log n)/. Lookup and update. See also 'updateWithKey'. +-- The function returns changed value, if it is updated. +-- Returns the original key value if the map entry is deleted. +updateLookupWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> (Maybe a, IntervalMap k a) +updateLookupWithKey f x m = case lookup x m of + Nothing -> (Nothing, m) + r@(Just v) -> case f x v of + Nothing -> (r, delete x m) + r'@(Just v') -> (r', adjust (const v') x m) + +-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in a 'Map'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Interval k e, Ord k) => (Maybe a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a +alter f x m = case lookup x m of + Nothing -> case f Nothing of + Nothing -> m + Just v -> insert x v m + y -> case f y of + Nothing -> delete x m + Just v' -> adjust (const v') x m + + +-- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered, +-- i.e. (@'union' == 'unionWith' 'const'@). +union :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k a -> IntervalMap k a +union m1 m2 = unionWithKey (\_ v _ -> v) m1 m2 + +-- | /O(n+m)/. Union with a combining function. +unionWith :: (Interval k e, Ord k) => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a +unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 + +-- | /O(n+m)/. Union with a combining function. +unionWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a +unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2)) + +-- | The union of a list of maps: +-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). +unions :: (Interval k e, Ord k) => [IntervalMap k a] -> IntervalMap k a +unions = L.foldl union empty + +-- | The union of a list of maps, with a combining operation: +-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). +unionsWith :: (Interval k e, Ord k) => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a +unionsWith f = L.foldl (unionWith f) empty + +-- | /O(n+m)/. Difference of two maps. +-- Return elements of the first map not existing in the second map. +difference :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k b -> IntervalMap k a +difference m1 m2 = differenceWithKey (\_ _ _ -> Nothing) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are +-- encountered, the combining function is applied to the values of these keys. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWith :: (Interval k e, Ord k) => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a +differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWithKey :: (Interval k e, Ord k) => (k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a +differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2)) + +-- | /O(n+m)/. Intersection of two maps. +-- Return data in the first map for the keys existing in both maps. +-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). +intersection :: (Interval k e, Ord k) => IntervalMap k a -> IntervalMap k b -> IntervalMap k a +intersection m1 m2 = intersectionWithKey (\_ v _ -> v) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWith :: (Interval k e, Ord k) => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWithKey :: (Interval k e, Ord k) => (k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2)) + +ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)] +ascListUnion _ [] [] = [] +ascListUnion _ [] ys = ys +ascListUnion _ xs [] = xs +ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') = + case compare xk yk of + LT -> x : ascListUnion f xs' ys + GT -> y : ascListUnion f xs ys' + EQ -> (xk, f xk xv yv) : ascListUnion f xs' ys' + +ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)] +ascListDifference _ [] _ = [] +ascListDifference _ xs [] = xs +ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') = + case compare xk yk of + LT -> x : ascListDifference f xs' ys + GT -> ascListDifference f xs ys' + EQ -> case f xk xv yv of + Nothing -> ascListDifference f xs' ys' + Just v' -> (xk,v') : ascListDifference f xs' ys' + +ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)] +ascListIntersection _ [] _ = [] +ascListIntersection _ _ [] = [] +ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') = + case compare xk yk of + LT -> ascListIntersection f xs' ys + GT -> ascListIntersection f xs ys' + EQ -> (xk, f xk xv yv) : ascListIntersection f xs' ys' + + +-- --- Conversion --- + +-- | /O(n)/. The list of all key\/value pairs contained in the map, in ascending order of keys. +toAscList :: IntervalMap k v -> [(k,v)] +toAscList m = foldrWithKey (\k v r -> (k,v) : r) [] m + +-- | /O(n)/. The list of all key\/value pairs contained in the map, in no particular order. +toList :: IntervalMap k v -> [(k,v)] +toList m = toAscList m + +-- | /O(n)/. The list of all key\/value pairs contained in the map, in descending order of keys. +toDescList :: IntervalMap k v -> [(k, v)] +toDescList m = foldlWithKey (\r k v -> (k,v) : r) [] m + +-- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. +-- If the list contains more than one value for the same key, the last value +-- for the key is retained. +fromList :: (Interval k e, Ord k) => [(k,v)] -> IntervalMap k v +fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs + +-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: (Interval k e, Ord k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs + +-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromListWithKey f xs = L.foldl' ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | /O(n)/. Build a map from an ascending list in linear time. +-- /The precondition (input list is ascending) is not checked./ +fromAscList :: (Interval k e, Eq k) => [(k,v)] -> IntervalMap k v +fromAscList xs = fromAscListWith (\_ b -> b) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- /The precondition (input list is ascending) is not checked./ +fromAscListWith :: (Interval k e, Eq k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- /The precondition (input list is ascending) is not checked./ +fromAscListWithKey :: (Interval k e, Eq k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) + +combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] +combineEq _ [] = [] +combineEq _ xs@[_] = xs +combineEq f (x@(xk,xv) : xs@((yk,yv) : xs')) + | xk == yk = combineEq f ((xk, f xk xv yv) : xs') + | otherwise = x : combineEq f xs + + +-- Strict tuple +data T2 a b = T2 !a !b + + +-- | /O(n)/. Build a map from an ascending list of elements with distinct keys in linear time. +-- /The precondition is not checked./ +fromDistinctAscList :: (Interval k e) => [(k,v)] -> IntervalMap k v +-- exactly 2^n-1 items have height n. They can be all black +-- from 2^n - 2^n-2 items have height n+1. The lowest "row" should be red. +fromDistinctAscList lyst = case h (length lyst) lyst of + (T2 result []) -> result + _ -> error "fromDistinctAscList: list not fully consumed" + where + h n xs | n == 0 = T2 Nil xs + | isPerfect n = buildB n xs + | otherwise = buildR n (log2 n) xs + + buildB n xs | xs `seq` n <= 0 = error "fromDictinctAscList: buildB 0" + | n == 1 = case xs of ((k,v):xs') -> T2 (Node B k k v Nil Nil) xs' + _ -> error "fromDictinctAscList: buildB 1" + | otherwise = + case n `quot` 2 of { n' -> + case buildB n' xs of { (T2 _ []) -> error "fromDictinctAscList: buildB n"; + (T2 l ((k,v):xs')) -> + case buildB n' xs' of { (T2 r xs'') -> + T2 (mNode B k v l r) xs'' }}} + + buildR n d xs | d `seq` xs `seq` n == 0 = T2 Nil xs + | n == 1 = case xs of ((k,v):xs') -> T2 (Node (if d==0 then R else B) k k v Nil Nil) xs' + _ -> error "fromDistinctAscList: buildR 1" + | otherwise = + case n `quot` 2 of { n' -> + case buildR n' (d-1) xs of { (T2 _ []) -> error "fromDistinctAscList: buildR n"; + (T2 l ((k,v):xs')) -> + case buildR (n - (n' + 1)) (d-1) xs' of { (T2 r xs'') -> + T2 (mNode B k v l r) xs'' }}} + + +-- is n a perfect binary tree size (2^m-1)? +isPerfect :: Int -> Bool +isPerfect n = (n .&. (n + 1)) == 0 + +log2 :: Int -> Int +log2 m = h (-1) m + where + h r n | r `seq` n <= 0 = r + | otherwise = h (r + 1) (n `shiftR` 1) + + +-- | /O(n)/. List of all values in the map, in ascending order of their keys. +elems :: IntervalMap k v -> [v] +elems m = [v | (_,v) <- toAscList m] + +-- | /O(n)/. List of all keys in the map, in ascending order. +keys :: IntervalMap k v -> [k] +keys m = [k | (k,_) <- toAscList m] + +-- | /O(n)/. Set of the keys. +keysSet :: (Ord k) => IntervalMap k v -> Set.Set k +keysSet m = Set.fromDistinctAscList (keys m) + +-- | Same as 'toAscList'. +assocs :: IntervalMap k v -> [(k, v)] +assocs m = toAscList m + +-- --- Mapping --- + +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> IntervalMap k a -> IntervalMap k b +map f = mapWithKey (\_ x -> f x) + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (k -> a -> b) -> IntervalMap k a -> IntervalMap k b +mapWithKey f = go + where + go Nil = Nil + go (Node c k m v l r) = Node c k m (f k v) (go l) (go r) + +-- | /O(n)/. The function 'mapAccum' threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) +mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) +mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m + +-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) +mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) +mapAccumWithKey f = go + where + go a Nil = (a,Nil) + go a (Node c kx m x l r) = + let (a1,l') = go a l + (a2,x') = f a1 kx x + (a3,r') = go a2 r + in (a3, Node c kx m x' l' r') + +-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) +mapAccumRWithKey f = go + where + go a Nil = (a, Nil) + go a (Node c kx m x l r) = + let (a1,r') = go a r + (a2,x') = f a1 kx x + (a3,l') = go a2 l + in (a3, Node c kx m x' l' r') + + +-- | /O(n log n)/. @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the value at the smallest of +-- these keys is retained. +mapKeys :: (Interval k2 e, Ord k2) => (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a +mapKeys f m = fromList [ (f k, v) | (k, v) <- toDescList m ] + +-- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. +mapKeysWith :: (Interval k2 e, Ord k2) => (a -> a -> a) -> (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a +mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ] + +-- | /O(n log n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +mapKeysMonotonic :: (Interval k2 e, Ord k2) => (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a +mapKeysMonotonic _ Nil = Nil +mapKeysMonotonic f (Node c k _ x l r) = + mNode c (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r) + +-- | /O(n)/. Filter values satisfying a predicate. +filter :: (Interval k e) => (a -> Bool) -> IntervalMap k a -> IntervalMap k a +filter p m = filterWithKey (\_ v -> p v) m + +-- | /O(n)/. Filter keys\/values satisfying a predicate. +filterWithKey :: (Interval k e) => (k -> a -> Bool) -> IntervalMap k a -> IntervalMap k a +filterWithKey p m = mapMaybeWithKey (\k v -> if p k v then Just v else Nothing) m + +-- | /O(n)/. Partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partition :: (Interval k e) => (a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a) +partition p m = partitionWithKey (\_ v -> p v) m + +-- | /O(n)/. Partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partitionWithKey :: (Interval k e) => (k -> a -> Bool) -> IntervalMap k a -> (IntervalMap k a, IntervalMap k a) +partitionWithKey p m = mapEitherWithKey p' m + where + p' k v | p k v = Left v + | otherwise = Right v + +-- | /O(n)/. Map values and collect the 'Just' results. +mapMaybe :: (Interval k e) => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b +mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m + +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +mapMaybeWithKey :: (Interval k e) => (k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b +mapMaybeWithKey f m = fromDistinctAscList (mapf [] m) + where + mapf z Nil = z + mapf z (Node _ k _ v l r) = mapf (f' k v z r) l + f' k v z r = case f k v of + Nothing -> mapf z r + Just v' -> (k,v') : mapf z r + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +mapEither :: (Interval k e) => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) +mapEither f m = mapEitherWithKey (\_ v -> f v) m + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: (Interval i k) => (i -> a -> Either b c) -> IntervalMap i a -> (IntervalMap i b, IntervalMap i c) +mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r) + where + (l, r) = part [] [] (toDescList m) + part ls rs [] = (ls, rs) + part ls rs ((k,v):xs) = case f k v of + Left v' -> part ((k,v'):ls) rs xs + Right v' -> part ls ((k,v'):rs) xs + +-- | /O(n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where +-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@. +-- Any key equal to @k@ is found in neither @map1@ nor @map2@. +split :: (Interval i k, Ord i) => i -> IntervalMap i a -> (IntervalMap i a, IntervalMap i a) +split x m = (l, r) + where (l, _, r) = splitLookup x m + +-- | /O(n)/. The expression (@'splitLookup' k map@) splits a map just +-- like 'split' but also returns @'lookup' k map@. +splitLookup :: (Interval i k, Ord i) => i -> IntervalMap i a -> (IntervalMap i a, Maybe a, IntervalMap i a) +splitLookup x m = (fromDistinctAscList less, lookup x m, fromDistinctAscList greater) + where + less = [e | e@(k,_) <- toAscList m, k < x] + greater = [e | e@(k,_) <- toAscList m, k > x] + +-- submaps + +-- | /O(n+m)/. This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool +isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 + +{- | /O(n+m)/. + The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if + all keys in @t1@ are in tree @t2@, and @f@ returns 'True' when + applied to their respective values. +-} +isSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool +isSubmapOfBy f m1 m2 = go (toAscList m1) (toAscList m2) + where + go [] _ = True + go (_:_) [] = False + go s1@((k1,v1):r1) ((k2,v2):r2) = + case compare k1 k2 of + GT -> go s1 r2 + EQ -> f v1 v2 && go r1 r2 + LT -> False + +-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). +isProperSubmapOf :: (Ord k, Eq a) => IntervalMap k a -> IntervalMap k a -> Bool +isProperSubmapOf m1 m2 = isProperSubmapOfBy (==) m1 m2 + +{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). + The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when + @m1@ and @m2@ are not equal, + all keys in @m1@ are in @m2@, and when @f@ returns 'True' when + applied to their respective values. +-} +isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> IntervalMap k a -> IntervalMap k b -> Bool +isProperSubmapOfBy f t1 t2 = size t1 < size t2 && isSubmapOfBy f t1 t2 + + +-- debugging + +-- | Check red-black-tree and interval search augmentation invariants. +-- For testing/debugging only. +valid :: (Interval i k, Ord i) => IntervalMap i v -> Bool +valid mp = test mp && height mp <= maxHeight (size mp) && validColor mp + where + test Nil = True + test n@(Node _ _ _ _ l r) = validOrder n && validMax n && test l && test r + validMax (Node _ k m _ lo hi) = m == maxUpper k lo hi + validMax Nil = True + + validOrder (Node _ _ _ _ Nil Nil) = True + validOrder (Node _ k1 _ _ Nil (Node _ k2 _ _ _ _)) = k1 < k2 + validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) Nil) = k1 < k2 + validOrder (Node _ k2 _ _ (Node _ k1 _ _ _ _) (Node _ k3 _ _ _ _)) = k1 < k2 && k2 < k3 + validOrder Nil = True + + -- validColor parentColor blackCount tree + validColor n = blackDepth n >= 0 + + -- return -1 if subtrees have diffrent black depths or two consecutive red nodes are encountered + blackDepth :: IntervalMap k v -> Int + blackDepth Nil = 0 + blackDepth (Node c _ _ _ l r) = case blackDepth l of + ld -> if ld < 0 then ld + else + case blackDepth r of + rd -> if rd < 0 then rd + else if rd /= ld then -1 + else if c == R && (isRed l || isRed r) then -1 + else if c == B then rd + 1 + else rd + diff --git a/Data/IntervalMap/Generic/Interval.hs b/Data/IntervalMap/Generic/Interval.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalMap/Generic/Interval.hs @@ -0,0 +1,112 @@ +-- | +-- Module : Data.IntervalMap.Generic.Interval +-- Copyright : (c) Christoph Breitkopf 2014 +-- License : BSD-style +-- Maintainer : chbreitkopf@gmail.com +-- Stability : experimental +-- Portability : portable +-- +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.IntervalMap.Generic.Interval ( + -- * Interval type + Interval(..), + -- * helper functions for declaring Eq and Ord instances + genericEquals, genericCompare +) where + +import qualified Data.IntervalMap.Interval as I + + +-- | Intervals with endpoints of type @e@. +-- A minimal instance declaration needs to define 'con', 'lowerBound', and 'upperBound'. +class Ord e => Interval i e | i -> e where + -- Construct interval from endpoints + -- con :: e -> e -> i e + + -- | lower and upper bound + lowerBound, upperBound :: i -> e + + -- | Does the interval include its lower bound? + -- Default is True for all values, i.e. closed intervals. + leftClosed :: i -> Bool + leftClosed _ = True + + -- | Does the interval include its upper bound bound? + -- Default is True for all values, i.e. closed intervals. + rightClosed :: i -> Bool + rightClosed _ = True + + overlaps, subsumes, before, after :: i -> i -> Bool + a `before` b = upperBound a < lowerBound b + || (upperBound a == lowerBound b && not (rightClosed a && leftClosed b)) + a `after` b = lowerBound a > upperBound b + || (lowerBound a == upperBound b && not (leftClosed a && rightClosed b)) + a `subsumes` b = (lowerBound a < lowerBound b || (lowerBound a == lowerBound b && (leftClosed a || not (leftClosed b)))) + && + (upperBound a > upperBound b || (upperBound a == upperBound b && (rightClosed a || not (rightClosed b)))) + a `overlaps` b = (lowerBound a < upperBound b || (lowerBound a == upperBound b && leftClosed a && rightClosed b)) + && + (upperBound a > lowerBound b || (upperBound a == lowerBound b && rightClosed a && leftClosed b)) + + above, below, inside :: e -> i -> Bool + p `below` i | leftClosed i = p < lowerBound i + | otherwise = p <= lowerBound i + p `above` i | rightClosed i = p > upperBound i + | otherwise = p >= upperBound i + p `inside` i = not ((p `above` i) || (p `below` i)) + + isEmpty :: i -> Bool + isEmpty i | leftClosed i && rightClosed i = lowerBound i > upperBound i + | otherwise = lowerBound i >= upperBound i + +{- +-- sample instance for tuples: +instance Ord e => Interval (e,e) e where + lowerBound (a,_) = a + upperBound (_,b) = b +-} + +genericEquals :: (Interval i e, Eq e) => i -> i -> Bool +genericEquals a b = lowerBound a == lowerBound b && upperBound a == upperBound b + && leftClosed a == leftClosed b + && rightClosed a == rightClosed b + +genericCompare :: (Interval i e, Ord e) => i -> i -> Ordering +genericCompare a b = case compareL a b of + LT -> LT + GT -> GT + EQ -> compareU a b + +compareL :: (Interval i e, Ord e) => i -> i -> Ordering +compareL a b = case compare (lowerBound a) (lowerBound b) of + LT -> LT + GT -> GT + EQ -> case (leftClosed a, leftClosed b) of + (True, False) -> LT + (False, True) -> GT + _ -> EQ + +compareU :: (Interval i e, Ord e) => i -> i -> Ordering +compareU a b = case compare (upperBound a) (upperBound b) of + LT -> LT + GT -> GT + EQ -> case (rightClosed a, rightClosed b) of + (True, False) -> GT + (False, True) -> LT + _ -> EQ + +instance Ord a => Interval (I.Interval a) a where + lowerBound = I.lowerBound + upperBound = I.upperBound + leftClosed = I.leftClosed + rightClosed = I.rightClosed + overlaps = I.overlaps + subsumes = I.subsumes + before = I.before + after = I.after + above = I.above + below = I.below + inside = I.inside + isEmpty = I.isEmpty diff --git a/Data/IntervalMap/Generic/Lazy.hs b/Data/IntervalMap/Generic/Lazy.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalMap/Generic/Lazy.hs @@ -0,0 +1,155 @@ +{- | +Module : Data.IntervalMap.Lazy +Copyright : (c) Christoph Breitkopf 2011 +License : BSD-style +Maintainer : chbreitkopf@gmail.com +Stability : experimental +Portability : portable + +An implementation of maps from intervals to values. The key intervals may +overlap, and the implementation contains efficient search functions +for all keys containing a point or overlapping an interval. +Closed, open, and half-open intervals can be contained in the same map. + +This module implements the same functions as "Data.IntervalMap.Strict", +but with value-lazy semantics. +-} +module Data.IntervalMap.Generic.Lazy ( + -- * re-export + Interval(..) + -- * Map type + , IntervalMap -- instance Eq,Show,Read + + -- * Operators + , (!), (\\) + + -- * Query + , M.null + , size + , member + , notMember + , M.lookup + , findWithDefault + + -- ** Interval query + , containing + , intersecting + , within + + -- * Construction + , empty + , singleton + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , M.map + , mapWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- ** Fold + , M.foldr, M.foldl + , foldrWithKey, foldlWithKey + + -- * Conversion + , elems + , keys + , keysSet + , assocs + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , toDescList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , M.filter + , filterWithKey + , partition + , partitionWithKey + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , findMin + , findMax + , findLast + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + + -- * Debugging + , valid + + -- * Testing + , height, maxHeight, showStats + + ) where + +import Data.IntervalMap.Generic.Base as M diff --git a/Data/IntervalMap/Generic/Strict.hs b/Data/IntervalMap/Generic/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalMap/Generic/Strict.hs @@ -0,0 +1,567 @@ +{- | +Module : Data.IntervalMap.Generic.Strict +Copyright : (c) Christoph Breitkopf 2014 +License : BSD-style +Maintainer : chbreitkopf@gmail.com +Stability : experimental +Portability : portable + +An implementation of maps from intervals to values. The key intervals +may overlap, and the implementation contains efficient search +functions for all keys containing a point or overlapping an +interval. Closed, open, and half-open intervals can be contained in +the same map. + +The functions in this module are strict in both the keys and the +values. If you need value-lazy maps, use "Data.IntervalMap.Lazy" +instead. The IntervalMap type itself is shared between the lazy and +strict modules, meaning that the same IntervalMap value can be passed +to functions in both modules (although that is rarely needed). + +An IntervalMap cannot contain duplicate keys - if you need to map a +key to multiple values, use a collection as the value type, for +example: @IntervalMap /k/ [/v/]@. + +It is an error to insert an empty interval into a map. This +precondition is not checked by the various construction functions. + +Since many function names (but not the type name) clash with /Prelude/ +names, this module is usually imported @qualified@, e.g. + +> import Data.IntervalMap (IvMap) +> import qualified Data.IntervalMap as IvMap + +It offers most of the same functions as 'Data.Map', but uses +'Interval' /k/ instead of just /k/ as the key type. Some of the +functions need stricter type constraints to maintain the additional +information for efficient interval searching, for example +'fromDistinctAscList' needs an 'Ord' /k/ constraint. Also, some +functions differ in asymptotic performance (for example 'size') or +have not been tuned for efficiency as much as their equivalents in +'Data.Map' (in particular the various set functions). + +In addition, there are functions specific to maps of intervals, for +example to search for all keys containing a given point or contained +in a given interval. + +The implementation is a red-black tree augmented with the maximum +upper bound of all keys. + +Parts of this implementation are based on code from the 'Data.Map' +implementation, (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008. The +red-black tree deletion is based on code from llrbtree by Kazu +Yamamoto. Of course, any errors are mine. +-} +module Data.IntervalMap.Generic.Strict ( + -- * re-export + Interval(..) + -- * Map type + , IntervalMap -- instance Eq,Show,Read + + -- * Operators + , (!), (\\) + + -- * Query + , null + , size + , member + , notMember + , lookup + , findWithDefault + + -- ** Interval query + , containing + , intersecting + , within + + -- * Construction + , empty + , singleton + + -- ** Insertion + , insert + , insertWith + , insertWithKey + , insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeys + , mapKeysWith + , mapKeysMonotonic + + -- ** Fold + , foldr, foldl + , foldrWithKey, foldlWithKey + + -- * Conversion + , elems + , keys + , keysSet + , assocs + + -- ** Lists + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , toDescList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , partition + , partitionWithKey + + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + + , split + , splitLookup + + -- * Submap + , isSubmapOf, isSubmapOfBy + , isProperSubmapOf, isProperSubmapOfBy + + -- * Min\/Max + , findMin + , findMax + , findLast + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + , minView + , maxView + , minViewWithKey + , maxViewWithKey + + -- * Debugging + , valid + + -- * Testing + , height, maxHeight, showStats + + ) where + +import Prelude hiding (null, lookup, map, filter, foldr, foldl) +import qualified Data.List as L +import Data.IntervalMap.Generic.Base as M hiding ( + singleton + , insert + , insertWith + , insertWithKey + , findWithDefault + , insertLookupWithKey + , adjust + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + , alter + , unionWith + , unionWithKey + , unionsWith + , differenceWith + , differenceWithKey + , intersectionWith + , intersectionWithKey + , map + , mapWithKey + , mapAccum + , mapAccumWithKey + , mapAccumRWithKey + , mapKeysWith + , fromList + , fromListWith + , fromListWithKey + , fromAscList + , fromAscListWith + , fromAscListWithKey + , mapMaybe + , mapMaybeWithKey + , mapEither + , mapEitherWithKey + , updateMin + , updateMax + , updateMinWithKey + , updateMaxWithKey + ) + +-- | /O(1)/. A map with one entry. +singleton :: k -> v -> IntervalMap k v +singleton k v = v `seq` Node B k k v Nil Nil + + +-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- the value at key @k@ or returns default value @def@ +-- when the key is not in the map. +-- +-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' +-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' +findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a +findWithDefault def k m = def `seq` case M.lookup k m of + Nothing -> def + Just x -> x + +-- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is +-- changed to the new value. +insert :: (Interval k e, Ord k) => k -> v -> IntervalMap k v -> IntervalMap k v +insert = insertWithKey (\_ v _ -> v) + +-- | /O(log n)/. Insert with a function, combining new value and old value. +-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert the pair @(key, f new_value old_value)@. +insertWith :: (Interval k e, Ord k) => (v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v +insertWith f = insertWithKey (\_ new old -> f new old) + +-- | /O(log n)/. Insert with a function, combining key, new value and old value. +-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does +-- not exist in the map. If the key does exist, the function will +-- insert the pair @(key, f key new_value old_value)@. +-- Note that the key passed to f is the same key passed to 'insertWithKey'. +insertWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> IntervalMap k v +insertWithKey f key value mp = key `seq` turnBlack (ins mp) + where + singletonR k v = Node R k k v Nil Nil + ins Nil = value `seq` singletonR key value + ins (Node color k m v l r) = + case compare key k of + LT -> balanceL color k v (ins l) r + GT -> balanceR color k v l (ins r) + EQ -> let v' = f k value v in v' `seq` Node color k m v' l r + + +-- | /O(log n)/. Combine insert with old values retrieval. +insertLookupWithKey :: (Interval k e, Ord k) => (k -> v -> v -> v) -> k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v) +insertLookupWithKey f key value mp = key `seq` (oldval, turnBlack mp') + where + (oldval, mp') = ins mp + singletonR k v = Node R k k v Nil Nil + ins Nil = value `seq` (Nothing, singletonR key value) + ins (Node color k m v l r) = + case compare key k of + LT -> case ins l of + (x@(Just _), t') -> (x, Node color k m v t' r) + (Nothing, t') -> (Nothing, balanceL color k v t' r) + GT -> case ins r of + (x@(Just _), t') -> (x, Node color k m v l t') + (Nothing, t') -> (Nothing, balanceR color k v l t') + EQ -> let v' = f k value v in v' `seq` (Just v, Node color k m v' l r) + + +-- | /O(log n)/. Update a value at a specific key with the result of the provided function. +-- When the key is not +-- a member of the map, the original map is returned. +adjust :: Ord k => (a -> a) -> k -> IntervalMap k a -> IntervalMap k a +adjust f k m = adjustWithKey (\_ v -> f v) k m + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: Ord k => (k -> a -> a) -> k -> IntervalMap k a -> IntervalMap k a +adjustWithKey _ _ Nil = Nil +adjustWithKey f x (Node c k m v l r) = + case compare x k of + LT -> Node c k m v (adjustWithKey f x l) r + GT -> Node c k m v l (adjustWithKey f x r) + EQ -> let v' = f k v in v' `seq` Node c k m v' l r + +-- | /O(log n)/. Update or delete value at minimum key. +updateMin :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMin f m = updateMinWithKey (\_ v -> f v) m + +-- | /O(log n)/. Update or delete value at maximum key. +updateMax :: (Interval k e, Ord k) => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMax f m = updateMaxWithKey (\_ v -> f v) m + +-- | /O(log n)/. Update or delete value at minimum key. +updateMinWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMinWithKey _ Nil = Nil +updateMinWithKey f m = let (k,v) = findMin m in + case f k v of + Just v' -> v' `seq` setMinValue v' m + Nothing -> deleteMin m + +-- | /O(log n)/. Update or delete value at maximum key. +updateMaxWithKey :: (Interval k e, Ord k) => (k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v +updateMaxWithKey _ Nil = Nil +updateMaxWithKey f m = let (k,v) = findMax m in + case f k v of + Just v' -> v' `seq` setMaxValue v' m + Nothing -> deleteMax m + +-- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. +-- If the list contains more than one value for the same key, the last value +-- for the key is retained. +fromList :: (Interval k e, Ord k) => [(k,v)] -> IntervalMap k v +fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs + +-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: (Interval k e, Ord k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs + +-- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromListWithKey f xs = L.foldl' ins empty xs + where + ins t (k,x) = insertWithKey f k x t + +-- | /O(n)/. Build a map from an ascending list in linear time. +-- /The precondition (input list is ascending) is not checked./ +fromAscList :: (Interval k e, Eq k) => [(k,v)] -> IntervalMap k v +fromAscList xs = fromAscListWith (\_ b -> b) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- /The precondition (input list is ascending) is not checked./ +fromAscListWith :: (Interval k e, Eq k) => (a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- /The precondition (input list is ascending) is not checked./ +fromAscListWithKey :: (Interval k e, Eq k) => (k -> a -> a -> a) -> [(k,a)] -> IntervalMap k a +fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) + +combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] +combineEq _ [] = [] +combineEq _ xs@[_] = xs +combineEq f (x@(xk,xv) : xs@((yk,yv) : xs')) + | xk == yk = let v' = f xk xv yv in v' `seq` combineEq f ((xk, v') : xs') + | otherwise = x : combineEq f xs + + +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> IntervalMap k a -> IntervalMap k b +map f = mapWithKey (\_ x -> f x) + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (k -> a -> b) -> IntervalMap k a -> IntervalMap k b +mapWithKey f = go + where + go Nil = Nil + go (Node c k m v l r) = let v' = f k v in v' `seq` Node c k m v' (go l) (go r) + +-- | /O(n)/. The function 'mapAccum' threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a b = (a ++ b, b ++ "X") +-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) +mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) +mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m + +-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating +-- argument through the map in ascending order of keys. +-- +-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") +-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) +mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) +mapAccumWithKey f = go + where + go a Nil = (a,Nil) + go a (Node c kx m x l r) = + let (a1,l') = go a l + (a2,x') = f a1 kx x + (a3,r') = go a2 r + in x' `seq` (a3, Node c kx m x' l' r') + +-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating +-- argument through the map in descending order of keys. +mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) +mapAccumRWithKey f = go + where + go a Nil = (a, Nil) + go a (Node c kx m x l r) = + let (a1,r') = go a r + (a2,x') = f a1 kx x + (a3,l') = go a2 l + in x' `seq` (a3, Node c kx m x' l' r') + + +-- | /O(n)/. Map values and collect the 'Just' results. +mapMaybe :: (Interval k e) => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b +mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m + +-- | /O(n)/. Map keys\/values and collect the 'Just' results. +mapMaybeWithKey :: (Interval k e) => (k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b +mapMaybeWithKey f m = fromDistinctAscList (mapf [] m) + where + mapf z Nil = z + mapf z (Node _ k _ v l r) = mapf (f' k v z r) l + f' k v z r = case f k v of + Nothing -> mapf z r + Just v' -> v' `seq` (k,v') : mapf z r + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +mapEither :: (Interval k e) => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) +mapEither f m = mapEitherWithKey (\_ v -> f v) m + +-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: (Interval k e) => (k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) +mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r) + where + (l, r) = part [] [] (toDescList m) + part ls rs [] = (ls, rs) + part ls rs ((k,v):xs) = case f k v of + Left v' -> v' `seq` part ((k,v'):ls) rs xs + Right v' -> v' `seq` part ls ((k,v'):rs) xs + + +-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in a 'Map'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. +alter :: (Interval k e, Ord k) => (Maybe a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a +alter f x m = case lookup x m of + Nothing -> case f Nothing of + Nothing -> m + Just v -> insert x v m + y -> case f y of + Nothing -> delete x m + Just v' -> adjust (const v') x m + + +-- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- keys to the same new key. In this case the associated values will be +-- combined using @c@. +mapKeysWith :: (Interval k2 e, Ord k2) => (a -> a -> a) -> (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a +mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ] + +-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +update :: (Interval k e, Ord k) => (a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a +update f k m = updateWithKey (\_ v -> f v) k m + +-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', +-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound +-- to the new value @y@. +updateWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> IntervalMap k a +updateWithKey f k m = snd (updateLookupWithKey f k m) + +-- | /O(log n)/. Lookup and update. See also 'updateWithKey'. +-- The function returns changed value, if it is updated. +-- Returns the original key value if the map entry is deleted. +updateLookupWithKey :: (Interval k e, Ord k) => (k -> a -> Maybe a) -> k -> IntervalMap k a -> (Maybe a, IntervalMap k a) +updateLookupWithKey f x m = case lookup x m of + Nothing -> (Nothing, m) + r@(Just v) -> case f x v of + Nothing -> (r, delete x m) + r'@(Just v') -> (r', adjust (const v') x m) + + +-- | /O(n+m)/. Union with a combining function. +unionWith :: (Interval k e, Ord k) => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a +unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 + +-- | /O(n+m)/. Union with a combining function. +unionWithKey :: (Interval k e, Ord k) => (k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a +unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2)) + +-- | The union of a list of maps, with a combining operation: +-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). +unionsWith :: (Interval k e, Ord k) => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a +unionsWith f = L.foldl (unionWith f) empty + +-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are +-- encountered, the combining function is applied to the values of these keys. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWith :: (Interval k e, Ord k) => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a +differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2 + +-- | /O(n+m)/. Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the key and both values. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWithKey :: (Interval k e, Ord k) => (k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a +differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2)) + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWith :: (Interval k e, Ord k) => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWithKey :: (Interval k e, Ord k) => (k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c +intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2)) + + +ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)] +ascListUnion _ [] [] = [] +ascListUnion _ [] ys = ys +ascListUnion _ xs [] = xs +ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') = + case compare xk yk of + LT -> x : ascListUnion f xs' ys + GT -> y : ascListUnion f xs ys' + EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListUnion f xs' ys' + +ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)] +ascListDifference _ [] _ = [] +ascListDifference _ xs [] = xs +ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') = + case compare xk yk of + LT -> x : ascListDifference f xs' ys + GT -> ascListDifference f xs ys' + EQ -> case f xk xv yv of + Nothing -> ascListDifference f xs' ys' + Just v' -> v' `seq` (xk,v') : ascListDifference f xs' ys' + +ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)] +ascListIntersection _ [] _ = [] +ascListIntersection _ _ [] = [] +ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') = + case compare xk yk of + LT -> ascListIntersection f xs' ys + GT -> ascListIntersection f xs ys' + EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListIntersection f xs' ys' diff --git a/Data/IntervalMap/Lazy.hs b/Data/IntervalMap/Lazy.hs --- a/Data/IntervalMap/Lazy.hs +++ b/Data/IntervalMap/Lazy.hs @@ -16,7 +16,7 @@ -} module Data.IntervalMap.Lazy ( -- * re-export - Interval(..) + I.Interval(..) -- * Map type , IntervalMap -- instance Eq,Show,Read @@ -152,4 +152,9 @@ ) where -import Data.IntervalMap.Base as M +import Data.IntervalMap.Interval as I +import Data.IntervalMap.Generic.Lazy hiding (IntervalMap, null, filter, lookup, map, foldr, foldl) +import qualified Data.IntervalMap.Generic.Lazy as M + + +type IntervalMap k v = M.IntervalMap (I.Interval k) v diff --git a/Data/IntervalMap/Strict.hs b/Data/IntervalMap/Strict.hs --- a/Data/IntervalMap/Strict.hs +++ b/Data/IntervalMap/Strict.hs @@ -60,7 +60,7 @@ -} module Data.IntervalMap.Strict ( -- * re-export - Interval(..) + I.Interval(..) -- * Map type , IntervalMap -- instance Eq,Show,Read @@ -196,378 +196,10 @@ ) where -import Prelude hiding (null, lookup, map, filter, foldr, foldl) -import qualified Data.List as L -import Data.IntervalMap.Base as M hiding ( - singleton - , insert - , insertWith - , insertWithKey - , findWithDefault - , insertLookupWithKey - , adjust - , adjustWithKey - , update - , updateWithKey - , updateLookupWithKey - , alter - , unionWith - , unionWithKey - , unionsWith - , differenceWith - , differenceWithKey - , intersectionWith - , intersectionWithKey - , map - , mapWithKey - , mapAccum - , mapAccumWithKey - , mapAccumRWithKey - , mapKeysWith - , fromList - , fromListWith - , fromListWithKey - , fromAscList - , fromAscListWith - , fromAscListWithKey - , mapMaybe - , mapMaybeWithKey - , mapEither - , mapEitherWithKey - , updateMin - , updateMax - , updateMinWithKey - , updateMaxWithKey - ) --- | /O(1)/. A map with one entry. -singleton :: Interval k -> v -> IntervalMap k v -singleton k v = v `seq` Node B k k v Nil Nil - - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns default value @def@ --- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' --- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' -findWithDefault :: Ord k => a -> Interval k -> IntervalMap k a -> a -findWithDefault def k m = def `seq` case M.lookup k m of - Nothing -> def - Just x -> x - --- | /O(log n)/. Insert a new key/value pair. If the map already contains the key, its value is --- changed to the new value. -insert :: (Ord k) => Interval k -> v -> IntervalMap k v -> IntervalMap k v -insert = insertWithKey (\_ v _ -> v) - --- | /O(log n)/. Insert with a function, combining new value and old value. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key, f new_value old_value)@. -insertWith :: (Ord k) => (v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -insertWith f = insertWithKey (\_ new old -> f new old) - --- | /O(log n)/. Insert with a function, combining key, new value and old value. --- @'insertWithKey' f key value mp@ --- will insert the pair (key, value) into @mp@ if key does --- not exist in the map. If the key does exist, the function will --- insert the pair @(key, f key new_value old_value)@. --- Note that the key passed to f is the same key passed to 'insertWithKey'. -insertWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> IntervalMap k v -insertWithKey f key value mp = key `seq` turnBlack (ins mp) - where - singletonR k v = Node R k k v Nil Nil - ins Nil = value `seq` singletonR key value - ins (Node color k m v l r) = - case compare key k of - LT -> balanceL color k v (ins l) r - GT -> balanceR color k v l (ins r) - EQ -> let v' = f k value v in v' `seq` Node color k m v' l r - - --- | /O(log n)/. Combine insert with old values retrieval. -insertLookupWithKey :: (Ord k) => (Interval k -> v -> v -> v) -> Interval k -> v -> IntervalMap k v -> (Maybe v, IntervalMap k v) -insertLookupWithKey f key value mp = key `seq` (oldval, turnBlack mp') - where - (oldval, mp') = ins mp - singletonR k v = Node R k k v Nil Nil - ins Nil = value `seq` (Nothing, singletonR key value) - ins (Node color k m v l r) = - case compare key k of - LT -> case ins l of - (x@(Just _), t') -> (x, Node color k m v t' r) - (Nothing, t') -> (Nothing, balanceL color k v t' r) - GT -> case ins r of - (x@(Just _), t') -> (x, Node color k m v l t') - (Nothing, t') -> (Nothing, balanceR color k v l t') - EQ -> let v' = f k value v in v' `seq` (Just v, Node color k m v' l r) - - --- | /O(log n)/. Update a value at a specific key with the result of the provided function. --- When the key is not --- a member of the map, the original map is returned. -adjust :: Ord k => (a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a -adjust f k m = adjustWithKey (\_ v -> f v) k m - --- | /O(log n)/. Adjust a value at a specific key. When the key is not --- a member of the map, the original map is returned. -adjustWithKey :: Ord k => (Interval k -> a -> a) -> Interval k -> IntervalMap k a -> IntervalMap k a -adjustWithKey _ _ Nil = Nil -adjustWithKey f x (Node c k m v l r) = - case compare x k of - LT -> Node c k m v (adjustWithKey f x l) r - GT -> Node c k m v l (adjustWithKey f x r) - EQ -> let v' = f k v in v' `seq` Node c k m v' l r - --- | /O(log n)/. Update or delete value at minimum key. -updateMin :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMin f m = updateMinWithKey (\_ v -> f v) m - --- | /O(log n)/. Update or delete value at maximum key. -updateMax :: Ord k => (v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMax f m = updateMaxWithKey (\_ v -> f v) m - --- | /O(log n)/. Update or delete value at minimum key. -updateMinWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMinWithKey _ Nil = Nil -updateMinWithKey f m = let (k,v) = findMin m in - case f k v of - Just v' -> v' `seq` setMinValue v' m - Nothing -> deleteMin m - --- | /O(log n)/. Update or delete value at maximum key. -updateMaxWithKey :: Ord k => (Interval k -> v -> Maybe v) -> IntervalMap k v -> IntervalMap k v -updateMaxWithKey _ Nil = Nil -updateMaxWithKey f m = let (k,v) = findMax m in - case f k v of - Just v' -> v' `seq` setMaxValue v' m - Nothing -> deleteMax m - --- | /O(n log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'. --- If the list contains more than one value for the same key, the last value --- for the key is retained. -fromList :: Ord k => [(Interval k,v)] -> IntervalMap k v -fromList xs = L.foldl' (\m (k,v) -> insert k v m) empty xs - --- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -fromListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs - --- | /O(n log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. -fromListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromListWithKey f xs = L.foldl' ins empty xs - where - ins t (k,x) = insertWithKey f k x t - --- | /O(n)/. Build a map from an ascending list in linear time. --- /The precondition (input list is ascending) is not checked./ -fromAscList :: Ord k => [(Interval k,v)] -> IntervalMap k v -fromAscList xs = fromAscListWith (\_ b -> b) xs - --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ -fromAscListWith :: Ord k => (a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWith f xs = fromAscListWithKey (\_ a b -> f a b) xs - --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. --- /The precondition (input list is ascending) is not checked./ -fromAscListWithKey :: Ord k => (Interval k -> a -> a -> a) -> [(Interval k,a)] -> IntervalMap k a -fromAscListWithKey f xs = fromDistinctAscList (combineEq f xs) - -combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -combineEq _ [] = [] -combineEq _ xs@[_] = xs -combineEq f (x@(xk,xv) : xs@((yk,yv) : xs')) - | xk == yk = let v' = f xk xv yv in v' `seq` combineEq f ((xk, v') : xs') - | otherwise = x : combineEq f xs - - --- | /O(n)/. Map a function over all values in the map. -map :: (a -> b) -> IntervalMap k a -> IntervalMap k b -map f = mapWithKey (\_ x -> f x) - --- | /O(n)/. Map a function over all values in the map. -mapWithKey :: (Interval k -> a -> b) -> IntervalMap k a -> IntervalMap k b -mapWithKey f = go - where - go Nil = Nil - go (Node c k m v l r) = let v' = f k v in v' `seq` Node c k m v' (go l) (go r) - --- | /O(n)/. The function 'mapAccum' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) -mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) -mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m - --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating --- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) -mapAccumWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) -mapAccumWithKey f = go - where - go a Nil = (a,Nil) - go a (Node c kx m x l r) = - let (a1,l') = go a l - (a2,x') = f a1 kx x - (a3,r') = go a2 r - in x' `seq` (a3, Node c kx m x' l' r') - --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating --- argument through the map in descending order of keys. -mapAccumRWithKey :: (a -> Interval k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) -mapAccumRWithKey f = go - where - go a Nil = (a, Nil) - go a (Node c kx m x l r) = - let (a1,r') = go a r - (a2,x') = f a1 kx x - (a3,l') = go a2 l - in x' `seq` (a3, Node c kx m x' l' r') - - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybe :: Ord k => (a -> Maybe b) -> IntervalMap k a -> IntervalMap k b -mapMaybe f m = mapMaybeWithKey (\_ v -> f v) m - --- | /O(n)/. Map keys\/values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (Interval k -> a -> Maybe b) -> IntervalMap k a -> IntervalMap k b -mapMaybeWithKey f m = fromDistinctAscList (mapf [] m) - where - mapf z Nil = z - mapf z (Node _ k _ v l r) = mapf (f' k v z r) l - f' k v z r = case f k v of - Nothing -> mapf z r - Just v' -> v' `seq` (k,v') : mapf z r - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEither :: Ord k => (a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) -mapEither f m = mapEitherWithKey (\_ v -> f v) m - --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (Interval k -> a -> Either b c) -> IntervalMap k a -> (IntervalMap k b, IntervalMap k c) -mapEitherWithKey f m = (fromDistinctAscList l, fromDistinctAscList r) - where - (l, r) = part [] [] (toDescList m) - part ls rs [] = (ls, rs) - part ls rs ((k,v):xs) = case f k v of - Left v' -> v' `seq` part ((k,v'):ls) rs xs - Right v' -> v' `seq` part ls ((k,v'):rs) xs - - --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. --- 'alter' can be used to insert, delete, or update a value in a 'Map'. --- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. -alter :: Ord k => (Maybe a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a -alter f x m = case lookup x m of - Nothing -> case f Nothing of - Nothing -> m - Just v -> insert x v m - y -> case f y of - Nothing -> delete x m - Just v' -> adjust (const v') x m - - --- | /O(n log n)/. @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --- --- The size of the result may be smaller if @f@ maps two or more distinct --- keys to the same new key. In this case the associated values will be --- combined using @c@. -mapKeysWith :: Ord k2 => (a -> a -> a) -> (Interval k1 -> Interval k2) -> IntervalMap k1 a -> IntervalMap k2 a -mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ] - --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ --- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is --- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. -update :: Ord k => (a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a -update f k m = updateWithKey (\_ v -> f v) k m - --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the --- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', --- the element is deleted. If it is (@'Just' y@), the key @k@ is bound --- to the new value @y@. -updateWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> IntervalMap k a -updateWithKey f k m = snd (updateLookupWithKey f k m) - --- | /O(log n)/. Lookup and update. See also 'updateWithKey'. --- The function returns changed value, if it is updated. --- Returns the original key value if the map entry is deleted. -updateLookupWithKey :: Ord k => (Interval k -> a -> Maybe a) -> Interval k -> IntervalMap k a -> (Maybe a, IntervalMap k a) -updateLookupWithKey f x m = case lookup x m of - Nothing -> (Nothing, m) - r@(Just v) -> case f x v of - Nothing -> (r, delete x m) - r'@(Just v') -> (r', adjust (const v') x m) - - --- | /O(n+m)/. Union with a combining function. -unionWith :: Ord k => (a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a -unionWith f m1 m2 = unionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 - --- | /O(n+m)/. Union with a combining function. -unionWithKey :: Ord k => (Interval k -> a -> a -> a) -> IntervalMap k a -> IntervalMap k a -> IntervalMap k a -unionWithKey f m1 m2 = fromDistinctAscList (ascListUnion f (toAscList m1) (toAscList m2)) - --- | The union of a list of maps, with a combining operation: --- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). -unionsWith :: Ord k => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a -unionsWith f = L.foldl (unionWith f) empty - --- | /O(n+m)/. Difference with a combining function. --- When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWith :: Ord k => (a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a -differenceWith f m1 m2 = differenceWithKey (\_ v1 v2 -> f v1 v2) m1 m2 - --- | /O(n+m)/. Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the key and both values. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWithKey :: Ord k => (Interval k -> a -> b -> Maybe a) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k a -differenceWithKey f m1 m2 = fromDistinctAscList (ascListDifference f (toAscList m1) (toAscList m2)) - --- | /O(n+m)/. Intersection with a combining function. -intersectionWith :: Ord k => (a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c -intersectionWith f m1 m2 = intersectionWithKey (\_ v1 v2 -> f v1 v2) m1 m2 - --- | /O(n+m)/. Intersection with a combining function. -intersectionWithKey :: Ord k => (Interval k -> a -> b -> c) -> IntervalMap k a -> IntervalMap k b -> IntervalMap k c -intersectionWithKey f m1 m2 = fromDistinctAscList (ascListIntersection f (toAscList m1) (toAscList m2)) +import Data.IntervalMap.Interval as I +import Data.IntervalMap.Generic.Strict hiding (IntervalMap, null, filter, lookup, map, foldr, foldl) +import qualified Data.IntervalMap.Generic.Strict as M -ascListUnion :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] -> [(k,a)] -ascListUnion _ [] [] = [] -ascListUnion _ [] ys = ys -ascListUnion _ xs [] = xs -ascListUnion f xs@(x@(xk,xv):xs') ys@(y@(yk,yv):ys') = - case compare xk yk of - LT -> x : ascListUnion f xs' ys - GT -> y : ascListUnion f xs ys' - EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListUnion f xs' ys' - -ascListDifference :: Ord k => (k -> a -> b -> Maybe a) -> [(k,a)] -> [(k,b)] -> [(k,a)] -ascListDifference _ [] _ = [] -ascListDifference _ xs [] = xs -ascListDifference f xs@(x@(xk,xv):xs') ys@((yk,yv):ys') = - case compare xk yk of - LT -> x : ascListDifference f xs' ys - GT -> ascListDifference f xs ys' - EQ -> case f xk xv yv of - Nothing -> ascListDifference f xs' ys' - Just v' -> v' `seq` (xk,v') : ascListDifference f xs' ys' - -ascListIntersection :: Ord k => (k -> a -> b -> c) -> [(k,a)] -> [(k,b)] -> [(k,c)] -ascListIntersection _ [] _ = [] -ascListIntersection _ _ [] = [] -ascListIntersection f xs@((xk,xv):xs') ys@((yk,yv):ys') = - case compare xk yk of - LT -> ascListIntersection f xs' ys - GT -> ascListIntersection f xs ys' - EQ -> let v' = f xk xv yv in v' `seq` (xk, v') : ascListIntersection f xs' ys' +type IntervalMap k v = M.IntervalMap (I.Interval k) v diff --git a/IntervalMap.cabal b/IntervalMap.cabal --- a/IntervalMap.cabal +++ b/IntervalMap.cabal @@ -1,5 +1,5 @@ Name: IntervalMap -Version: 0.3.0.3 +Version: 0.4.0.0 Stability: experimental Synopsis: Maps from Intervals to values, with efficient search. Homepage: http://www.chr-breitkopf.de/comp/IntervalMap @@ -12,7 +12,7 @@ Category: Data Build-type: Simple Cabal-version: >= 1.8 -Tested-With: GHC==7.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.0.4, GHC==6.12.1 +Tested-With: GHC==7.8.3 Description: A map from intervals to values, with efficient search for all keys containing a point or overlapping an interval. @@ -25,8 +25,11 @@ Library Exposed-modules: Data.IntervalMap, Data.IntervalMap.Lazy, - Data.IntervalMap.Strict, Data.IntervalMap.Interval - other-modules: Data.IntervalMap.Base + Data.IntervalMap.Strict, Data.IntervalMap.Interval, + Data.IntervalMap.Generic.Interval, + Data.IntervalMap.Generic.Lazy, + Data.IntervalMap.Generic.Strict + other-modules: Data.IntervalMap.Generic.Base Build-depends: base >= 4 && < 5, containers, deepseq ghc-options: -Wall if impl(ghc >= 6.8) @@ -39,6 +42,14 @@ build-depends: base >= 4 && < 5, containers, deepseq, QuickCheck, Cabal >= 1.9.2 + +Test-Suite TestGenericInterval + type: exitcode-stdio-1.0 + main-is: GenericIntervalTests.hs + hs-source-dirs: . test + build-depends: base >= 4 && < 5, containers, deepseq, + QuickCheck, Cabal >= 1.9.2 + Test-Suite TestIntervalMap type: exitcode-stdio-1.0 main-is: IntervalMapTests.hs @@ -50,6 +61,15 @@ type: exitcode-stdio-1.0 hs-source-dirs: . bench main-is: BenchAll.hs + Build-depends: base >= 4 && < 5, + containers, random, deepseq, + criterion >= 1.0 + ghc-options: -Wall + +benchmark bench-generic-lazy-strict + type: exitcode-stdio-1.0 + hs-source-dirs: . bench + main-is: GenericLazyVsStrict.hs Build-depends: base >= 4 && < 5, containers, random, deepseq, criterion >= 1.0 diff --git a/bench/BenchAll.hs b/bench/BenchAll.hs --- a/bench/BenchAll.hs +++ b/bench/BenchAll.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + import Criterion.Main import Criterion.Types (Config(..)) @@ -10,6 +13,7 @@ import Data.IntervalMap.Interval import qualified Data.Map as D import qualified Data.IntervalMap as M +import qualified Data.IntervalMap.Generic.Lazy as G seed :: Int @@ -45,35 +49,49 @@ cDATA_SIZE :: Int cDATA_SIZE = 10000 +instance Ord a => G.Interval (a,a) a where + lowerBound (a,_) = a + upperBound (_,a) = a + main :: IO () main = do let ivs = genRandomIntervals cDATA_SIZE 20 cDATA_SIZE let ivs2 = genRandomIntervals cDATA_SIZE 20 (cDATA_SIZE `quot` 2) ivsP <- ensure $ [(ClosedInterval lo hi, lo) | (lo,hi) <- ivs] + ivsG <- ensure $ [(iv,lo) | iv@(lo,_) <- ivs] oIvsP <- ensure $ sort ivsP + oIvsG <- ensure $ sort ivsG lookupKeys <- ensure $ [i | (i,_) <- ivsP] + lookupKeysG <- ensure $ [i | (i,_) <- ivsG] dMap <- ensure $ D.fromList ivsP dIvMap <- ensure $ M.fromList ivsP + gIvMap <- ensure $ G.fromList ivsG dMapSmall <- ensure $ D.fromList [(ClosedInterval lo hi, lo) | (lo,hi) <- ivs2] dIvMapSmall <- ensure $ M.fromList [(ClosedInterval lo hi, lo) | (lo,hi) <- ivs2] rndInts <- ensure (genRandomInts 1 cDATA_SIZE cDATA_SIZE) defaultMainWith benchConfig [ bgroup "fromList (insert)" [ bench "Data.Map" $ nf D.fromList ivsP, - bench "IntervalMap" $ nf M.fromList ivsP + bench "IntervalMap" $ nf M.fromList ivsP, + bench "IMGeneric" $ nf G.fromList ivsG ], bgroup "fromAscList" [ bench "Data.Map" $ nf D.fromAscList oIvsP, - bench "IntervalMap" $ nf M.fromAscList oIvsP + bench "IntervalMap" $ nf M.fromAscList oIvsP, + bench "IMGeneric" $ nf G.fromAscList oIvsG ], bgroup "search" [ bench "lookup Data.Map" $ nf (\m -> [D.lookup i m | i <- lookupKeys]) dMap, bench "lookup" $ nf (\m -> [M.lookup i m | i <- lookupKeys]) dIvMap, bench "containing" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.containing` p]) dIvMap, bench "intersecting" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.intersecting` (ClosedInterval p (p+15))]) dIvMap, - bench "within" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.within` (ClosedInterval p (p+15))]) dIvMap + bench "within" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `M.within` (ClosedInterval p (p+15))]) dIvMap, + bench "G lookup" $ nf (\m -> [G.lookup i m | i <- lookupKeysG]) gIvMap, + bench "G containing" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `G.containing` p]) gIvMap, + bench "G intersecting" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `G.intersecting` (p, p+15)]) gIvMap, + bench "G within" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `G.within` (p, p+15)]) gIvMap ], bgroup "mapKeys" [ bench "Data.Map" $ nf (D.mapKeys (move 1)) dMap, @@ -94,6 +112,8 @@ bench "Data.Map Empty/Large" $ nf (\m -> D.union D.empty m) dMap, bench "IntervalMap Large/Empty" $ nf (\m -> M.union m M.empty) dIvMap, bench "IntervalMap Empty/Large" $ nf (\m -> M.union M.empty m) dIvMap, + bench "IMGeneric Large/Empty" $ nf (\m -> G.union m G.empty) gIvMap, + bench "IMGeneric Empty/Large" $ nf (\m -> G.union G.empty m) gIvMap, bench "Data.Map self" $ nf (\m -> D.union m m) dMap, bench "IntervalMap self" $ nf (\m -> M.union m m) dIvMap ], diff --git a/bench/GenericLazyVsStrict.hs b/bench/GenericLazyVsStrict.hs new file mode 100644 --- /dev/null +++ b/bench/GenericLazyVsStrict.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Criterion.Main +import Criterion.Types (Config(..)) + +import Control.DeepSeq +import Prelude hiding (lookup, max, foldr) +import System.Random +import Data.Foldable (foldr) +import Data.List (sort) + +import Data.IntervalMap.Generic.Interval +import qualified Data.IntervalMap.Generic.Lazy as L +import qualified Data.IntervalMap.Generic.Lazy as S + + +seed :: Int +seed = 54321 + +ensure :: NFData a => a -> IO a +ensure xs = xs `deepseq` return xs + +forceRange :: Int -> Int -> Int -> Int +forceRange lo hi n | n >= lo && n <= hi = n + | n < 0 = forceRange lo hi (0 - n) + | otherwise = lo + (n `rem` (1 + hi - lo)) + +genRandomInts :: Int -> Int -> Int -> [Int] +genRandomInts lo hi n = Prelude.map (forceRange lo hi) . take n . randoms . mkStdGen $ seed + +genRandomIntervals :: Int -> Int -> Int -> [(Int,Int)] +genRandomIntervals max lap n = genIvs . take (2*n) . randoms . mkStdGen $ seed + where + genIvs [] = [] + genIvs [_] = [] + genIvs (x:y:xs) = let lo = forceRange 1 max x + sz = forceRange 0 lap y + in (lo, lo + sz) : genIvs xs + + +benchConfig :: Config +benchConfig = defaultConfig { reportFile = Just "bench-lazy-strict.html" } + +cDATA_SIZE :: Int +cDATA_SIZE = 10000 + +data IV = IV {-# UNPACK #-} !Int {-# UNPACK #-} !Int + deriving (Eq, Ord) + +instance NFData IV where + rnf a = a `seq` () + +instance Interval IV Int where + lowerBound (IV l _) = l + upperBound (IV _ u) = u + +move :: Int -> IV -> IV +move n (IV a b) = IV (a+n) (b+n) + + +main :: IO () +main = + do + let ivs = genRandomIntervals cDATA_SIZE 20 cDATA_SIZE + ivsP <- ensure $ [(IV lo hi, lo) | (lo,hi) <- ivs] + oIvsP <- ensure $ sort ivsP + lookupKeys <- ensure $ [i | (i,_) <- ivsP] + sMap <- ensure $ S.fromList ivsP + lMap <- ensure $ L.fromList ivsP + rndInts <- ensure (genRandomInts 1 cDATA_SIZE cDATA_SIZE) + defaultMainWith benchConfig [ + bgroup "fromList (insert)" [ + bench "Lazy" $ nf L.fromList ivsP, + bench "Strict" $ nf S.fromList ivsP + ], + bgroup "fromAscList" [ + bench "Lazy" $ nf L.fromAscList oIvsP, + bench "Strict" $ nf S.fromAscList oIvsP + ], + bgroup "search" [ + bench "lookup lazy" $ nf (\m -> [L.lookup i m | i <- lookupKeys]) lMap, + bench "lookup strict" $ nf (\m -> [S.lookup i m | i <- lookupKeys]) sMap, + bench "containing lazy" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.containing` p]) lMap, + bench "containing strict" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.containing` p]) sMap, + bench "intersecting lazy" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.intersecting` (IV p (p+15))]) lMap, + bench "intersecting strict" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.intersecting` (IV p (p+15))]) sMap, + bench "within lazy" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.within` (IV p (p+15))]) lMap, + bench "within strict" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.within` (IV p (p+15))]) sMap + ], + bgroup "mapKeys" [ + bench "lazy" $ nf (L.mapKeys (move 1)) lMap, + bench "strict" $ nf (S.mapKeys (move 1)) sMap, + bench "monotonic lazy" $ nf (L.mapKeysMonotonic (move 1)) lMap, + bench "monotonic strict" $ nf (S.mapKeysMonotonic (move 1)) sMap + ], + bgroup "map" [ + bench "lazy" $ nf (L.map (1+)) lMap, + bench "strict" $ nf (S.map (1+)) sMap + ], + bgroup "union" [ + bench "Large/Empty lazy" $ nf (\m -> L.union m L.empty) lMap, + bench "Large/Empty strict" $ nf (\m -> S.union m S.empty) sMap, + bench "Empty/Large lazy" $ nf (\m -> L.union L.empty m) lMap, + bench "Empty/Large strict" $ nf (\m -> S.union S.empty m) sMap, + bench "self lazy" $ nf (\m -> L.union m m) lMap, + bench "self strict" $ nf (\m -> S.union m m) sMap + ] + ] diff --git a/examples/Example.lhs b/examples/Example.lhs --- a/examples/Example.lhs +++ b/examples/Example.lhs @@ -1,4 +1,4 @@ -

IntervalMap usage example

+

IntervalMap usage example

In this example I use an IntervalMap to store a set of appointments. The appointments are for several people, so they can overlap. diff --git a/examples/GenericExample.lhs b/examples/GenericExample.lhs new file mode 100644 --- /dev/null +++ b/examples/GenericExample.lhs @@ -0,0 +1,98 @@ +

IntervalMap.generic usage example

+ +In this example I use an IntervalMap to store a set of appointments. +The appointments are for several people, so they can overlap. + +This is a literate Haskell file, you can [download it](Example.lhs) and compile it with +ghc or run in in ghci. You must first install IntervalMap, if you have not already done so: +`cabal install IntervalMap`. + +First, I have to enable some language extensions to be able to +make my own interval type an instance of Interval: + +> {-# LANGUAGE MultiParamTypeClasses #-} +> {-# LANGUAGE FlexibleInstances #-} + +In most cases, you should use the value-strict version, so I import that: + +> import Data.IntervalMap.Generic.Strict + +For readability, here are simple type synonyms for our data types. In production +code, one would of course use newtype or data for this. + +> type Person = String +> type Details = String + +Again for readability, I use strings to represent timestamps. Also, to keep it shorter, +I will omit the date and only use the time of the day in this example, e.g.: "09:00", "12:47". + +> type Time = String +> type TimeSpan = (Time,Time) + +I have a time span include its start time but not its end time. +So I declare an Interval instance for tuples that is closed at the startpoint +but open at the endpoint: + +> instance Ord e => Interval (e,e) e where +> lowerBound (a,_) = a +> upperBound (_,b) = b +> rightClosed _ = False + +Constructing timespans is just using tuples: + +> mkTimeSpan :: Time -> Time -> TimeSpan +> mkTimeSpan from to = (from,to) + +An appointment consists of the timespan, the person, and the appointment details: + +> type Appointment = (TimeSpan, Person, Details) + +For a set of possible overlapping appointments, I store a list of (person, details) +tuples for each timespan: + +> type Appointments = IntervalMap TimeSpan [(Person, Details)] + +Not that the key type is *Time*, not *TimeSpan*. That is, you specify the type of the +endpoints, not the type of the interval itself. + +Now I can define some helper functions. + +A set containing no appointments: + +> noAppointments :: Appointments +> noAppointments = empty + +To add an appointment to a set, I use (++) as a combining function to add +the new appointment: + +> addAppointment :: Person -> Time -> Time -> Details -> Appointments -> Appointments +> addAppointment who from to what = insertWith (++) (mkTimeSpan from to) [(who, what)] + +To look up all appointments at a given time, just get all entries _containing_ +that time: + +> appointmentsAt :: Time -> Appointments -> [Appointment] +> appointmentsAt t apps = [ (time, person, details) +> | (time, pds) <- apps `containing` t, +> (person, details) <- pds ] + +The function to get all appointments that overlap a given timespan is almost +the same, just using _intersecting_ instead: + +> appointmentsDuring :: Time -> Time -> Appointments -> [Appointment] +> appointmentsDuring from to apps = [ (time, person, details) +> | (time, pds) <- apps `intersecting` mkTimeSpan from to, +> (person, details) <- pds ] + +Here is a sample set of appointments and a main function to show some test results: + +> sampleApps :: Appointments +> sampleApps = addAppointment "Paul" "09:00" "11:00" "Dentist" $ +> addAppointment "John" "10:00" "11:30" "Meeting" $ +> addAppointment "Rosy" "10:00" "11:30" "Shopping" $ +> addAppointment "Lisa" "08:45" "09:15" "Bank" $ +> noAppointments +> +> main :: IO () +> main = do putStrLn (show (appointmentsAt "09:00" sampleApps)) +> putStrLn (show (appointmentsDuring "09:30" "10:30" sampleApps)) diff --git a/test/GenericIntervalTests.hs b/test/GenericIntervalTests.hs new file mode 100644 --- /dev/null +++ b/test/GenericIntervalTests.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- module IntervalTests (main) where + +import System.Exit (exitSuccess, exitFailure) + +import Test.QuickCheck +import Test.QuickCheck.Test (isSuccess) +import Control.Monad (liftM) + +import Data.IntervalMap.Generic.Interval + +data IV a = IV !Bool !a !a !Bool deriving (Eq, Show) + +-- Note that we can not derive Ord for intervals with "mixed" closedness. +-- If, in contrast, all values have identical closedness, deriving should work. +instance Ord a => Ord (IV a) where + compare = genericCompare + +instance Ord a => Interval (IV a) a where + lowerBound (IV _ x _ _) = x + upperBound (IV _ _ x _) = x + leftClosed (IV c _ _ _) = c + rightClosed (IV _ _ _ c) = c + +closedInterval, openInterval, intervalCO, intervalOC :: a -> a -> IV a +closedInterval a b = IV True a b True +openInterval a b = IV False a b False +intervalCO a b = IV True a b False +intervalOC a b = IV False a b True + + +c15, o15, co15, oc15 :: IV Int +c15 = closedInterval 1 5 +o15 = openInterval 1 5 +co15 = intervalCO 1 5 +oc15 = intervalOC 1 5 + + +prop_boundsC, prop_boundsO, prop_boundsCO, prop_boundsOC :: Int -> Int -> Bool +prop_boundsC lo hi = let iv = closedInterval lo hi in lowerBound iv == lo && upperBound iv == hi +prop_boundsO lo hi = let iv = openInterval lo hi in lowerBound iv == lo && upperBound iv == hi +prop_boundsCO lo hi = let iv = intervalCO lo hi in lowerBound iv == lo && upperBound iv == hi +prop_boundsOC lo hi = let iv = intervalOC lo hi in lowerBound iv == lo && upperBound iv == hi + +prop_empty = + isEmpty (openInterval 1 1) && + isEmpty (intervalCO 1 1) && + isEmpty (intervalOC 1 1) && + not (isEmpty (closedInterval 1 1)) + +prop_ord = + closedInterval 1 2 < openInterval 1 2 && + closedInterval 2 3 > openInterval 1 2 + + +contains :: Interval i e => i -> e -> Bool +contains = flip inside + +prop_contains1 = + (c15 `contains` 3) && + (o15 `contains` 3) && + (co15 `contains` 3) && + (oc15 `contains` 3) && + (c15 `contains` 1) && + (c15 `contains` 5) && + not (o15 `contains` 1) && + not (o15 `contains` 5) && + (co15 `contains` 1) && + not (co15 `contains` 5) && + not (oc15 `contains` 1) && + (oc15 `contains` 5) + + +prop_overlaps = + (c15 `overlaps` closedInterval 5 6) && + not (c15 `overlaps` openInterval 5 6) && + (c15 `overlaps` intervalCO 5 6) && + not (c15 `overlaps` intervalOC 5 6) && + (c15 `overlaps` closedInterval 0 1) && + not (c15 `overlaps` openInterval 0 1) && + (c15 `overlaps` intervalOC 0 1) && + not (c15 `overlaps` intervalCO 0 1) + +prop_subsumes1 = (c15 `subsumes` o15) && -- closed subsumes open + not (o15 `subsumes` c15) && -- ~? "open does not subsume closed", + not (co15 `subsumes` c15) && -- "open does not subsume closed", + not (oc15 `subsumes` c15) -- "open does not subsume closed" + +ivGen :: Int -> Int -> Gen II +ivGen lo hi = do start <- choose (lo, hi) + size <- choose (0, hi - start) + if size == 0 + then return (II (closedInterval start start)) + else oneof [ + return (II (closedInterval start (start + size))), + return (II (openInterval start (start + size))), + return (II (intervalCO start (start + size))), + return (II (intervalOC start (start + size))) ] + +newtype II = II (IV Int) deriving (Show) + +instance Arbitrary II where + arbitrary = do x <- arbitrary + liftM II (interval (abs x)) + +interval x = do + y <- sized (\n -> choose (x, x + abs n)) + if x == y then return (closedInterval x y) + else oneof [return (closedInterval x y), + return (openInterval x y), + return (intervalCO x y), + return (intervalOC x y)] + +-- our generator will never generate empty intervals +prop_not_empty (II iv) = not (isEmpty iv) + +prop_leftClosed = leftClosed (closedInterval 1 2) && + leftClosed (intervalCO 1 2) && + not (leftClosed (openInterval 1 2)) && + not (leftClosed (intervalOC 1 2)) + +prop_rightClosed = rightClosed (closedInterval 1 2) && + rightClosed (intervalOC 1 2) && + not (rightClosed (openInterval 1 2)) && + not (rightClosed (intervalCO 1 2)) + + +prop_overlaps_symmetric (II i1) (II i2) = (i1 `overlaps` i2) == (i2 `overlaps` i1) + +prop_compare1 (II i1) (II i2) = + case compare (lowerBound i1) (lowerBound i2) of + LT -> compare i1 i2 == LT + GT -> compare i1 i2 == GT + EQ -> True + +prop_contains (II i) p = + if p `inside` i then + lowerBound i <= p && upperBound i >= p + else + p <= lowerBound i || p >= upperBound i + +prop_subsumes (II i1) = forAll subIv (\(II i2) -> (i1 `subsumes` i2) ==> + ((i1 == i2) || not (i2 `subsumes` i1))) + where + subIv = ivGen (lowerBound i1) (upperBound i1) + +prop_equals (II a) (II b) = + (lowerBound a /= lowerBound b || upperBound a /= upperBound b) ==> (a /= b) + +check p name = do r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p + if isSuccess r + then return r + else do putStrLn ("error: " ++ name ++ ": " ++ show r) + exitFailure + + +main = do + check prop_boundsO "boundsO" + check prop_boundsC "boundsC" + check prop_boundsOC "boundsOC" + check prop_boundsCO "boundsCO" + check prop_empty "empty" + check prop_leftClosed "leftClosed" + check prop_rightClosed "rightClosed" + check prop_ord "ord" + check prop_compare1 "compare1" + check prop_contains1 "contains1" + check prop_overlaps "overlaps" + check prop_subsumes1 "subsumes1" + check prop_not_empty "not empty" + check prop_overlaps_symmetric "overlaps symmetric" + check prop_contains "contains" + check prop_subsumes "subsumes" + check prop_equals "equals" + exitSuccess