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