diff --git a/Data/IntervalMap/Generic/Base.hs b/Data/IntervalMap/Generic/Base.hs --- a/Data/IntervalMap/Generic/Base.hs +++ b/Data/IntervalMap/Generic/Base.hs @@ -198,7 +198,7 @@ import qualified Data.Foldable as Foldable import qualified Data.List as L import qualified Data.Set as Set -import Control.DeepSeq (NFData(rnf)) +import Control.DeepSeq import Data.IntervalMap.Generic.Interval @@ -208,6 +208,9 @@ infixl 9 !,\\ -- -- | /O(log n)/. Lookup value for given key. Calls 'error' if the key is not in the map. +-- +-- Use 'lookup' or 'findWithDefault' instead of this function, unless you are absolutely +-- sure that the key is present in the map. (!) :: (Interval k e, Ord k) => IntervalMap k v -> k -> v tree ! key = case lookup key tree of Just v -> v @@ -258,7 +261,7 @@ instance (NFData k, NFData a) => NFData (IntervalMap k a) where rnf Nil = () - rnf (Node _ kx _ x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r + rnf (Node _ kx _ x l r) = kx `deepseq` x `deepseq` l `deepseq` r `deepseq` () instance (Ord k, Read k, Read e, Interval i k, Ord i, Read i) => Read (IntervalMap i e) where readsPrec p = readParen (p > 10) $ \ r -> do @@ -366,10 +369,6 @@ -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@ -- when the key is not in the map. --- --- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x' --- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' - findWithDefault :: Ord k => a -> k -> IntervalMap k a -> a findWithDefault def k m = case lookup k m of Nothing -> def @@ -500,19 +499,17 @@ findMax (Node _ _ _ _ _ r) = findMax r findMax Nil = error "IntervalMap.findMin: empty map" --- | Returns the interval with the largest endpoint. --- If there is more than one interval with that endpoint, --- return the rightmost. +-- | Returns the key with the largest endpoint and its associated value. +-- If there is more than one key with that endpoint, return the rightmost. -- -- /O(n)/, since all keys could have the same endpoint. -- /O(log n)/ average case. findLast :: (Interval k e) => IntervalMap k v -> (k, v) findLast Nil = error "IntervalMap.findLast: empty map" -findLast t@(Node _ _ mx _ _ _) = lastMax +findLast t@(Node _ _ mx _ _ _) = head (go t) where - (lastMax : _) = go t go Nil = [] - go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ ((k,v) : go l) + go (Node _ k m v l r) | sameU m mx = if sameU k m then go r ++ [(k,v)] else go r ++ go l | otherwise = [] sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b @@ -824,12 +821,20 @@ -- | The union of a list of maps: -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). unions :: (Interval k e, Ord k) => [IntervalMap k a] -> IntervalMap k a -unions = L.foldl union empty +unions ms = unionsWith const ms -- | The union of a list of maps, with a combining operation: -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). unionsWith :: (Interval k e, Ord k) => (a -> a -> a) -> [IntervalMap k a] -> IntervalMap k a -unionsWith f = L.foldl (unionWith f) empty +unionsWith _ [] = empty +unionsWith _ [m] = m +unionsWith f ms = fromDistinctAscList (head (go (L.map toAscList ms))) + where + f' _ l r = f l r + merge m1 m2 = ascListUnion f' m1 m2 + go [] = [] + go xs@[_] = xs + go (x:y:xs) = go (merge x y : go xs) -- | /O(n+m)/. Difference of two maps. -- Return elements of the first map not existing in the second map. @@ -1029,17 +1034,11 @@ -- | /O(n)/. The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys. --- --- > let f a b = (a ++ b, b ++ "X") --- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) mapAccum :: (a -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating -- argument through the map in ascending order of keys. --- --- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X") --- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")]) mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> IntervalMap k b -> (a, IntervalMap k c) mapAccumWithKey f = go where @@ -1079,7 +1078,7 @@ mapKeysWith :: (Interval k2 e, Ord k2) => (a -> a -> a) -> (k1 -> k2) -> IntervalMap k1 a -> IntervalMap k2 a mapKeysWith c f m = fromListWith c [ (f k, v) | (k, v) <- toAscList m ] --- | /O(n log n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ +-- | /O(n)/. @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@ -- is strictly monotonic. -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. -- /The precondition is not checked./ @@ -1149,10 +1148,13 @@ -- | /O(n)/. The expression (@'splitLookup' k map@) splits a map just -- like 'split' but also returns @'lookup' k map@. splitLookup :: (Interval i k, Ord i) => i -> IntervalMap i a -> (IntervalMap i a, Maybe a, IntervalMap i a) -splitLookup x m = (fromDistinctAscList less, lookup x m, fromDistinctAscList greater) - where - less = [e | e@(k,_) <- toAscList m, k < x] - greater = [e | e@(k,_) <- toAscList m, k > x] +splitLookup x m = case span (\(k,_) -> k < x) (toAscList m) of + ([], []) -> (empty, Nothing, empty) + ([], ((k,v):_)) | k == x -> (empty, Just v, deleteMin m) + | otherwise -> (empty, Nothing, m) + (_, []) -> (m, Nothing, empty) + (lt, ge@((k,v):gt)) | k == x -> (fromDistinctAscList lt, Just v, fromDistinctAscList gt) + | otherwise -> (fromDistinctAscList lt, Nothing, fromDistinctAscList ge) -- submaps diff --git a/Data/IntervalMap/Generic/Interval.hs b/Data/IntervalMap/Generic/Interval.hs --- a/Data/IntervalMap/Generic/Interval.hs +++ b/Data/IntervalMap/Generic/Interval.hs @@ -11,6 +11,13 @@ -- As there is no sensible default, no instances for prelude types -- are provided (E.g. you might want to have tuples as closed -- intervals in one case, and open in another). +-- +-- Empty intervals, i.e. intervals where 'lowerBound >= upperBound' should be avoided +-- if possible. If you must use empty intervals, you need to provide implementations +-- for all operations, as the default implementations do not necessarily work correctly. +-- for example, the default implementation of 'inside' returns 'True' if the point +-- is equal to the lowerBound of a left-closed interval even if it is larger than +-- the upper bound. {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} @@ -70,13 +77,17 @@ -- | Is a point strictly less than lower bound? below :: e -> i -> Bool - p `below` i | leftClosed i = p < lowerBound i - | otherwise = p <= lowerBound i + p `below` i = case compare p (lowerBound i) of + LT -> True + EQ -> not (leftClosed i) + GT -> False -- | Is a point strictly greater than upper bound? above :: e -> i -> Bool - p `above` i | rightClosed i = p > upperBound i - | otherwise = p >= upperBound i + p `above` i = case compare p (upperBound i) of + LT -> False + EQ -> not (rightClosed i) + GT -> True -- | Does the interval contain a given point? inside :: e -> i -> Bool diff --git a/Data/IntervalMap/Generic/Lazy.hs b/Data/IntervalMap/Generic/Lazy.hs --- a/Data/IntervalMap/Generic/Lazy.hs +++ b/Data/IntervalMap/Generic/Lazy.hs @@ -1,5 +1,5 @@ {- | -Module : Data.IntervalMap.Lazy +Module : Data.IntervalMap.Generic.Lazy Copyright : (c) Christoph Breitkopf 2014 License : BSD-style Maintainer : chbreitkopf@gmail.com diff --git a/Data/IntervalSet.hs b/Data/IntervalSet.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalSet.hs @@ -0,0 +1,769 @@ +-- | +-- Module : Data.IntervalSet +-- Copyright : (c) Christoph Breitkopf 2015 +-- License : BSD-style +-- Maintainer : chbreitkopf@gmail.com +-- Stability : experimental +-- Portability : non-portable (MPTC with FD) +-- +-- An implementation of sets of intervals. The intervals may +-- overlap, and the implementation contains efficient search functions +-- for all intervals containing a point or overlapping a given interval. +-- Closed, open, and half-open intervals can be contained in the same set. +-- +-- It is an error to insert an empty interval into a set. This precondition is not +-- checked by the various construction functions. +-- +-- Since many function names (but not the type name) clash with +-- /Prelude/ names, this module is usually imported @qualified@, e.g. +-- +-- > import Data.IntervalSet.Strict (IntervalSet) +-- > import qualified Data.IntervalSet.Strict as IS +-- +-- It offers most of the same functions as 'Data.Set', but the member type must be an +-- instance of 'Interval'. The 'findMin' and 'findMax' functions deviate from their +-- set counterparts in being total and returning a 'Maybe' value. +-- Some functions differ in asymptotic performance (for example 'size') or have not +-- been tuned for efficiency as much as their equivalents in 'Data.Set'. +-- +-- In addition, there are functions specific to sets of intervals, for example to search +-- for all intervals containing a given point or contained in a given interval. +-- +-- The implementation is a red-black tree augmented with the maximum upper bound +-- of all keys. +-- +-- Parts of this implementation are based on code from the 'Data.Map' implementation, +-- (c) Daan Leijen 2002, (c) Andriy Palamarchuk 2008. +-- The red-black tree deletion is based on code from llrbtree by Kazu Yamamoto. +-- Of course, any errors are mine. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.IntervalSet ( + -- * re-export + Interval(..) + -- * Set type + , IntervalSet(..) -- instance Eq,Show,Read + + -- * Operators + , (\\) + + -- * Query + , null + , size + , member + , notMember + + -- ** Interval query + , containing + , intersecting + , within + + -- * Construction + , empty + , singleton + + -- ** Insertion + , insert + + -- ** Delete\/Update + , delete + + -- * Combine + , union + , unions + , difference + , intersection + + -- * Traversal + -- ** Map + , map + , mapMonotonic + + -- ** Fold + , foldr, foldl + , foldl', foldr' + + -- * Conversion + , elems + + -- ** Lists + , toList + , fromList + + -- ** Ordered lists + , toAscList + , toDescList + , fromAscList + , fromDistinctAscList + + -- * Filter + , filter + , partition + + , split + , splitMember + + -- * Subset + , isSubsetOf, isProperSubsetOf + + -- * Min\/Max + , findMin + , findMax + , findLast + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + , minView + , maxView + + -- * Debugging + , valid + + ) where + +import Prelude hiding (null, lookup, map, filter, foldr, foldl) +import Data.Bits (shiftR, (.&.)) +import Data.Monoid (Monoid(..)) +import qualified Data.Foldable as Foldable +import qualified Data.List as L +import Control.DeepSeq +import qualified Data.Foldable as Foldable + +import Data.IntervalMap.Generic.Interval + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ -- + +-- | Same as 'difference'. +(\\) :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k +m1 \\ m2 = difference m1 m2 + + +data Color = R | B deriving (Eq) + +-- | A set of intervals of type @k@. +data IntervalSet k = Nil + | Node !Color + !k -- key + !k -- interval with maximum upper in tree + !(IntervalSet k) -- left subtree + !(IntervalSet k) -- right subtree + +instance (Eq k) => Eq (IntervalSet k) where + a == b = toAscList a == toAscList b + +instance (Ord k) => Ord (IntervalSet k) where + compare a b = compare (toAscList a) (toAscList b) + +instance (Interval i k, Ord i) => Monoid (IntervalSet i) where + mempty = empty + mappend = union + mconcat = unions + +instance Foldable.Foldable IntervalSet where + fold t = go t + where go Nil = mempty + go (Node _ k _ l r) = go l `mappend` (k `mappend` go r) + foldr = foldr + foldl = foldl + foldMap f t = go t + where go Nil = mempty + go (Node _ k _ l r) = go l `mappend` (f k `mappend` go r) + +instance (NFData k) => NFData (IntervalSet k) where + rnf Nil = () + rnf (Node _ kx _ l r) = kx `deepseq` l `deepseq` r `deepseq` () + +instance (Ord k, Read k, Interval i k, Ord i, Read i) => Read (IntervalSet i) where + readsPrec p = readParen (p > 10) $ \ r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) + +instance (Show k) => Show (IntervalSet k) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + + +isRed :: IntervalSet k -> Bool +isRed (Node R _ _ _ _) = True +isRed _ = False + +turnBlack :: IntervalSet k -> IntervalSet k +turnBlack (Node R k m l r) = Node B k m l r +turnBlack t = t + +turnRed :: IntervalSet k -> IntervalSet k +turnRed Nil = error "turnRed: Leaf" +turnRed (Node B k m l r) = Node R k m l r +turnRed t = t + +-- construct node, recomputing the upper key bound. +mNode :: (Interval k e) => Color -> k -> IntervalSet k -> IntervalSet k -> IntervalSet k +mNode c k l r = Node c k (maxUpper k l r) l r + +maxUpper :: (Interval i k) => i -> IntervalSet i -> IntervalSet i -> i +maxUpper k Nil Nil = k `seq` k +maxUpper k Nil (Node _ _ m _ _) = maxByUpper k m +maxUpper k (Node _ _ m _ _) Nil = maxByUpper k m +maxUpper k (Node _ _ l _ _) (Node _ _ r _ _) = maxByUpper k (maxByUpper l r) + +-- interval with the greatest upper bound. The lower bound is ignored! +maxByUpper :: (Interval i e) => i -> i -> i +maxByUpper a b | rightClosed a = if upperBound a >= upperBound b then a else b + | otherwise = if upperBound a > upperBound b then a else b + +-- --------------------------------------------------------- + +-- | /O(1)/. The empty set. +empty :: IntervalSet k +empty = Nil + +-- | /O(1)/. A set with one entry. +singleton :: k -> IntervalSet k +singleton k = Node B k k Nil Nil + + +-- | /O(1)/. Is the set empty? +null :: IntervalSet k -> Bool +null Nil = True +null _ = False + +-- | /O(n)/. Number of keys in the set. +-- +-- Caution: unlike 'Data.Set.size', this takes linear time! +size :: IntervalSet k -> Int +size t = h 0 t + where + h n s = n `seq` case s of + Nil -> n + Node _ _ _ l r -> h (h n l + 1) r + +-- | /O(log n)/. Does the set contain the given value? See also 'notMember'. +member :: (Ord k) => k -> IntervalSet k -> Bool +member k Nil = k `seq` False +member k (Node _ key _ l r) = case compare k key of + LT -> member k l + GT -> member k r + EQ -> True + +-- | /O(log n)/. Does the set not contain the given value? See also 'member'. +notMember :: (Ord k) => k -> IntervalSet k -> Bool +notMember key tree = not (member key tree) + +-- | Return the set of all intervals containing the given point. +-- +-- /O(n)/, since potentially all intervals could contain the point. +-- /O(log n)/ average case. This is also the worst case for sets containing no overlapping intervals. +containing :: (Interval k e) => IntervalSet k -> e -> IntervalSet k +t `containing` pt = fromDistinctAscList (go [] pt t) + where + go xs p Nil = p `seq` xs + go xs p (Node _ k m l r) + | p `above` m = xs -- above all intervals in the tree: no result + | p `below` k = go xs p l -- to the left of the lower bound: can't be in right subtree + | p `inside` k = go (k : go xs p r) p l + | otherwise = go (go xs p r) p l + +-- | Return the set of all intervals overlapping (intersecting) the given interval. +-- +-- /O(n)/, since potentially all values could intersect the interval. +-- /O(log n)/ average case, if few values intersect the interval. +intersecting :: (Interval k e) => IntervalSet k -> k -> IntervalSet k +t `intersecting` iv = fromDistinctAscList (go [] iv t) + where + go xs i Nil = i `seq` xs + go xs i (Node _ k m l r) + | i `after` m = xs + | i `before` k = go xs i l + | i `overlaps` k = go (k : go xs i r) i l + | otherwise = go (go xs i r) i l + +-- | Return the set of all intervals which are completely inside the given interval. +-- +-- /O(n)/, since potentially all values could be inside the interval. +-- /O(log n)/ average case, if few keys are inside the interval. +within :: (Interval k e) => IntervalSet k -> k -> IntervalSet k +t `within` iv = fromDistinctAscList (go [] iv t) + where + go xs i Nil = i `seq` xs + go xs i (Node _ k m l r) + | i `after` m = xs + | i `before` k = go xs i l + | i `subsumes` k = go (k : go xs i r) i l + | otherwise = go (go xs i r) i l + + +-- | /O(log n)/. Insert a new value. If the set already contains an element equal to the value, +-- it is replaced by the new value. +insert :: (Interval k e, Ord k) => k -> IntervalSet k -> IntervalSet k +insert v s = v `seq` turnBlack (ins s) + where + singletonR k = Node R k k Nil Nil + ins Nil = singletonR v + ins (Node color k m l r) = + case compare v k of + LT -> balanceL color k (ins l) r + GT -> balanceR color k l (ins r) + EQ -> Node color v m l r + +balanceL :: (Interval k e) => Color -> k -> IntervalSet k -> IntervalSet k -> IntervalSet k +balanceL B zk (Node R yk _ (Node R xk _ a b) c) d = + mNode R yk (mNode B xk a b) (mNode B zk c d) +balanceL B zk (Node R xk _ a (Node R yk _ b c)) d = + mNode R yk (mNode B xk a b) (mNode B zk c d) +balanceL c xk l r = mNode c xk l r + +balanceR :: (Interval k e) => Color -> k -> IntervalSet k -> IntervalSet k -> IntervalSet k +balanceR B xk a (Node R yk _ b (Node R zk _ c d)) = + mNode R yk (mNode B xk a b) (mNode B zk c d) +balanceR B xk a (Node R zk _ (Node R yk _ b c) d) = + mNode R yk (mNode B xk a b) (mNode B zk c d) +balanceR c xk l r = mNode c xk l r + + +-- min/max + +-- | /O(log n)/. Returns the least interval in the set. +findMin :: IntervalSet k -> Maybe k +findMin (Node _ k _ Nil _) = Just k +findMin (Node _ _ _ l _) = findMin l +findMin Nil = Nothing + +-- | /O(log n)/. Returns the largest interval in the set. +findMax :: IntervalSet k -> Maybe k +findMax (Node _ k _ _ Nil) = Just k +findMax (Node _ _ _ _ r) = findMax r +findMax Nil = Nothing + +-- | Returns the interval with the largest endpoint. +-- If there is more than one interval with that endpoint, +-- return the rightmost. +-- +-- /O(n)/, since all intervals could have the same endpoint. +-- /O(log n)/ average case. +findLast :: (Interval k e) => IntervalSet k -> Maybe k +findLast Nil = Nothing +findLast t@(Node _ _ mx _ _) = go t + where + go (Node _ k m l r) | sameU m mx = if sameU k m then go r `or` Just k + else go r `or` go l + | otherwise = Nothing + go Nil = Nothing + sameU a b = upperBound a == upperBound b && rightClosed a == rightClosed b + Nothing `or` x = x + x `or` _ = x + + +-- Type to indicate whether the number of black nodes changed or stayed the same. +data DeleteResult k = U !(IntervalSet k) -- Unchanged + | S !(IntervalSet k) -- Shrunk + +unwrap :: DeleteResult k -> IntervalSet k +unwrap (U m) = m +unwrap (S m) = m + +-- DeleteResult with value +data DeleteResult' k a = U' !(IntervalSet k) a + | S' !(IntervalSet k) a + +unwrap' :: DeleteResult' k a -> IntervalSet k +unwrap' (U' m _) = m +unwrap' (S' m _) = m + +-- annotate DeleteResult with value +annotate :: DeleteResult k -> a -> DeleteResult' k a +annotate (U m) x = U' m x +annotate (S m) x = S' m x + + +-- | /O(log n)/. Remove the smallest element from the set. Return the empty set if the set is empty. +deleteMin :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k +deleteMin Nil = Nil +deleteMin m = turnBlack (unwrap' (deleteMin' m)) + +deleteMin' :: (Interval k e, Ord k) => IntervalSet k -> DeleteResult' k k +deleteMin' Nil = error "deleteMin': Nil" +deleteMin' (Node B k _ Nil Nil) = S' Nil k +deleteMin' (Node B k _ Nil r@(Node R _ _ _ _)) = U' (turnBlack r) k +deleteMin' (Node R k _ Nil r) = U' r k +deleteMin' (Node c k _ l r) = + case deleteMin' l of + (U' l' kv) -> U' (mNode c k l' r) kv + (S' l' kv) -> annotate (unbalancedR c k l' r) kv + +deleteMax' :: (Interval k e, Ord k) => IntervalSet k -> DeleteResult' k k +deleteMax' Nil = error "deleteMax': Nil" +deleteMax' (Node B k _ Nil Nil) = S' Nil k +deleteMax' (Node B k _ l@(Node R _ _ _ _) Nil) = U' (turnBlack l) k +deleteMax' (Node R k _ l Nil) = U' l k +deleteMax' (Node c k _ l r) = + case deleteMax' r of + (U' r' kv) -> U' (mNode c k l r') kv + (S' r' kv) -> annotate (unbalancedL c k l r') kv + +-- The left tree lacks one Black node +unbalancedR :: (Interval k e, Ord k) => Color -> k -> IntervalSet k -> IntervalSet k -> DeleteResult k +-- Decreasing one Black node in the right +unbalancedR B k l r@(Node B _ _ _ _) = S (balanceR B k l (turnRed r)) +unbalancedR R k l r@(Node B _ _ _ _) = U (balanceR B k l (turnRed r)) +-- Taking one Red node from the right and adding it to the right as Black +unbalancedR B k l (Node R rk _ rl@(Node B _ _ _ _) rr) + = U (mNode B rk (balanceR B k l (turnRed rl)) rr) +unbalancedR _ _ _ _ = error "unbalancedR" + +unbalancedL :: (Interval k e, Ord k) => Color -> k -> IntervalSet k -> IntervalSet k -> DeleteResult k +unbalancedL R k l@(Node B _ _ _ _) r = U (balanceL B k (turnRed l) r) +unbalancedL B k l@(Node B _ _ _ _) r = S (balanceL B k (turnRed l) r) +unbalancedL B k (Node R lk _ ll lr@(Node B _ _ _ _)) r + = U (mNode B lk ll (balanceL B k (turnRed lr) r)) +unbalancedL _ _ _ _ = error "unbalancedL" + + +-- | /O(log n)/. Remove the largest element from the set. Return the empty set if the set is empty. +deleteMax :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k +deleteMax Nil = Nil +deleteMax m = turnBlack (unwrap' (deleteMax' m)) + +-- | /O(log n)/. Delete and return the smallest element. +deleteFindMin :: (Interval k e, Ord k) => IntervalSet k -> (k, IntervalSet k) +deleteFindMin mp = case deleteMin' mp of + (U' r v) -> (v, turnBlack r) + (S' r v) -> (v, turnBlack r) + +-- | /O(log n)/. Delete and return the largest element. +deleteFindMax :: (Interval k e, Ord k) => IntervalSet k -> (k, IntervalSet k) +deleteFindMax mp = case deleteMax' mp of + (U' r v) -> (v, turnBlack r) + (S' r v) -> (v, turnBlack r) + +-- | /O(log n)/. Retrieves the minimal element of the set, and +-- the set stripped of that element, or 'Nothing' if passed an empty set. +minView :: (Interval k e, Ord k) => IntervalSet k -> Maybe (k, IntervalSet k) +minView Nil = Nothing +minView x = Just (deleteFindMin x) + +-- | /O(log n)/. Retrieves the maximal element of the set, and +-- the set stripped of that element, or 'Nothing' if passed an empty set. +maxView :: (Interval k e, Ord k) => IntervalSet k -> Maybe (k, IntervalSet k) +maxView Nil = Nothing +maxView x = Just (deleteFindMax x) + + +-- folding + +-- | /O(n)/. Fold the values in the set using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +foldr :: (k -> b -> b) -> b -> IntervalSet k -> b +foldr _ z Nil = z +foldr f z (Node _ k _ l r) = foldr f (f k (foldr f z r)) l + +-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldr' :: (k -> b -> b) -> b -> IntervalSet k -> b +foldr' f z s = z `seq` case s of + Nil -> z + Node _ k _ l r -> foldr' f (f k (foldr' f z r)) l + +-- | /O(n)/. Fold the values in the set using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +foldl :: (b -> k -> b) -> b -> IntervalSet k -> b +foldl _ z Nil = z +foldl f z (Node _ k _ l r) = foldl f (f (foldl f z l) k) r + +-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is +-- evaluated before using the result in the next application. This +-- function is strict in the starting value. +foldl' :: (b -> k -> b) -> b -> IntervalSet k -> b +foldl' f z s = z `seq` case s of + Nil -> z + Node _ k _ l r -> foldl' f (f (foldl' f z l) k) r + +-- delete + +-- | /O(log n)/. Delete an element from the set. If the set does not contain the value, +-- it is returned unchanged. +delete :: (Interval k e, Ord k) => k -> IntervalSet k -> IntervalSet k +delete key mp = turnBlack (unwrap (delete' key mp)) + +delete' :: (Interval k e, Ord k) => k -> IntervalSet k -> DeleteResult k +delete' x Nil = x `seq` U Nil +delete' x (Node c k _ l r) = + case compare x k of + LT -> case delete' x l of + (U l') -> U (mNode c k l' r) + (S l') -> unbalancedR c k l' r + GT -> case delete' x r of + (U r') -> U (mNode c k l r') + (S r') -> unbalancedL c k l r' + EQ -> case r of + Nil -> if c == B then blackify l else U l + _ -> case deleteMin' r of + (U' r' rk) -> U (mNode c rk l r') + (S' r' rk) -> unbalancedL c rk l r' + +blackify :: IntervalSet k -> DeleteResult k +blackify (Node R k m l r) = U (Node B k m l r) +blackify s = S s + + +-- | /O(n+m)/. The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate elements are encountered. +union :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k +union m1 m2 = fromDistinctAscList (ascListUnion (toAscList m1) (toAscList m2)) + +-- | The union of a list of sets: +-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). +unions :: (Interval k e, Ord k) => [IntervalSet k] -> IntervalSet k +unions [] = empty +unions [s] = s +unions iss = fromDistinctAscList (head (go (L.map toAscList iss))) + where + go [] = [] + go xs@[_] = xs + go (x:y:xs) = go (ascListUnion x y : go xs) + +-- | /O(n+m)/. Difference of two sets. +-- Return elements of the first set not existing in the second set. +difference :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k +difference m1 m2 = fromDistinctAscList (ascListDifference (toAscList m1) (toAscList m2)) + +-- | /O(n+m)/. Intersection of two sets. +-- Return elements in the first set also existing in the second set. +intersection :: (Interval k e, Ord k) => IntervalSet k -> IntervalSet k -> IntervalSet k +intersection m1 m2 = fromDistinctAscList (ascListIntersection (toAscList m1) (toAscList m2)) + +ascListUnion :: Ord k => [k] -> [k] -> [k] +ascListUnion [] [] = [] +ascListUnion [] ys = ys +ascListUnion xs [] = xs +ascListUnion xs@(x:xs') ys@(y:ys') = + case compare x y of + LT -> x : ascListUnion xs' ys + GT -> y : ascListUnion xs ys' + EQ -> x : ascListUnion xs' ys' + +ascListDifference :: Ord k => [k] -> [k] -> [k] +ascListDifference [] _ = [] +ascListDifference xs [] = xs +ascListDifference xs@(xk:xs') ys@(yk:ys') = + case compare xk yk of + LT -> xk : ascListDifference xs' ys + GT -> ascListDifference xs ys' + EQ -> ascListDifference xs' ys' + +ascListIntersection :: Ord k => [k] -> [k] -> [k] +ascListIntersection [] _ = [] +ascListIntersection _ [] = [] +ascListIntersection xs@(xk:xs') ys@(yk:ys') = + case compare xk yk of + LT -> ascListIntersection xs' ys + GT -> ascListIntersection xs ys' + EQ -> xk : ascListIntersection xs' ys' + + +-- --- Conversion --- + +-- | /O(n)/. The list of all values contained in the set, in ascending order. +toAscList :: IntervalSet k -> [k] +toAscList m = foldr (\k r -> k : r) [] m + +-- | /O(n)/. The list of all values in the set, in no particular order. +toList :: IntervalSet k -> [k] +toList s = go s [] + where + go Nil xs = xs + go (Node _ k _ l r) xs = k : go l (go r xs) + +-- | /O(n)/. The list of all values in the set, in descending order. +toDescList :: IntervalSet k -> [k] +toDescList m = foldl (\r k -> k : r) [] m + +-- | /O(n log n)/. Build a set from a list of elements. See also 'fromAscList'. +-- If the list contains duplicate values, the last value is retained. +fromList :: (Interval k e, Ord k) => [k] -> IntervalSet k +fromList xs = L.foldl' (\m k -> insert k m) empty xs + +-- | /O(n)/. Build a set from an ascending list in linear time. +-- /The precondition (input list is ascending) is not checked./ +fromAscList :: (Interval k e, Eq k) => [k] -> IntervalSet k +fromAscList xs = fromDistinctAscList (uniq xs) + +uniq :: Eq k => [k] -> [k] +uniq [] = [] +uniq (x:xs) = go x xs + where + go v [] = [v] + go v (y:ys) | v == y = go v ys + | otherwise = v : go y ys + +-- Strict tuple +data T2 a b = T2 !a !b + + +-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. +-- /The precondition is not checked./ +fromDistinctAscList :: (Interval k e) => [k] -> IntervalSet k +-- exactly 2^n-1 items have height n. They can be all black +-- from 2^n - 2^n-2 items have height n+1. The lowest "row" should be red. +fromDistinctAscList lyst = case h (length lyst) lyst of + (T2 result []) -> result + _ -> error "fromDistinctAscList: list not fully consumed" + where + h n xs | n == 0 = T2 Nil xs + | isPerfect n = buildB n xs + | otherwise = buildR n (log2 n) xs + + buildB n xs | xs `seq` n <= 0 = error "fromDictinctAscList: buildB 0" + | n == 1 = case xs of (k:xs') -> T2 (Node B k k Nil Nil) xs' + _ -> error "fromDictinctAscList: buildB 1" + | otherwise = + case n `quot` 2 of { n' -> + case buildB n' xs of { (T2 _ []) -> error "fromDictinctAscList: buildB n"; + (T2 l (k:xs')) -> + case buildB n' xs' of { (T2 r xs'') -> + T2 (mNode B k l r) xs'' }}} + + buildR n d xs | d `seq` xs `seq` n == 0 = T2 Nil xs + | n == 1 = case xs of (k:xs') -> T2 (Node (if d==0 then R else B) k k Nil Nil) xs' + _ -> error "fromDistinctAscList: buildR 1" + | otherwise = + case n `quot` 2 of { n' -> + case buildR n' (d-1) xs of { (T2 _ []) -> error "fromDistinctAscList: buildR n"; + (T2 l (k:xs')) -> + case buildR (n - (n' + 1)) (d-1) xs' of { (T2 r xs'') -> + T2 (mNode B k l r) xs'' }}} + + +-- is n a perfect binary tree size (2^m-1)? +isPerfect :: Int -> Bool +isPerfect n = (n .&. (n + 1)) == 0 + +log2 :: Int -> Int +log2 m = h (-1) m + where + h r n | r `seq` n <= 0 = r + | otherwise = h (r + 1) (n `shiftR` 1) + + +-- | /O(n)/. List of all values in the set, in ascending order. +elems :: IntervalSet k -> [k] +elems s = toAscList s + +-- --- Mapping --- + +-- | /O(n log n)/. Map a function over all values in the set. +-- +-- The size of the result may be smaller if @f@ maps two or more distinct +-- elements to the same value. +map :: (Interval a e1, Interval b e2, Ord b) => (a -> b) -> IntervalSet a -> IntervalSet b +map f s = fromList [f x | x <- toList s] + +-- | /O(n)/. @'mapMonotonic' f s == 'map' f s@, but works only when @f@ +-- is strictly monotonic. +-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@. +-- /The precondition is not checked./ +mapMonotonic :: (Interval k2 e, Ord k2) => (k1 -> k2) -> IntervalSet k1 -> IntervalSet k2 +mapMonotonic _ Nil = Nil +mapMonotonic f (Node c k _ l r) = + mNode c (f k) (mapMonotonic f l) (mapMonotonic f r) + +-- | /O(n)/. Filter values satisfying a predicate. +filter :: (Interval k e) => (k -> Bool) -> IntervalSet k -> IntervalSet k +filter p s = fromDistinctAscList (L.filter p (toAscList s)) + +-- | /O(n)/. Partition the set according to a predicate. The first +-- set contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. See also 'split'. +partition :: (Interval k e) => (k -> Bool) -> IntervalSet k -> (IntervalSet k, IntervalSet k) +partition p s = let (xs,ys) = L.partition p (toAscList s) + in (fromDistinctAscList xs, fromDistinctAscList ys) + +-- | /O(n)/. The expression (@'split' k set@) is a pair @(set1,set2)@ where +-- the elements in @set1@ are smaller than @k@ and the elements in @set2@ larger than @k@. +-- Any key equal to @k@ is found in neither @set1@ nor @set2@. +split :: (Interval i k, Ord i) => i -> IntervalSet i -> (IntervalSet i, IntervalSet i) +split x m = (l, r) + where (l, _, r) = splitMember x m + +-- | /O(n)/. The expression (@'splitMember' k set@) splits a set just +-- like 'split' but also returns @'member' k set@. +splitMember :: (Interval i k, Ord i) => i -> IntervalSet i -> (IntervalSet i, Bool, IntervalSet i) +splitMember x s = case span (< x) (toAscList s) of + ([], []) -> (empty, False, empty) + ([], (y:_)) | y == x -> (empty, True, deleteMin s) + | otherwise -> (empty, False, s) + (_, []) -> (s, False, empty) + (lt, ge@(y:gt)) | y == x -> (fromDistinctAscList lt, True, fromDistinctAscList gt) + | otherwise -> (fromDistinctAscList lt, False, fromDistinctAscList ge) + +-- subsets + +-- | /O(n+m)/. +isSubsetOf :: (Ord k) => IntervalSet k -> IntervalSet k -> Bool +isSubsetOf m1 m2 = go (toAscList m1) (toAscList m2) + where + go [] _ = True + go (_:_) [] = False + go s1@(k1:r1) (k2:r2) = + case compare k1 k2 of + GT -> go s1 r2 + EQ -> go r1 r2 + LT -> False + +-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). +isProperSubsetOf :: (Ord k) => IntervalSet k -> IntervalSet k -> Bool +isProperSubsetOf m1 m2 = size m1 < size m2 && isSubsetOf m1 m2 + +-- debugging + + +-- | The height of the tree. For testing/debugging only. +height :: IntervalSet k -> Int +height Nil = 0 +height (Node _ _ _ l r) = 1 + max (height l) (height r) + +-- | The maximum height of a red-black tree with the given number of nodes. +-- For testing/debugging only. +maxHeight :: Int -> Int +maxHeight nodes = 2 * log2 (nodes + 1) + + +-- | Check red-black-tree and interval search augmentation invariants. +-- For testing/debugging only. +valid :: (Interval i k, Ord i) => IntervalSet i -> Bool +valid mp = test mp && height mp <= maxHeight (size mp) && validColor mp + where + test Nil = True + test n@(Node _ _ _ l r) = validOrder n && validMax n && test l && test r + validMax (Node _ k m lo hi) = m == maxUpper k lo hi + validMax Nil = True + + validOrder (Node _ _ _ Nil Nil) = True + validOrder (Node _ k1 _ Nil (Node _ k2 _ _ _)) = k1 < k2 + validOrder (Node _ k2 _ (Node _ k1 _ _ _) Nil) = k1 < k2 + validOrder (Node _ k2 _ (Node _ k1 _ _ _) (Node _ k3 _ _ _)) = k1 < k2 && k2 < k3 + validOrder Nil = True + + -- validColor parentColor blackCount tree + validColor n = blackDepth n >= 0 + + -- return -1 if subtrees have diffrent black depths or two consecutive red nodes are encountered + blackDepth :: IntervalSet k -> Int + blackDepth Nil = 0 + blackDepth (Node c _ _ l r) = case blackDepth l of + ld -> if ld < 0 then ld + else + case blackDepth r of + rd -> if rd < 0 then rd + else if rd /= ld then -1 + else if c == R && (isRed l || isRed r) then -1 + else if c == B then rd + 1 + else rd + diff --git a/IntervalMap.cabal b/IntervalMap.cabal --- a/IntervalMap.cabal +++ b/IntervalMap.cabal @@ -1,5 +1,5 @@ Name: IntervalMap -Version: 0.4.0.1 +Version: 0.4.1.0 Stability: experimental Synopsis: Maps from Intervals to values, with efficient search. Homepage: http://www.chr-breitkopf.de/comp/IntervalMap @@ -8,27 +8,33 @@ Author: Christoph Breitkopf Maintainer: Christoph Breitkopf bug-reports: mailto:chbreitkopf@gmail.com -Copyright: 2011-2014 Christoph Breitkopf +Copyright: 2011-2015 Christoph Breitkopf Category: Data Build-type: Simple Cabal-version: >= 1.8 -Tested-With: GHC==7.8.3 +Tested-With: GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.2 Description: - A map from intervals to values, with efficient search + Ordered containers of intervals, with efficient search for all keys containing a point or overlapping an interval. See the example code on the home page for a quick introduction. extra-source-files: README.md + changelog test/*.hs examples/*.lhs +Flag HPC + Description: Enable HPC test coverage support + Default: False + Library Exposed-modules: Data.IntervalMap, Data.IntervalMap.Lazy, Data.IntervalMap.Strict, Data.IntervalMap.Interval, Data.IntervalMap.Generic.Interval, Data.IntervalMap.Generic.Lazy, - Data.IntervalMap.Generic.Strict + Data.IntervalMap.Generic.Strict, + Data.IntervalSet other-modules: Data.IntervalMap.Generic.Base Build-depends: base >= 4 && < 5, containers, deepseq ghc-options: -Wall @@ -41,7 +47,11 @@ hs-source-dirs: . test build-depends: base >= 4 && < 5, containers, deepseq, QuickCheck, Cabal >= 1.9.2 - + if flag(HPC) + ghc-options: -with-rtsopts=-K1K -fhpc + else + ghc-options: -with-rtsopts=-K1K + Test-Suite TestGenericInterval type: exitcode-stdio-1.0 @@ -49,6 +59,10 @@ hs-source-dirs: . test build-depends: base >= 4 && < 5, containers, deepseq, QuickCheck, Cabal >= 1.9.2 + if flag(HPC) + ghc-options: -with-rtsopts=-K1K -fhpc + else + ghc-options: -with-rtsopts=-K1K Test-Suite TestIntervalMap type: exitcode-stdio-1.0 @@ -56,7 +70,22 @@ hs-source-dirs: . test build-depends: base >= 4 && < 5, containers, deepseq, QuickCheck, Cabal >= 1.9.2 + if flag(HPC) + ghc-options: -with-rtsopts=-K1K -fhpc + else + ghc-options: -with-rtsopts=-K1K +Test-Suite TestIntervalSet + type: exitcode-stdio-1.0 + main-is: IntervalSetTests.hs + hs-source-dirs: . test + build-depends: base >= 4 && < 5, containers, deepseq, + QuickCheck, Cabal >= 1.9.2 + if flag(HPC) + ghc-options: -with-rtsopts=-K1K -fhpc + else + ghc-options: -with-rtsopts=-K1K + benchmark bench-all type: exitcode-stdio-1.0 hs-source-dirs: . bench @@ -73,8 +102,26 @@ Build-depends: base >= 4 && < 5, containers, random, deepseq, criterion >= 1.0 + ghc-options: -Wall -with-rtsopts=-K1K + +benchmark bench-compare-types + type: exitcode-stdio-1.0 + hs-source-dirs: . bench + main-is: CompareTypes.hs + Build-depends: base >= 4 && < 5, + containers, random, deepseq, fingertree >= 0.1, SegmentTree, + criterion >= 1.0 ghc-options: -Wall +benchmark bench-rb-impl + type: exitcode-stdio-1.0 + hs-source-dirs: . bench + main-is: CompareRBImpl.hs + Build-depends: base >= 4 && < 5, + containers, random, deepseq, + criterion >= 1.0 + ghc-options: -Wall -with-rtsopts=-K1K + source-repository head - type: darcs - location: http://hub.darcs.net/bokesan/IntervalMap + type: git + location: https://github.com/bokesan/IntervalMap diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2014, Christoph Breitkopf +Copyright (c) 2011-2015, Christoph Breitkopf All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,20 +1,14 @@ -# IntervalMap +# IntervalMap [![Build Status](https://travis-ci.org/bokesan/IntervalMap.svg?branch=master)](https://travis-ci.org/bokesan/IntervalMap) -Maps with intervals as keys offering efficient search. +Containers for intervals offering efficient search. Home page and documentation: [http://www.chr-breitkopf.de/comp/IntervalMap/index.html](http://www.chr-breitkopf.de/comp/IntervalMap/index.html) Install from hackage with cabal install. -To run the tests, do extract the archive, and do +To run the tests, extract the archive, and do $ cabal configure --enable-tests $ cabal build $ cabal test - -------- - -Christoph Breitkopf - -Last edit: 2014-07-30 diff --git a/bench/CompareRBImpl.hs b/bench/CompareRBImpl.hs new file mode 100644 --- /dev/null +++ b/bench/CompareRBImpl.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Criterion.Main +import Criterion.Types (Config(..)) + +import Control.DeepSeq +import Prelude hiding (lookup, max, foldr) +import System.Random +import Data.List (sort) + +import Data.IntervalMap.Generic.Interval +import qualified Data.IntervalMap.Generic.Strict as S +import qualified RBColorInt as L +import qualified RBColorNode as N + +seed :: Int +seed = 54321 + +ensure :: NFData a => a -> IO a +ensure xs = xs `deepseq` return xs + +forceRange :: Int -> Int -> Int -> Int +forceRange lo hi n | n >= lo && n <= hi = n + | n < 0 = forceRange lo hi (0 - n) + | otherwise = lo + (n `rem` (1 + hi - lo)) + +genRandomInts :: Int -> Int -> Int -> [Int] +genRandomInts lo hi n = Prelude.map (forceRange lo hi) . take n . randoms . mkStdGen $ seed + +genRandomIntervals :: Int -> Int -> Int -> [(Int,Int)] +genRandomIntervals max lap n = genIvs . take (2*n) . randoms . mkStdGen $ seed + where + genIvs [] = [] + genIvs [_] = [] + genIvs (x:y:xs) = let lo = forceRange 1 max x + sz = forceRange 0 lap y + in (lo, lo + sz) : genIvs xs + + +benchConfig :: Config +benchConfig = defaultConfig { reportFile = Just "bench-rb-impl.html" } + +cDATA_SIZE :: Int +cDATA_SIZE = 500000 + +cTEST_SIZE :: Int +cTEST_SIZE = 25000 + +data IV = IV {-# UNPACK #-} !Int {-# UNPACK #-} !Int + deriving (Eq, Ord) + +instance NFData IV where + rnf a = a `seq` () + +instance Interval IV Int where + lowerBound (IV l _) = l + upperBound (IV _ u) = u + + +main :: IO () +main = + do + let ivs = genRandomIntervals cDATA_SIZE 20 cDATA_SIZE + ivsP <- ensure $ [(IV lo hi, lo) | (lo,hi) <- ivs] + oIvsP <- ensure $ sort ivsP + lookupKeys <- ensure $ take cTEST_SIZE [i | (i,_) <- ivsP] + sMap <- ensure $ S.fromAscList oIvsP + lMap <- ensure $ L.fromAscList oIvsP + nMap <- ensure $ N.fromAscList oIvsP + rndInts <- ensure (genRandomInts 1 cDATA_SIZE cTEST_SIZE) + defaultMainWith benchConfig [ + bgroup "fromAscList" [ + bench "regular" $ nf S.fromAscList oIvsP, + bench "int" $ nf L.fromAscList oIvsP, + bench "node" $ nf N.fromAscList oIvsP + ], + bgroup "lookup" [ + bench "reg" $ nf (\m -> [S.lookup i m | i <- lookupKeys]) sMap, + bench "int" $ nf (\m -> [L.lookup i m | i <- lookupKeys]) lMap, + bench "node" $ nf (\m -> [N.lookup i m | i <- lookupKeys]) nMap + ], + bgroup "containing" [ + bench "reg" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.containing` p]) sMap, + bench "int" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.containing` p]) lMap, + bench "node" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `N.containing` p]) nMap + ], + bgroup "intersecting" [ + bench "reg" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.intersecting` (IV p (p+15))]) sMap, + bench "int" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.intersecting` (IV p (p+15))]) lMap, + bench "node" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `N.intersecting` (IV p (p+15))]) nMap + ], + bgroup "within" [ + bench "reg" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `S.within` (IV p (p+15))]) sMap, + bench "int" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `L.within` (IV p (p+15))]) lMap, + bench "node" $ nf (\m -> sum [v | p <- rndInts, (_,v) <- m `N.within` (IV p (p+15))]) nMap + ] + ] diff --git a/bench/CompareTypes.hs b/bench/CompareTypes.hs new file mode 100644 --- /dev/null +++ b/bench/CompareTypes.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Criterion.Main +import Criterion.Types (Config(..), Verbosity(..)) + +import Control.DeepSeq +import Prelude hiding (lookup, max, foldr) +import System.Random +import Data.List (nub) +import Data.Foldable (foldr) +import Data.Maybe + +import IntRange +import qualified Data.IntervalMap.Generic.Strict as RB +import qualified IvMapSortedList as SL +import qualified Data.IntervalMap.FingerTree as FT +import qualified Data.SegmentTree as ST + + +instance Ord a => Interval (FT.Interval a) a where + lowerBound = FT.low + upperBound = FT.high + +instance Ord a => Interval (ST.Interval a) a where + lowerBound (ST.Interval _ (ST.R a) _ _) = a + lowerBound _ = error "interval lower" + upperBound (ST.Interval _ _ (ST.R a) _) = a + upperBound _ = error "interval upper" + + +instance NFData a => NFData (FT.Interval a) where + rnf (FT.Interval a b) = a `deepseq` b `deepseq` () + +instance NFData a => NFData (ST.Interval a) where + rnf (ST.Interval _ (ST.R a) (ST.R b) _) = a `deepseq` b `deepseq` () + rnf a = a `seq` () + +instance (NFData k, NFData v) => NFData (FT.IntervalMap k v) where + -- FIXME + rnf a = a `seq` () + +instance NFData v => NFData (ST.STree v Int) where + rnf (ST.Leaf a b) = a `deepseq` b `deepseq`() + rnf (ST.Branch a b c d) = a `deepseq` b `deepseq` c `deepseq` d `deepseq` () + +ftFromList :: Ord k => [(FT.Interval k, v)] -> FT.IntervalMap k v +ftFromList = foldr (\(k,v) m -> FT.insert k v m) FT.empty + +stFromList :: [(Int,Int)] -> ST.STree [ST.Interval Int] Int +stFromList = ST.fromList + +stLoBound :: ST.Interval Int -> Int +stLoBound (ST.Interval{ST.low=(ST.R v)}) = v +stLoBound _ = error "stLoBound" + +cSEED, cSEED2 :: Int +cSEED = 54321 +cSEED2 = 12345 + +forceRange :: Int -> Int -> Int -> Int +forceRange lo hi n | n >= lo && n <= hi = n + | n < 0 = forceRange lo hi (0 - n) + | otherwise = lo + (n `rem` (1 + hi - lo)) + +genRandomIntervals :: Int -> Int -> Int -> [IntRange] +genRandomIntervals = genRandomIntervalsWithSeed cSEED + +genRandomIntervalsWithSeed :: Int -> Int -> Int -> Int -> [IntRange] +genRandomIntervalsWithSeed seed max lap n = genIvs . take (2*n) . randoms . mkStdGen $ seed + where + genIvs [] = [] + genIvs [_] = [] + genIvs (x:y:xs) = let lo = forceRange 1 max x + sz = forceRange 0 lap y + in IntRange lo (lo + sz) : genIvs xs + + +benchConfig :: Config +benchConfig = defaultConfig { reportFile = Just "bench-compare-types.html", verbosity = Verbose } + +cNUM_KEYS :: Int +cNUM_KEYS = 10 + +mkKeys :: Int -> [IntRange] +mkKeys n = genRandomIntervalsWithSeed cSEED2 n 18 cNUM_KEYS ++ [IntRange 0 1, IntRange (n+1) (n+2)] + +slEnv :: Int -> IO ([IntRange], SL.IVS IntRange Int) +slEnv n = do + let ivs = genRandomIntervals n 20 n + return (mkKeys n, SL.fromList [(iv, lowerBound iv) | iv <- ivs]) + +rbEnv :: Int -> IO ([IntRange], RB.IntervalMap IntRange Int) +rbEnv n = do + let ivs = genRandomIntervals n 20 n + return (mkKeys n, RB.fromList [(iv, lowerBound iv) | iv <- ivs]) + +ftEnv :: Int -> IO ([FT.Interval Int], FT.IntervalMap Int Int) +ftEnv n = do + let ivs = genRandomIntervals n 20 n + let ivsFt = [(FT.Interval lo hi, lo) | (IntRange lo hi) <- nub ivs] + return (map toIv (mkKeys n), ftFromList ivsFt) + where + toIv (IntRange a b) = FT.Interval a b + +stEnv :: Int -> IO ([ST.Interval Int], ST.STree [ST.Interval Int] Int) +stEnv n = do + let ivs = genRandomIntervals n 20 n + let ivsFt = [(lo,hi) | (IntRange lo hi) <- nub ivs] + return (map toIv (mkKeys n), stFromList ivsFt) + where + toIv (IntRange a b) = ST.Interval ST.Closed (ST.R a) (ST.R b) ST.Closed + + +runInsert :: Interval k a => (k -> a -> m -> m) -> m -> [k] -> m +runInsert ins m keys = foldr (\k mp -> ins k (lowerBound k) mp) m keys + +runLookup :: (k -> m -> Maybe Int) -> m -> [k] -> Int +runLookup f m keys = sum $ catMaybes $ map (\k -> f k m) keys + +runContains :: (Interval i e) => (t -> e -> [(t1, Int)]) -> t -> [i] -> Int +runContains f m keys = sum [v | k <- keys, (_,v) <- f m (lowerBound k)] + +benchIV name ins look cont ~(keys,m) = bgroup name [ + bench "insert" $ whnf (runInsert ins m) keys, + bench "lookup" $ nf (runLookup look m) keys, + bench "containing" $ nf (runContains cont m) keys + ] + +benchSL :: ([IntRange], SL.IVS IntRange Int) -> Benchmark +benchSL = benchIV "SortedList" SL.insert SL.lookup SL.containing + +benchRB :: ([IntRange], RB.IntervalMap IntRange Int) -> Benchmark +benchRB = benchIV "RedBlackTree" RB.insert RB.lookup RB.containing + +benchFT :: ([FT.Interval Int], FT.IntervalMap Int Int) -> Benchmark +benchFT ~(keys,m) = bgroup "FingerTree" [ + bench "insert" $ whnf (runInsert FT.insert m) keys, + bench "containing" $ nf (\ks -> sum [v | k <- ks, (_,v) <- FT.search (FT.low k) m]) keys + ] + +benchST :: ([ST.Interval Int], ST.STree [ST.Interval Int] Int) -> Benchmark +benchST ~(keys,m) = bgroup "SegmentTree" [ + bench "insert" $ whnf (runInsert (\k _ mp -> ST.insert mp k) m) keys, + bench "containing" $ nf (\ks -> sum [stLoBound v | k <- ks, v <- ST.stabbingQuery m (stLoBound k)]) keys + ] + + + +main :: IO () +main = defaultMainWith benchConfig [ + bgroup "10" [ + env (slEnv 10) benchSL, + env (rbEnv 10) benchRB, + env (ftEnv 10) benchFT, + env (stEnv 10) benchST + ], + bgroup "100" [ + env (slEnv 100) benchSL, + env (rbEnv 100) benchRB, + env (ftEnv 100) benchFT, + env (stEnv 100) benchST + ], + bgroup "1000" [ + env (slEnv 1000) benchSL, + env (rbEnv 1000) benchRB, + env (ftEnv 1000) benchFT, + env (stEnv 1000) benchST + ], + bgroup "2500" [ + env (slEnv 2500) benchSL, + env (rbEnv 2500) benchRB, + env (ftEnv 2500) benchFT, + env (stEnv 2500) benchST + ], + bgroup "10000" [ + env (rbEnv 10000) benchRB, + env (ftEnv 10000) benchFT, + env (stEnv 10000) benchST + ], + bgroup "20000" [ + env (rbEnv 20000) benchRB, + env (ftEnv 20000) benchFT, + env (stEnv 20000) benchST + ], + bgroup "50000" [ + env (rbEnv 50000) benchRB, + env (ftEnv 50000) benchFT, + env (stEnv 50000) benchST + ], + bgroup "100000" [ + env (rbEnv 100000) benchRB, + env (ftEnv 100000) benchFT, + env (stEnv 100000) benchST + ] + ] diff --git a/bench/GenericLazyVsStrict.hs b/bench/GenericLazyVsStrict.hs --- a/bench/GenericLazyVsStrict.hs +++ b/bench/GenericLazyVsStrict.hs @@ -12,7 +12,7 @@ import Data.IntervalMap.Generic.Interval import qualified Data.IntervalMap.Generic.Lazy as L -import qualified Data.IntervalMap.Generic.Lazy as S +import qualified Data.IntervalMap.Generic.Strict as S seed :: Int diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,18 @@ +0.4.1.0 Add IntervalSet. + Minor performance tweaks. + Documentation updates. + Moved to GitHub. + +0.4.0.1 Documentation update. Wrong portability info fixed. + +0.4.0.0 Major update adding support for user-defined key intervals. + +0.3.0.3 Updated benchmark to use Criterion 1.0. Tested with ghc 7.8.3. + +0.3.0.2 Dropped upper constraint on criterion. Tested with ghc 7.6.3. + Migrated repo to Darcs Hub. + +0.3.0.1 Bugfixes: Lazy was too strict, Strict too lazy. + +0.3.0.0 Split into Lazy and Strict modules, following containers. + diff --git a/examples/GenericExample.lhs b/examples/GenericExample.lhs --- a/examples/GenericExample.lhs +++ b/examples/GenericExample.lhs @@ -52,9 +52,6 @@ > type Appointments = IntervalMap TimeSpan [(Person, Details)] -Not that the key type is *Time*, not *TimeSpan*. That is, you specify the type of the -endpoints, not the type of the interval itself. - Now I can define some helper functions. A set containing no appointments: diff --git a/test/IntervalMapTests.hs b/test/IntervalMapTests.hs --- a/test/IntervalMapTests.hs +++ b/test/IntervalMapTests.hs @@ -16,20 +16,20 @@ instance Arbitrary II where arbitrary = do x <- arbitrary - liftM II (interval (abs x)) + liftM II (interval (abs x)) interval :: Int -> Gen (Interval Int) interval x = do - y <- sized (\n -> choose (x, x + abs n)) - if x == y then return (ClosedInterval x y) - else oneof [return (ClosedInterval x y), - return (OpenInterval x y), - return (IntervalCO x y), - return (IntervalOC x y)] + y <- sized (\n -> choose (x, x + abs n)) + if x == y then return (ClosedInterval x y) + else oneof [return (ClosedInterval x y), + return (OpenInterval x y), + return (IntervalCO x y), + return (IntervalOC x y)] instance Arbitrary IMI where arbitrary = do xs <- orderedList - return (IMI (fromAscList [(v, lowerBound v) | (II v) <- xs])) + return (IMI (fromAscList [(v, lowerBound v) | (II v) <- xs])) emptyM, single46 :: M.IntervalMap Int String @@ -51,11 +51,11 @@ bal3 :: M.IntervalMap Int String bal3 = let m1 = M.insert (ClosedInterval 1 4) "14" single46 - in M.insert (ClosedInterval 5 8) "58" m1 + in M.insert (ClosedInterval 5 8) "58" m1 bal3' :: M.IntervalMap Int String bal3' = let m1 = M.insert (ClosedInterval 1 4) "14" single46 - in M.insert (OpenInterval 5 8) "o58" m1 + in M.insert (OpenInterval 5 8) "o58" m1 prop_tests2 = 3 == M.size bal3 && @@ -82,12 +82,12 @@ deep100L :: M.IntervalMap Int Int deep100L = construct 100 M.empty where construct n m | n <= 0 = m - | otherwise = construct (n - 1) (M.insert (ClosedInterval n n) n m) + | otherwise = construct (n - 1) (M.insert (ClosedInterval n n) n m) deep100R :: M.IntervalMap Int Int deep100R = construct 1 M.empty where construct n m | n > 100 = m - | otherwise = construct (n + 1) (M.insert (ClosedInterval n n) n m) + | otherwise = construct (n + 1) (M.insert (ClosedInterval n n) n m) prop_tests3 = @@ -107,48 +107,51 @@ M.valid (M.delete (ClosedInterval 23 23) deep100R) prop_mapKeys = - equalMap ["foo"] (M.mapKeys lower (M.insert (ClosedInterval 4 5) "foo" single46)) && - equalMap ["single46"] (M.mapKeys lower (M.insert (ClosedInterval 4 7) "foo" single46)) + equalMap ["foo"] (M.mapKeys lower (M.insert (ClosedInterval 4 5) "foo" single46)) && + equalMap ["single46"] (M.mapKeys lower (M.insert (ClosedInterval 4 7) "foo" single46)) where lower k = ClosedInterval (lowerBound k) (lowerBound k) prop_mapKeysWith (IMI m) = M.valid m' && all correct (M.keys m) where lower k = ClosedInterval (lowerBound k) (lowerBound k) - m' = M.mapKeysWith (+) lower m - correct x = let mps = sum [v | (k,v) <- M.toList m, lowerBound k == lowerBound x] - in case M.lookup (lower x) m' of - Nothing -> False - Just v' -> v' == mps - - + m' = M.mapKeysWith (+) lower m + correct x = let mps = sum [v | (k,v) <- M.toList m, lowerBound k == lowerBound x] + in case M.lookup (lower x) m' of + Nothing -> False + Just v' -> v' == mps + + -- check that our generator yields valid maps. prop_valid (IMI m) = M.valid m +prop_singleton (II k) = let m = singleton k 'a' in + m!k == 'a' && size m == 1 + prop_delete (IMI m) (II k) = let m' = M.delete k m in - M.valid m' && - notMember k m' && - if M.null m then M.null m' - else if M.member k m then M.size m' == M.size m - 1 - else M.size m' == M.size m + M.valid m' && + notMember k m' && + if M.null m then M.null m' + else if M.member k m then M.size m' == M.size m - 1 + else M.size m' == M.size m prop_insert (IMI m) (II k) = let m' = M.insert k 4711 m in M.valid m' && - M.lookup k m' == Just 4711 && - if M.member k m then M.size m' == M.size m - else M.size m' == M.size m + 1 + M.lookup k m' == Just 4711 && + if M.member k m then M.size m' == M.size m + else M.size m' == M.size m + 1 prop_min (IMI m) = if M.null m then M.null (M.deleteMin m) else let (k,v) = findMin m - m' = deleteMin m - in notMember k m' && M.size m == M.size m' + 1 - && k == minimum (M.keys m) && valid m' + m' = deleteMin m + in notMember k m' && M.size m == M.size m' + 1 + && k == minimum (M.keys m) && valid m' prop_max (IMI m) = if M.null m then M.null (M.deleteMax m) else let (k,v) = findMax m - m' = deleteMax m - in notMember k m' && M.size m == M.size m' + 1 - && k == maximum (M.keys m) && valid m' + m' = deleteMax m + in notMember k m' && M.size m == M.size m' + 1 + && k == maximum (M.keys m) && valid m' prop_updateMin_u (IMI m) = let m' = M.updateMin (\v -> Just (v+1)) m in @@ -207,26 +210,26 @@ [e | e@(k,_) <- M.toList m, p `inside` k] prop_searchInterval (IMI m) (II i) = sameElements (m `intersecting` i) - [e | e@(k,_) <- M.toList m, k `overlaps` i] + [e | e@(k,_) <- M.toList m, k `overlaps` i] prop_within (IMI m) (II i) = sameElements (m `M.within` i) [e | e@(k,_) <- M.toList m, i `subsumes` k] prop_findMin (IMI m) = not (M.null m) ==> let x = minimum (M.toList m) - (y,m') = M.deleteFindMin m - in M.findMin m == x && - y == x && - M.valid m' && - sameElements (M.toList m Data.List.\\ [x]) (M.toList m') && - sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMin m)) + (y,m') = M.deleteFindMin m + in M.findMin m == x && + y == x && + M.valid m' && + sameElements (M.toList m Data.List.\\ [x]) (M.toList m') && + sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMin m)) prop_findMax (IMI m) = not (M.null m) ==> let x = maximum (M.toList m) - (y,m') = M.deleteFindMax m - in M.findMax m == x && - y == x && - M.valid m' && - sameElements (M.toList m Data.List.\\ [x]) (M.toList m') && - sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMax m)) + (y,m') = M.deleteFindMax m + in M.findMax m == x && + y == x && + M.valid m' && + sameElements (M.toList m Data.List.\\ [x]) (M.toList m') && + sameElements (M.toList m Data.List.\\ [x]) (M.toList (M.deleteMax m)) prop_findLast (IMI m) = not (M.null m) ==> M.findLast m == head (sortBy cmp (M.toList m)) @@ -239,14 +242,14 @@ prop_insertWith (IMI m) (II i) v = let m' = M.insertWith (\new old -> new + old) i v m in if M.member i m then M.valid m' && m' M.! i == m M.! i + v && M.size m' == M.size m - else - M.valid m' && m' M.! i == v && M.size m' == M.size m + 1 + else + M.valid m' && m' M.! i == v && M.size m' == M.size m + 1 prop_insertWith' (IMI m) (II i) v = let m' = M.insertWith' (\new old -> new + old) i v m in if M.member i m then M.valid m' && m' M.! i == m M.! i + v && M.size m' == M.size m - else - M.valid m' && m' M.! i == v && M.size m' == M.size m + 1 + else + M.valid m' && m' M.! i == v && M.size m' == M.size m + 1 prop_insertLookupWithKey (IMI m) (II i) v = case M.insertLookupWithKey (\k new old -> upperBound k + new + old) i v m of @@ -261,25 +264,25 @@ prop_foldr (IMI m) = M.foldr f z m == Prelude.foldr f z [ v | (_,v) <- M.toAscList m ] where z = [] - f = (:) + f = (:) prop_adjust (II i) (IMI m) = let m' = M.adjust (13*) i m in - M.valid m' && + M.valid m' && case M.lookup i m of Nothing -> m == m' - Just v -> case M.lookup i m' of - Nothing -> False - Just v' -> v' == v * 13 + Just v -> case M.lookup i m' of + Nothing -> False + Just v' -> v' == v * 13 prop_update (II i) (IMI m) = let f n = if n `rem` 2 == 0 then Nothing else Just (13 * n) - m' = M.update f i m - in - M.valid m' && - case M.lookup i m of - Nothing -> m == m' - Just v -> case M.lookup i m' of - Nothing -> v `rem` 2 == 0 - Just v' -> v' == 13 * v + m' = M.update f i m + in + M.valid m' && + case M.lookup i m of + Nothing -> m == m' + Just v -> case M.lookup i m' of + Nothing -> v `rem` 2 == 0 + Just v' -> v' == 13 * v prop_alter (IMI m) (II k) = delete && insert where @@ -289,49 +292,51 @@ prop_union (IMI m1) (IMI m2) = M.size m' == M.size m1 + numNotInM1 0 (M.keys m2) -- size && valsM1 (M.assocs m1) -- m1 entries unchanged - && valsM2 (M.assocs m2) -- m2 entries not in m1 unchanged - && M.valid m' + && valsM2 (M.assocs m2) -- m2 entries not in m1 unchanged + && M.valid m' where m' = m1 `M.union` m2 valsM1 [] = True valsM1 ((k,v):xs) = case M.lookup k m' of - Nothing -> False - Just v' -> v' == v && valsM1 xs + Nothing -> False + Just v' -> v' == v && valsM1 xs valsM2 [] = True valsM2 ((k,v):xs) | M.member k m1 = valsM2 xs - | otherwise = case M.lookup k m' of - Nothing -> False - Just v' -> v' == v && valsM2 xs + | otherwise = case M.lookup k m' of + Nothing -> False + Just v' -> v' == v && valsM2 xs numNotInM1 n [] = n numNotInM1 n (k:ks) | M.member k m1 = numNotInM1 n ks - | otherwise = numNotInM1 (n+1) ks + | otherwise = numNotInM1 (n+1) ks prop_unionWithKey (IMI m1) (IMI m2) = M.size m' == M.size m1 + numNotInM1 0 (M.keys m2) -- size && valuesCorrect (M.assocs m') - && M.valid m' + && M.valid m' where f k a b = 7 * upperBound k + 3 * b + b m' = M.unionWithKey f m1 m2 valuesCorrect [] = True valuesCorrect ((k,v):xs) = case M.lookup k m1 of - Nothing -> case M.lookup k m2 of - Nothing -> False - Just v2 -> v2 == v && valuesCorrect xs - Just v1 -> case M.lookup k m2 of - Nothing -> v1 == v && valuesCorrect xs - Just v2 -> v == f k v1 v2 && valuesCorrect xs + Nothing -> case M.lookup k m2 of + Nothing -> False + Just v2 -> v2 == v && valuesCorrect xs + Just v1 -> case M.lookup k m2 of + Nothing -> v1 == v && valuesCorrect xs + Just v2 -> v == f k v1 v2 && valuesCorrect xs numNotInM1 n [] = n numNotInM1 n (k:ks) | M.member k m1 = numNotInM1 n ks - | otherwise = numNotInM1 (n+1) ks + | otherwise = numNotInM1 (n+1) ks -prop_unions (IMI m1) (IMI m2) (IMI m3) = M.unions [m1,m2,m3] == (m1 `M.union` m2 `M.union` m3) +prop_unions ims = M.unions ms == Prelude.foldl M.union empty ms + where ms = [m | IMI m <- ims] + prop_difference (IMI m1) (IMI m2) = M.valid m' && m' == Prelude.foldr M.delete m1 (M.keys m2) where m' = m1 M.\\ m2 @@ -353,7 +358,7 @@ assoc :: Eq k => k -> [(k,a)] -> Maybe a assoc _ [] = Nothing assoc k ((x,v):xs) | x == k = Just v - | otherwise = assoc k xs + | otherwise = assoc k xs prop_mapAccum (IMI m) = M.valid m' && acc == sum (M.elems m) && sum (M.elems m') == 2 * acc where (acc, m') = M.mapAccum (\a v -> (a+v, 2*v)) 0 m @@ -375,33 +380,35 @@ odds = length [x | x <- M.elems m, odd x] prop_partition (IMI m) = M.valid m1 && M.valid m2 && all odd (M.elems m1) && all even (M.elems m2) - && M.size m == M.size m1 + M.size m2 + && M.size m == M.size m1 + M.size m2 where (m1,m2) = M.partition odd m prop_splitLookup (IMI m) (II x) = M.valid l && M.valid r - && all (< x) (M.keys l) && all (> x) (M.keys r) - && value == M.lookup x m - && M.size m == M.size l + M.size r + (if M.member x m then 1 else 0) + && all (< x) (M.keys l) && all (> x) (M.keys r) + && value == M.lookup x m + && M.size m == M.size l + M.size r + (if M.member x m then 1 else 0) where (l, value, r) = splitLookup x m +prop_readShow (IMI m) = m == read (show m) + checkElems :: Int -> Int -> [(Interval Int, Int)] -> Bool checkElems n len lyst = h n (n + len) lyst where h i n xs | i > n = True | otherwise = case xs of ((iv,v):xs') -> if v == i && lowerBound iv == i && upperBound iv == i - then h (i+1) n xs' - else False + then h (i+1) n xs' + else False check p name = do r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p - if isSuccess r - then return r - else do putStrLn ("error: " ++ name ++ ": " ++ show r) - exitFailure + if isSuccess r + then return r + else do putStrLn ("error: " ++ name ++ ": " ++ show r) + exitFailure main :: IO () @@ -410,43 +417,48 @@ check prop_tests2 "tests2" check prop_tests3 "tests3" check prop_mapKeys "mapKeys" - check prop_valid "valid" - check prop_delete "delete" - check prop_insert "insert" - check prop_min "min" - check prop_max "max" - check prop_findWithDefault "findWithDefault" - check prop_searchPoint "searchPoint" - check prop_searchInterval "searchInterval" + check prop_valid "valid" + check prop_singleton "singleton" + check prop_delete "delete" + check prop_insert "insert" + check prop_min "min" + check prop_max "max" + check prop_findWithDefault "findWithDefault" + check prop_searchPoint "searchPoint" + check prop_searchInterval "searchInterval" check prop_within "within" - check prop_findMin "findMin" - check prop_findMax "findMax" + check prop_findMin "findMin" + check prop_findMax "findMax" + check prop_findLast "findLast" check prop_updateMin_u "updateMin update" check prop_updateMin_d "updateMin delete" check prop_updateMax_u "updateMax update" check prop_updateMax_d "updateMax delete" - check prop_insertWith "insertWith" + check prop_insertWith "insertWith" check prop_insertWith' "insertWith'" - check prop_insertLookupWithKey "insertLookupWithKey" - check prop_insertLookupWithKey' "insertLookupWithKey'" - check prop_map "map" - check prop_foldr "foldr" - check prop_fromAscList "fromAscList" - check prop_adjust "adjust" - check prop_update "update" - check prop_union "union" - check prop_unionWithKey "unionWithKey" - check prop_unions "unions" - check prop_difference "difference" - check prop_intersection "intersection" - check prop_filter "filter" - check prop_partition "partition" - check prop_splitLookup "splitLookup" - check prop_mapKeysWith "mapKeysWith" + check prop_insertLookupWithKey "insertLookupWithKey" + check prop_insertLookupWithKey' "insertLookupWithKey'" + check prop_map "map" + check prop_mapAccum "mapAccum" + check prop_foldr "foldr" + check prop_fromAscList "fromAscList" + check prop_adjust "adjust" + check prop_update "update" + check prop_alter "alter" + check prop_union "union" + check prop_unionWithKey "unionWithKey" + check prop_unions "unions" + check prop_difference "difference" + check prop_intersection "intersection" + check prop_filter "filter" + check prop_partition "partition" + check prop_splitLookup "splitLookup" + check prop_mapKeysWith "mapKeysWith" check prop_submap "submap" - putStrLn ("deep100L: " ++ show (M.showStats deep100L)) - putStrLn ("deep100R: " ++ show (M.showStats deep100R)) - exitSuccess + check prop_readShow "read/show" + putStrLn ("deep100L: " ++ show (M.showStats deep100L)) + putStrLn ("deep100R: " ++ show (M.showStats deep100R)) + exitSuccess -- Utils ----------------- @@ -457,11 +469,11 @@ sameElements [] [] = True sameElements [] (_:_) = False sameElements (x:xs) ys = case tryRemove x ys of - Nothing -> False - Just ys' -> sameElements xs ys' + Nothing -> False + Just ys' -> sameElements xs ys' where tryRemove _ [] = Nothing tryRemove x (y:ys) | x == y = Just ys - | otherwise = case tryRemove x ys of - Nothing -> Nothing - Just ys' -> Just (y : ys') + | otherwise = case tryRemove x ys of + Nothing -> Nothing + Just ys' -> Just (y : ys') diff --git a/test/IntervalSetTests.hs b/test/IntervalSetTests.hs new file mode 100644 --- /dev/null +++ b/test/IntervalSetTests.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- module IntervalSetTests (main) where + +import System.Exit (exitSuccess, exitFailure) + +import Test.QuickCheck hiding (within) +import Test.QuickCheck.Test (isSuccess) +import Control.Monad (liftM) +import Prelude hiding (null, map, filter, foldr, foldl) +import qualified Data.List as L + +import Data.IntervalSet + + +data II = II !Int !Int deriving (Eq, Ord, Show, Read) + +bump :: Int -> II -> II +bump n (II a b) = II (a+n) (b+n) + +contains :: II -> Int -> Bool +contains (II a b) n = a <= n && n <= b + +instance Interval II Int where + lowerBound (II a _) = a + upperBound (II _ b) = b + +instance Arbitrary II where + arbitrary = do x <- arbitrary + iv <- interval (abs x) + return iv + +interval :: Int -> Gen II +interval x = do y <- sized (\n -> choose (x, x + abs n)) + return (II x y) + +newtype IS = IS (IntervalSet II) deriving (Show) + +instance Arbitrary IS where + arbitrary = do xs <- orderedList + return (IS (fromAscList xs)) + +prop_valid (IS s) = valid s + +prop_null (IS s) = null s == (size s == 0) + +prop_size (IS s) = size s == length (toList s) + +prop_singleton :: II -> Bool +prop_singleton iv = size (singleton iv) == 1 + +prop_insert_member (IS s) iv = member iv (insert iv s) + +prop_notMember (IS s) iv = notMember iv s == not (member iv s) + +prop_isSubsetOf (IS s1) (IS s2) = (s1 `isSubsetOf` s2) == L.null (toList s1 L.\\ toList s2) + +prop_isProperSubsetOf (IS s1) (IS s2) + = (s1 `isProperSubsetOf` s2) == + (L.null (toList s1 L.\\ toList s2) && s1 /= s2) + +prop_insert_size (IS s) iv = + let s' = insert iv s in + if member iv s + then size s' == size s + else size s' == size s + 1 + +prop_delete (IS s) iv = let s' = delete iv s in + valid s' && + if notMember iv s then s' == s + else all (\e -> e `member` s' || e == iv) (toList s) + +prop_list (IS s) = s == fromList (toList s) +prop_asclist (IS s) = s == fromAscList (toAscList s) +prop_desclist (IS s) = toDescList s == reverse (toAscList s) +prop_elems (IS s) = elems s == toAscList s + +prop_union (IS s1) (IS s2) = union s1 s2 == foldr insert s2 s1 + +prop_unions xs = unions iss == L.foldl union empty iss + where iss = [is | IS is <- xs] + +prop_difference (IS s1) (IS s2) = (s1 \\ s2) == foldr delete s1 s2 + +prop_intersection (IS s1) (IS s2) = + let i = intersection s1 s2 in + all (\e -> member e s1 && member e s2) (toList i) + +prop_minView (IS s) = case minView s of + Nothing -> null s + Just (min, s') -> all (min <) (toList s') + +prop_maxView (IS s) = case maxView s of + Nothing -> null s + Just (max, s') -> all (max >) (toList s') + +prop_findMin (IS s) = case findMin s of + Nothing -> null s + Just min -> all (min <=) (toList s) + +prop_findMax (IS s) = case findMax s of + Nothing -> null s + Just max -> all (max >=) (toList s) + +prop_findLast (IS s) = case findLast s of + Nothing -> null s + Just x@(II _ end) -> + all (\e -> upperBound e < end || (upperBound e == end && e <= x)) (toList s) + +prop_deleteMin (IS s) = let s' = deleteMin s in + case findMin s of + Nothing -> null s' + Just min -> s' == delete min s + +prop_deleteMax (IS s) = let s' = deleteMax s in + case findMax s of + Nothing -> null s' + Just max -> s' == delete max s + +prop_map (IS s) n = s == map (bump n) (map (bump (-n)) s) +prop_mapMonotonic (IS s) n = s == mapMonotonic (bump n) (mapMonotonic (bump (-n)) s) + +prop_filter (IS s) iv = filter (iv /=) s == delete iv s + +prop_partition (IS s) iv = let (lo,hi) = partition (<= iv) s in + valid lo && valid hi && + all (<= iv) (toList lo) && + all (> iv) (toList hi) && + union lo hi == s + +prop_split (IS s) iv = let (lo,hi) = split iv s in + all (< iv) (toList lo) && + all (> iv) (toList hi) && + union lo hi == if member iv s then delete iv s else s + +prop_splitMember (IS s) iv = let (lo,m,hi) = splitMember iv s in + valid lo && valid hi && + m == member iv s && + all (< iv) (toList lo) && + all (> iv) (toList hi) && + union lo hi == if m then delete iv s else s + +prop_readShow (IS s) = s == read (show s) + + +prop_containing :: IS -> Int -> Bool +prop_containing (IS s) n = let s' = s `containing` n in + all (\e -> if e `contains` n then e `member` s' else e `notMember` s') (toList s) + +prop_intersecting :: IS -> II -> Bool +prop_intersecting (IS s) iv = let s' = s `intersecting` iv in + all (\e -> if e `overlaps` iv then e `member` s' else e `notMember` s') (toList s) + +prop_within :: IS -> II -> Bool +prop_within (IS s) iv = let s' = s `within` iv in + all (\e -> if iv `subsumes` e then e `member` s' else e `notMember` s') (toList s) + +prop_foldr (IS s) iv = Just (foldr (\v r -> min v r) iv s) == findMin (insert iv s) +prop_foldr' (IS s) iv = Just (foldr' (\v r -> min v r) iv s) == findMin (insert iv s) +prop_foldl (IS s) iv = Just (foldl (\r v -> min v r) iv s) == findMin (insert iv s) +prop_foldl' (IS s) iv = Just (foldl' (\r v -> min v r) iv s) == findMin (insert iv s) + +check p name = do putStrLn ("Testing " ++ name ++ ":") + r <- quickCheckWithResult (stdArgs { maxSuccess = 500 }) p + if isSuccess r + then return r + else do putStrLn ("error: " ++ name ++ ": " ++ show r) + exitFailure + + +main = do + check prop_valid "valid" + check prop_null "null" + check prop_size "size" + check prop_notMember "notMember" + check prop_singleton "singleton" + check prop_isSubsetOf "subsetOf" + check prop_isProperSubsetOf "properSubsetOf" + check prop_insert_member "insert -> member" + check prop_insert_size "insert + size" + check prop_delete "delete" + check prop_list "toList/fromList" + check prop_asclist "toAscList/fromAscList" + check prop_desclist "toDescList" + check prop_elems "elems" + check prop_union "union" + check prop_unions "unions" + check prop_difference "difference" + check prop_intersection "intersection" + check prop_findMin "findMin" + check prop_findMax "findMax" + check prop_findLast "findLast" + check prop_deleteMin "deleteMin" + check prop_deleteMax "deleteMax" + check prop_minView "minView" + check prop_maxView "maxView" + check prop_foldr "foldr" + check prop_foldr' "foldr'" + check prop_foldl "foldl" + check prop_foldl' "foldl'" + check prop_map "map" + check prop_mapMonotonic "mapMonotonic" + check prop_filter "filter" + check prop_partition "partition" + check prop_split "split" + check prop_splitMember "splitMember" + check prop_containing "containing" + check prop_intersecting "intersecting" + check prop_within "within" + check prop_readShow "read/show" + exitSuccess