diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +### 0.1.2.0 + +- Map implementations: `Data.RangeSet.IntMap` and `Data.RangeSet.Map` + ### 0.1.1.0 - Add `Semigroup`, `NFData`, `Hashable` and `Typeable` instances diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,23 +6,27 @@ [![Stackage LTS 3](http://stackage.org/package/range-set-list/badge/lts-3)](http://stackage.org/lts-3/package/range-set-list) [![Stackage Nightly](http://stackage.org/package/range-set-list/badge/nightly)](http://stackage.org/nightly/package/range-set-list) -A trivial implementation of range sets. +A few trivial implementations of range sets. -You can find the package (and it's documentation) on [hackage](http://hackage.haskell.org/package/range-set-list). +You can find the package (and its documentation) on [hackage](http://hackage.haskell.org/package/range-set-list). This module is intended to be imported qualified, to avoid name -clashes with Prelude functions, e.g. +clashes with Prelude functions, e.g., ```haskell import Data.RangeSet.List (RSet) import qualified Data.RangeSet.List as RSet ``` -The implementation of `RSet` is based on _list_. +This package contains two implementations of exactly the same interface, plus one specialization, all of which provide exactly the same behavior: +* "Data.RangeSet.List" implements the simplest `RSet` based on _list_. Set construction and manipulation is most efficient for this version, but lookups may require a full list traversal. +* "Data.RangeSet.Map" implements a slightly less simple `RSet` based on _map_. Construction and manipulation have more overhead in this version, but lookups are significantly faster, especially for large sets. +* "Data.RangeSet.IntMap" is simply a specialization of "Data.RangeSet.Map" to Ints based on IntMap. + Compared to [`Data.Set`](http://hackage.haskell.org/package/containers-0.5.4.0/docs/Data-Set.html), -this module imposes also [`Enum`](http://hackage.haskell.org/package/base-4.6.0.1/docs/Prelude.html#t:Enum) -restriction for many functions. +this module also imposes an [`Enum`](http://hackage.haskell.org/package/base-4.6.0.1/docs/Prelude.html#t:Enum) +constraint for many functions. We must be able to identify consecutive elements to be able to _glue_ and _split_ ranges properly. The implementation assumes that diff --git a/range-set-list.cabal b/range-set-list.cabal --- a/range-set-list.cabal +++ b/range-set-list.cabal @@ -3,9 +3,9 @@ -- see: https://github.com/sol/hpack name: range-set-list -version: 0.1.1.0 -synopsis: Memory efficient sets with continuous ranges of elements. -description: Memory efficient sets with continuous ranges of elements. List based implementation. Interface mimics 'Data.Set' interface where possible. +version: 0.1.2.0 +synopsis: Memory efficient sets with ranges of elements. +description: Memory efficient sets with continuous ranges of discrete, bounded elements. List- and map-based implementations. Interface mimics 'Data.Set' where possible. homepage: https://github.com/phadej/range-set-list#readme bug-reports: https://github.com/phadej/range-set-list/issues license: MIT @@ -28,14 +28,19 @@ library hs-source-dirs: src + other-extensions: DeriveDataTypeable Safe ghc-options: -Wall -fwarn-tabs build-depends: - base >=4.5 && <4.9, + base >=4.5 && <4.10, + containers >=0.5.3 && <0.6, semigroups >=0.16.2.2 && <0.19, deepseq >=1.3.0.0 && <1.5, hashable >=1.2.3.3 && <1.3 exposed-modules: + Data.RangeSet.Internal + Data.RangeSet.IntMap Data.RangeSet.List + Data.RangeSet.Map default-language: Haskell2010 test-suite test @@ -45,7 +50,8 @@ tests ghc-options: -Wall -fwarn-tabs build-depends: - base >=4.5 && <4.9, + base >=4.5 && <4.10, + containers >=0.5.3 && <0.6, semigroups >=0.16.2.2 && <0.19, deepseq >=1.3.0.0 && <1.5, hashable >=1.2.3.3 && <1.3, @@ -53,4 +59,9 @@ tasty >=0.8 && <0.12, tasty-quickcheck >=0.8 && <0.9, range-set-list + other-modules: + IntMap + List + Map + SetAction default-language: Haskell2010 diff --git a/src/Data/RangeSet/IntMap.hs b/src/Data/RangeSet/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/RangeSet/IntMap.hs @@ -0,0 +1,338 @@ +{- | +Module : Data.RangeSet.IntMap +Description : Specialization of Data.RangeSet.Map to Ints +Copyright : (c) Dylan Simon, 2015 +License : MIT + +This is simply a specialization of "Data.RangeSet.Map" to 'Int'. + +The implementation of 'RIntSet' is based on "Data.IntMap.Strict". +-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +module Data.RangeSet.IntMap ( + -- * Range set type + RIntSet + + -- * Operators + , (\\) + + -- * Query + , null + , isFull + , size + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + , containsRange + , isSubsetOf + , valid + + -- * Construction + , empty + , full + , singleton + , singletonRange + , insert + , insertRange + , delete + , deleteRange + + -- * Combine + , union + , difference + , intersection + + -- * Filter + , split + , splitMember + + -- * Min/Max + , findMin + , findMax + + -- * Complement + , complement + + -- * Conversion + , elems + , toList + , fromList + , fromAscList + , toAscList + , toRangeList + , fromRangeList + , fromRList + , toRList + , fromNormalizedRangeList + + ) where + +import Prelude hiding (filter, foldl, foldr, map, null) + +import Control.DeepSeq (NFData (..)) +import qualified Data.Foldable as Fold +import Data.Functor ((<$>)) +import qualified Data.IntMap.Strict as Map +import Data.Monoid (Monoid (..), getSum) +import Data.Semigroup (Semigroup (..)) +import Data.Typeable (Typeable) + +import Data.RangeSet.Internal +import qualified Data.RangeSet.List as RList + +-- | Internally set is represented as sorted list of distinct inclusive ranges. +newtype RIntSet = RSet (Map.IntMap Int) + deriving (Eq, Ord, Typeable) + +instance Show RIntSet where + show x = "fromRangeList " ++ show (toRangeList x) + +instance Semigroup RIntSet where + (<>) = union + +instance Monoid RIntSet where + mempty = empty + mappend = union + +instance NFData RIntSet where + rnf (RSet xs) = rnf xs + +{- Operators -} +infixl 9 \\ -- + +-- | /O(n+m)/. See 'difference'. +(\\) :: RIntSet -> RIntSet -> RIntSet +m1 \\ m2 = difference m1 m2 + +{- Query -} + +-- | /O(1)/. Is this the empty set? +null :: RIntSet -> Bool +null (RSet m) = Map.null m + +-- | /O(1)/. Is this the empty set? +isFull :: RIntSet -> Bool +isFull = (==) full + +-- | /O(n)/. The number of the elements in the set. +size :: RIntSet -> Int +size (RSet xm) = getSum $ Map.foldMapWithKey rangeSize xm + +contains' :: Int -> Int -> RIntSet -> Bool +contains' x y (RSet xm) = Fold.any ((y <=) . snd) $ Map.lookupLE x xm + +-- | /O(log n)/. Is the element in the set? +member :: Int -> RIntSet -> Bool +member x = contains' x x + +-- | /O(log n)/. Is the element not in the set? +notMember :: Int -> RIntSet -> Bool +notMember a r = not $ member a r + +-- | /O(log n)/. Find largest element smaller than the given one. +lookupLT :: Int -> RIntSet -> Maybe Int +lookupLT x (RSet xm) = min (pred x) . snd <$> Map.lookupLT x xm + +-- | /O(log n)/. Find smallest element greater than the given one. +lookupGT :: Int -> RIntSet -> Maybe Int +lookupGT x (RSet xm) + | Just (_, b) <- Map.lookupLE x xm, x < b = Just (succ x) + | otherwise = fst <$> Map.lookupGT x xm + +-- | /O(log n)/. Find largest element smaller or equal to than the given one. +lookupLE :: Int -> RIntSet -> Maybe Int +lookupLE x (RSet xm) = min x . snd <$> Map.lookupLE x xm + +-- | /O(log n)/. Find smallest element greater or equal to than the given one. +lookupGE :: Int -> RIntSet -> Maybe Int +lookupGE x (RSet xm) + | Just (_, b) <- Map.lookupLE x xm, x <= b = Just x + | otherwise = fst <$> Map.lookupGT x xm + +-- | /O(log n)/. Is the entire range contained within the set? +containsRange :: (Int, Int) -> RIntSet -> Bool +containsRange (x,y) s + | x <= y = contains' x y s + | otherwise = True + +-- | /O(n+m)/. Is this a subset? +-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +isSubsetOf :: RIntSet -> RIntSet -> Bool +isSubsetOf x y = isSubsetRangeList (toRangeList x) (toRangeList y) + +{- Construction -} + +-- | /O(1)/. The empty set. +empty :: RIntSet +empty = RSet Map.empty + +-- | /O(1)/. The full set. +full :: RIntSet +full = singletonRange' minBound maxBound + +singletonRange' :: Int -> Int -> RIntSet +singletonRange' x y = RSet $ Map.singleton x y + +-- | /O(1)/. Create a singleton set. +singleton :: Int -> RIntSet +singleton x = singletonRange' x x + +-- | /O(1)/. Create a continuos range set. +singletonRange :: (Int, Int) -> RIntSet +singletonRange (x, y) | x > y = empty + | otherwise = singletonRange' x y + +{- Construction -} + +insertRange' :: Int -> Int -> RIntSet -> RIntSet +insertRange' x y s = unRangeList $ insertRangeList x y $ toRangeList s + +-- | /O(n)/. Insert an element in a set. +insert :: Int -> RIntSet -> RIntSet +insert x = insertRange' x x + +-- | /O(n)/. Insert a continuos range in a set. +insertRange :: (Int, Int) -> RIntSet -> RIntSet +insertRange (x, y) set + | x > y = set + | otherwise = insertRange' x y set + +deleteRange' :: Int -> Int -> RIntSet -> RIntSet +deleteRange' x y s = unRangeList $ deleteRangeList x y $ toRangeList s + +-- | /O(n). Delete an element from a set. +delete :: Int -> RIntSet -> RIntSet +delete x = deleteRange' x x + +-- | /O(n). Delete a continuos range from a set. +deleteRange :: (Int, Int) -> RIntSet -> RIntSet +deleteRange (x, y) set + | x > y = set + | otherwise = deleteRange' x y set + +{- Combination -} + +-- | /O(n*m)/. The union of two sets. +union :: RIntSet -> RIntSet -> RIntSet +union x y = unRangeList $ unionRangeList (toRangeList x) (toRangeList y) + +-- | /O(n*m)/. Difference of two sets. +difference :: RIntSet -> RIntSet -> RIntSet +difference x y = unRangeList $ differenceRangeList (toRangeList x) (toRangeList y) + +-- | /O(n*m)/. The intersection of two sets. +intersection :: RIntSet -> RIntSet -> RIntSet +intersection x y = unRangeList $ intersectRangeList (toRangeList x) (toRangeList y) + +{- Complement -} + +-- | /O(n)/. Complement of the set. +complement :: RIntSet -> RIntSet +complement = unRangeList . complementRangeList . toRangeList + +{- Filter -} + +-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ +-- comprises the elements of @set@ greater than @x@. +split :: Int -> RIntSet -> (RIntSet, RIntSet) +split x s = (l, r) where (l, _, r) = splitMember x s + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: Int -> RIntSet -> (RIntSet, Bool, RIntSet) +splitMember x (RSet xm) + | Just y <- xv = (RSet ml, True, RSet $ insertIf (x < y) (succ x) y mr) + | Just ((u,v), ml') <- Map.maxViewWithKey ml = + if v < x + then (RSet ml, False, RSet mr) + else (RSet $ insertIf (u < x) u (pred x) ml', True, RSet $ insertIf (x < v) (succ x) v mr) + | otherwise = (RSet ml {- empty -}, False, RSet {- mr -} xm) + where + (ml, xv, mr) = Map.splitLookup x xm + insertIf False _ _ = id + insertIf True a b = Map.insert a b + +{- Min/Max -} + +-- | /O(log n)/. The minimal element of a set. +findMin :: RIntSet -> Int +findMin (RSet m) = fst $ Map.findMin m + +-- | /O(log n)/. The maximal element of a set. +findMax :: RIntSet -> Int +findMax (RSet m) = snd $ Map.findMax m + +{- Conversion -} + +unRangeList :: [(Int, Int)] -> RIntSet +unRangeList = RSet . Map.fromDistinctAscList + +-- | /O(n*r)/. An alias of 'toAscList'. The elements of a set in ascending +-- order. /r/ is the size of longest range. +elems :: RIntSet -> [Int] +elems = toAscList + +-- | /O(n*r)/. Convert the set to a list of elements (in arbitrary order). /r/ +-- is the size of longest range. +toList :: RIntSet -> [Int] +toList (RSet xm) = Map.foldMapWithKey enumFromTo xm + +-- | /O(n*log n)/. Create a set from a list of elements. +-- +-- Note that unlike "Data.Set" and other binary trees, this always requires a +-- full sort and traversal to create distinct, disjoint ranges before +-- constructing the tree. +fromList :: [Int] -> RIntSet +fromList = unRangeList . fromElemList + +-- | /O(n)/. Create a set from a list of ascending elements. +-- +-- /The precondition is not checked./ You may use 'valid' to check the result. +-- Note that unlike "Data.Set" and other binary trees, this always requires a +-- full traversal to create distinct, disjoint ranges before constructing the +-- tree. +fromAscList :: [Int] -> RIntSet +fromAscList = unRangeList . fromAscElemList + +-- | /O(n*r)/. Convert the set to an ascending list of elements. +toAscList :: RIntSet -> [Int] +toAscList (RSet xm) = Map.foldrWithKey (\a -> (++) . enumFromTo a) [] xm + +-- | /O(n)/. Convert the set to a list of range pairs. +toRangeList :: RIntSet -> [(Int, Int)] +toRangeList (RSet xs) = Map.toAscList xs + +-- | /O(n*log n)/. Create a set from a list of range pairs. +-- +-- Note that unlike "Data.Set" and other binary trees, this always requires a +-- full sort and traversal to create distinct, disjoint ranges before +-- constructing the tree. +fromRangeList :: [(Int, Int)] -> RIntSet +fromRangeList = unRangeList . normalizeRangeList + +-- | /O(n)/. Convert a list-based 'RList.RSet' to a map-based 'RIntSet'. +fromRList :: RList.RSet Int -> RIntSet +fromRList = fromNormalizedRangeList . RList.toRangeList + +-- | /O(n)/. Convert a map-based 'RIntSet' to a list-based 'RList.RSet'. +toRList :: RIntSet -> RList.RSet Int +toRList = RList.fromNormalizedRangeList . toRangeList + +-- | /O(n)/. Convert a normalized, non-adjacent, ascending list of ranges to a set. +-- +-- /The precondition is not checked./ In general you should only use this +-- function on the result of 'toRangeList' or ensure 'valid' on the result. +fromNormalizedRangeList :: [(Int, Int)] -> RIntSet +fromNormalizedRangeList = RSet . Map.fromDistinctAscList + +-- | /O(n)/. Ensure that a set is valid. All functions should return valid sets +-- except those with unchecked preconditions: 'fromAscList', +-- 'fromNormalizedRangeList' +valid :: RIntSet -> Bool +valid = validRangeList . toRangeList + diff --git a/src/Data/RangeSet/Internal.hs b/src/Data/RangeSet/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/RangeSet/Internal.hs @@ -0,0 +1,202 @@ +{- | +Module : Data.RangeSet.Internal +Description : Support functions for dealing with distinct ordered range lists +Copyright : (c) Dylan Simon 2015 +License : MIT + +Maintainer : oleg.grenrus@iki.fi +Stability : experimental +Portability : non-portable (tested with GHC only) + +Most functions in this module deal with normalized (closed, fst <= snd, +non-overlapping, non-adjacent, ordered) ranges, but do not check this +assumption. Most users should use a higher-level interface. +-} +{-# LANGUAGE Safe #-} +module Data.RangeSet.Internal + ( rangeSize + , rangeIsSubsetList + , isSubsetRangeList + , insertRangeList + , deleteRangeList + , unionRangeList + , differenceRangeList + , intersectRangeList + , complementRangeList + , fromAscElemList + , fromElemList + , normalizeRangeList + , validRangeList + ) where + +import Data.List (sort) +import Data.Monoid (Sum (..)) + +-- | Determine the number of items in an 'Enum' range as a 'Sum' +rangeSize :: Enum a => a -> a -> Sum Int +rangeSize a b = Sum $ succ $ fromEnum b - fromEnum a + +-- | Determine if @[x,y]@ is a subset of the list, returning the list right of +-- @y@ if so. +rangeIsSubsetList :: Ord a => a -> a -> [(a, a)] -> Maybe [(a, a)] +rangeIsSubsetList x y ((u,v):s) + | x < u = Nothing + | y <= v = Just ((y,v):s) + | otherwise = rangeIsSubsetList x y s +rangeIsSubsetList _ _ [] = Nothing + +-- | Determine if the first list is a subset of the second. +isSubsetRangeList :: Ord a => [(a, a)] -> [(a, a)] -> Bool +isSubsetRangeList ((x,y):as) bs = maybe False (isSubsetRangeList as) $ rangeIsSubsetList x y bs +isSubsetRangeList [] _ = True + +-- | Add @[x,y]@. +-- +-- There are three possibilities we consider, when inserting into non-empty set: +-- +-- * discretely after: continue +-- * discretely before: prepend +-- * overlapping: union and prepend +insertRangeList :: (Ord a, Enum a) => a -> a -> [(a, a)] -> [(a, a)] +insertRangeList x y set@(uv@(u,v) : xs) + | v < x && succ v /= x = uv : insertRangeList x y xs + | y < u && succ y /= u = (x,y) : set + | otherwise = prependRangeList (min x u) (max y v) xs +insertRangeList x y [] = [(x,y)] + +-- | Add @[x,y]@ to the beginning (assuming @x <= u@). +prependRangeList :: (Ord a, Enum a) => a -> a -> [(a, a)] -> [(a, a)] +prependRangeList x y set@((u,v) : xs) + | y < u && succ y /= u = (x,y) : set + | otherwise = prependRangeList x (max y v) xs +prependRangeList x y [] = [(x,y)] + +-- | Union two range lists. +unionRangeList :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] -> [(a, a)] +unionRangeList aset@(xy@(x,y):as) bset@(uv@(u,v):bs) + | y < u && succ y /= u = xy : unionRangeList as bset + | v < x && succ v /= x = uv : unionRangeList aset bs + | otherwise = prependRangeList (min x u) (max y v) $ unionRangeList as bs +unionRangeList s [] = s +unionRangeList [] s = s + +-- | Remove a range from a range list. +-- +-- There are 6 possibilities we consider, when deleting from non-empty set: +-- +-- * more +-- * less +-- * strictly inside (splits) +-- * overlapping less-edge +-- * overlapping more-edge +-- * stricly larger +deleteRangeList :: (Ord a, Enum a) => a -> a -> [(a, a)] -> [(a, a)] +deleteRangeList x y set@(s@(u,v) : xs) + | v < x = s : deleteRangeList x y xs + | y < u = set + | u < x = (u, pred x) : t + | otherwise = t where + t = trimRangeList' y v xs +deleteRangeList _ _ [] = [] + +-- | Remove @(,y]@ while (re-)adding @(y,v]@ if valid +trimRangeList' :: (Ord a, Enum a) => a -> a -> [(a, a)] -> [(a, a)] +trimRangeList' y v xs + | y < v = (succ y, v) : xs + | otherwise = trimRangeList y xs + +-- | Remove @(,y]@ +trimRangeList :: (Ord a, Enum a) => a -> [(a, a)] -> [(a, a)] +trimRangeList y set@((u,v) : xs) + | y < u = set + | otherwise = trimRangeList' y v xs +trimRangeList _ [] = [] + +-- | Compute the set difference, removing each range in the second list from +-- the first. +differenceRangeList :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] -> [(a, a)] +differenceRangeList aset@(xy@(x,y):as) bset@((u,v):bs) + | y < u = xy : differenceRangeList as bset + | v < x = differenceRangeList aset bs + | x < u = (x, pred u) : t + | otherwise = t where + t = differenceRangeList (trimRangeList' v y as) bs +differenceRangeList s [] = s +differenceRangeList [] _ = [] + +-- | Compute the intersection. +intersectRangeList :: Ord a => [(a, a)] -> [(a, a)] -> [(a, a)] +intersectRangeList aset@((x,y):as) bset@((u,v):bs) + | y < u = intersectRangeList as bset + | v < x = intersectRangeList aset bs + | y < v = (max x u, y) : intersectRangeList as bset + | otherwise = (max x u, v) : intersectRangeList aset bs +intersectRangeList _ [] = [] +intersectRangeList [] _ = [] + +-- | Compute the complement intersected with @[x,)@ assuming @x a -> [(a, a)] -> [(a, a)] +complementRangeList' x ((u,v):s) = (x,pred u) : complementRangeList'' v s +complementRangeList' x [] = [(x,maxBound)] + +-- | Compute the complement intersected with @(x,)@. +complementRangeList'' :: (Ord a, Enum a, Bounded a) => a -> [(a, a)] -> [(a, a)] +complementRangeList'' x s + | x == maxBound = [] + | otherwise = complementRangeList' (succ x) s + +-- | Compute the complement. +complementRangeList :: (Ord a, Enum a, Bounded a) => [(a, a)] -> [(a, a)] +complementRangeList s@((x,y):s') + | x == minBound = complementRangeList'' y s' + | otherwise = complementRangeList' minBound s +complementRangeList [] = [(minBound, maxBound)] + +-- | Take elements off the beginning of the list while they are equal or +-- adjacent to the given item, and return the last removed item and remaining +-- list. +takeWhileAdj :: (Eq a, Enum a) => a -> [a] -> (a, [a]) +takeWhileAdj x yl@(y:l) + | x == y || succ x == y = takeWhileAdj y l + | otherwise = (x, yl) +takeWhileAdj x [] = (x, []) + +-- | Take ranges off the beginning of a unnormalized but sorted and valid range +-- list while they are overlapping or adjacent to the given value, and return +-- the last removed item and remaining list. +takeWhileRangeAdj :: (Ord a, Enum a) => a -> [(a,a)] -> (a, [(a,a)]) +takeWhileRangeAdj x yzl@((y,z):l) + | x >= y || succ x == y = takeWhileRangeAdj (max x z) l + | otherwise = (x, yzl) +takeWhileRangeAdj x [] = (x, []) + +-- | Normalize a sorted list of elements to a range list. +fromAscElemList :: (Eq a, Enum a) => [a] -> [(a, a)] +fromAscElemList (x:l) = (x, y) : fromAscElemList l' where + (y, l') = takeWhileAdj x l +fromAscElemList [] = [] + +-- | Normalize an arbitrary list of elements to a range list. +fromElemList :: (Ord a, Enum a) => [a] -> [(a, a)] +fromElemList = fromAscElemList . sort + +-- | Normalize a sorted list of valid ranges. +mergeRangeList :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] +mergeRangeList ((x,y):l) = (x,y') : mergeRangeList l' where + (y', l') = takeWhileRangeAdj y l +mergeRangeList [] = [] + +-- | Normalize an arbitrary list of ranges. +normalizeRangeList :: (Ord a, Enum a) => [(a, a)] -> [(a, a)] +normalizeRangeList = mergeRangeList . sort . filter valid where + valid (x,y) = x <= y + +-- | Check if a list is normalized and strictly above @b@. +validRangeList' :: (Ord a, Enum a, Bounded a) => a -> [(a, a)] -> Bool +validRangeList' b ((x,y):s) = b < maxBound && succ b < x && x <= y && validRangeList' y s +validRangeList' _ [] = True + +-- | Check if a list is normalized. +validRangeList :: (Ord a, Enum a, Bounded a) => [(a, a)] -> Bool +validRangeList ((x,y):s) = x <= y && validRangeList' y s +validRangeList [] = True diff --git a/src/Data/RangeSet/List.hs b/src/Data/RangeSet/List.hs --- a/src/Data/RangeSet/List.hs +++ b/src/Data/RangeSet/List.hs @@ -18,18 +18,20 @@ The implementation of 'RSet' is based on /list/. -Compared to 'Data.Set', this module imposes also 'Enum' restriction for many functions. -We must be able to identify consecutive elements to be able to /glue/ and /split/ ranges properly. +Compared to 'Data.Set', this module imposes also 'Enum' restriction for many +functions. We must be able to identify consecutive elements to be able to +/glue/ and /split/ ranges properly. The implementation assumes that > x < succ x > pred x < x -and there aren't elements in between (not true for 'Float' and 'Double'). -Also 'succ' and 'pred' are never called for largest or smallest value respectively. +and there aren't elements in between (not true for 'Float' and 'Double'). Also +'succ' and 'pred' are never called for largest or smallest value respectively. -} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} module Data.RangeSet.List ( -- * Range set type RSet @@ -39,9 +41,17 @@ -- * Query , null + , isFull , size , member , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + , containsRange + , isSubsetOf + , valid -- * Construction , empty @@ -58,6 +68,10 @@ , difference , intersection + -- * Filter + , split + , splitMember + -- * Min/Max , findMin , findMax @@ -69,20 +83,29 @@ , elems , toList , fromList + , fromAscList + , toAscList , toRangeList , fromRangeList + , fromNormalizedRangeList + , toSet ) where -import Prelude hiding (filter,foldl,foldr,null,map) +import Prelude hiding (filter, foldl, foldr, map, null) import qualified Prelude -import Control.DeepSeq (NFData(..)) -import Data.Typeable (Typeable) -import Data.Semigroup (Semigroup(..)) -import Data.Monoid (Monoid(..)) -import Data.Hashable (Hashable(..)) +import Control.DeepSeq (NFData (..)) +import Data.Foldable (foldMap) +import Data.Hashable (Hashable (..)) +import Data.Maybe (isJust) +import Data.Monoid (Monoid (..), getSum) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Data.RangeSet.Internal + -- | Internally set is represented as sorted list of distinct inclusive ranges. newtype RSet a = RSet [(a, a)] deriving (Eq, Ord, Typeable) @@ -116,21 +139,76 @@ null :: RSet a -> Bool null = Prelude.null . toRangeList +-- | /O(1)/. Is this the full set? +isFull :: (Eq a, Bounded a) => RSet a -> Bool +isFull = (==) full + -- | /O(n)/. The number of the elements in the set. size :: Enum a => RSet a -> Int -size (RSet xs) = sum (Prelude.map f xs) - where f (a, b) = fromEnum b - fromEnum a + 1 +size (RSet xs) = getSum $ foldMap (uncurry rangeSize) xs -- | /O(n)/. Is the element in the set? -member :: (Ord a, Enum a) => a -> RSet a -> Bool -member x (RSet xs) = any f $ takeWhile g xs - where f (a, b) = a <= x && x <= b - g (a,_) = a <= x +member :: Ord a => a -> RSet a -> Bool +member x (RSet xs) = f xs where + f ((a,b):s) + | x < a = False + | x <= b = True + | otherwise = f s + f [] = False -- | /O(n)/. Is the element not in the set? -notMember :: (Ord a, Enum a) => a -> RSet a -> Bool +notMember :: Ord a => a -> RSet a -> Bool notMember a r = not $ member a r +-- | /O(n)/. Find largest element smaller than the given one. +lookupLT :: (Ord a, Enum a) => a -> RSet a -> Maybe a +lookupLT x (RSet xs) = f Nothing xs where + f l ((a,b):s) + | x <= a = l + | x <= b || pred x == b = Just (pred x) + | otherwise = f (Just b) s + f l [] = l + +-- | /O(n)/. Find smallest element greater than the given one. +lookupGT :: (Ord a, Enum a) => a -> RSet a -> Maybe a +lookupGT x (RSet xs) = f xs where + f ((a,b):s) + | x < a = Just a + | x < b = Just (succ x) + | otherwise = f s + f [] = Nothing + +-- | /O(n)/. Find largest element smaller or equal to than the given one. +lookupLE :: Ord a => a -> RSet a -> Maybe a +lookupLE x (RSet xs) = f Nothing xs where + f l ((a,b):s) + | x < a = l + | x <= b = Just x + | otherwise = f (Just b) s + f l [] = l + +-- | /O(n)/. Find smallest element greater or equal to than the given one. +lookupGE :: Ord a => a -> RSet a -> Maybe a +lookupGE x (RSet xs) = f xs where + f ((a,b):s) + | x <= a = Just a + | x <= b = Just x + | otherwise = f s + f [] = Nothing + +-- | /O(n)/. Is the entire range contained within the set? +containsRange :: Ord a => (a, a) -> RSet a -> Bool +containsRange (x,y) (RSet xs) + | x <= y = isJust $ rangeIsSubsetList x y xs + | otherwise = True + +-- | /O(n+m)/. Is this a subset? +-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +isSubsetOf :: Ord a => RSet a -> RSet a -> Bool +isSubsetOf (RSet xs) (RSet ys) = isSubsetRangeList xs ys + +-- MISSING: isProperSubsetOf isRangeProperSubsetOf? overlapsRange? + {- Construction -} -- | /O(1)/. The empty set. @@ -139,89 +217,92 @@ -- | /O(1)/. The full set. full :: Bounded a => RSet a -full = RSet [(minBound, maxBound)] +full = singletonRange' minBound maxBound +singletonRange' :: a -> a -> RSet a +singletonRange' x y = RSet [(x, y)] + -- | /O(1)/. Create a singleton set. singleton :: a -> RSet a -singleton x = RSet [(x, x)] +singleton x = singletonRange' x x -- | /O(1)/. Create a continuos range set. singletonRange :: Ord a => (a, a) -> RSet a singletonRange (x, y) | x > y = empty - | otherwise = RSet [(x, y)] + | otherwise = singletonRange' x y {- Construction -} -- | /O(n)/. Insert an element in a set. insert :: (Ord a, Enum a) => a -> RSet a -> RSet a -insert x = insertRange (x, x) +insert x (RSet xs) = RSet $ insertRangeList x x xs -- | /O(n)/. Insert a continuos range in a set. insertRange :: (Ord a, Enum a) => (a, a) -> RSet a -> RSet a -insertRange r@(x, y) set@(RSet xs) +insertRange (x, y) set@(RSet xs) | x > y = set - | otherwise = RSet $ insertRange' r xs - --- There are three possibilities we consider, when inserting into non-empty set: --- * discretely less --- * discretely more --- * other -insertRange' :: (Ord a, Enum a) => (a, a) -> [(a, a)] -> [(a, a)] -insertRange' r [] = [r] -insertRange' r@(x, y) set@(s@(u, v) : xs) - | y < u && succ y /= u = r : set - | v < x && succ v /= x = s : insertRange' r xs - | otherwise = insertRange' (min x u, max y v) xs + | otherwise = RSet $ insertRangeList x y xs -- | /O(n). Delete an element from a set. delete :: (Ord a, Enum a) => a -> RSet a -> RSet a -delete x = deleteRange (x, x) +delete x (RSet xs) = RSet $ deleteRangeList x x xs -- | /O(n). Delete a continuos range from a set. deleteRange :: (Ord a, Enum a) => (a, a) -> RSet a -> RSet a -deleteRange r@(x, y) set@(RSet xs) +deleteRange (x, y) set@(RSet xs) | x > y = set - | otherwise = RSet $ deleteRange' r xs - --- There are 6 possibilities we consider, when deleting from non-empty set: --- * less --- * more --- * strictly inside (splits) --- * overlapping less-edge --- * overlapping more-edge --- * stricly larger --- --- TODO: is there simpler rules, with less cases -deleteRange' :: (Ord a, Enum a) => (a, a) -> [(a, a)] -> [(a, a)] -deleteRange' _ [] = [] -deleteRange' r@(x, y) set@(s@(u, v) : xs) - | y < u = set - | v < x = s : deleteRange' r xs - | u < x && y < v = (u, pred x) : (succ y, v) : xs - | y < v = (succ y, v) : xs - | u < x = (u, pred x) : deleteRange' r xs - | otherwise = deleteRange' r xs + | otherwise = RSet $ deleteRangeList x y xs {- Combination -} --- | /O(n*m)/. The union of two sets. +-- | /O(n+m)/. The union of two sets. union :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a -union set (RSet xs) = Prelude.foldr insertRange set xs +union (RSet xs) (RSet ys) = RSet $ unionRangeList xs ys --- | /O(n*m)/. Difference of two sets. +-- | /O(n+m)/. Difference of two sets. difference :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a -difference set (RSet xs) = Prelude.foldr deleteRange set xs +difference (RSet xs) (RSet ys) = RSet $ differenceRangeList xs ys --- | /O(n*m)/. The intersection of two sets. -intersection :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a -intersection a b = a \\ (a \\ b) +-- | /O(n+m)/. The intersection of two sets. +intersection :: (Ord a) => RSet a -> RSet a -> RSet a +intersection (RSet xs) (RSet ys) = RSet $ intersectRangeList xs ys {- Complement -} -- | /O(n)/. Complement of the set. complement :: (Ord a, Enum a, Bounded a) => RSet a -> RSet a -complement a = full `difference` a +complement (RSet xs) = RSet $ complementRangeList xs +{- Filter -} + +-- MISSING: filter partition filterRanges? partitionRanges? + +-- | /O(n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ +-- comprises the elements of @set@ greater than @x@. +split :: (Ord a, Enum a) => a -> RSet a -> (RSet a, RSet a) +split x s = (l, r) where (l, _, r) = splitMember x s + +-- | /O(n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: (Ord a, Enum a) => a -> RSet a -> (RSet a, Bool, RSet a) +splitMember x (RSet xs) = f xs where + f s@(r@(a,b):s') = case compare x a of + LT -> (empty, False, RSet s) + EQ -> (empty, True, RSet xs') + GT + | x <= b -> (RSet [(a, pred x)], True, RSet xs') + | otherwise -> push r $ f s' + where + xs' + | x < b = (succ x,b):s' + | otherwise = s' + f [] = (empty, False, empty) + push r (RSet ls, b, RSet rs) = (RSet (r:ls), b, RSet rs) + +-- MISSING: lookupIndex findIndex elemAt deleteAt map mapMonotonic fold* +-- mapMonotonic may be reasonable as just need to map range endpoints and check adjacency + {- Min/Max -} -- | /O(1)/. The minimal element of a set. @@ -236,25 +317,59 @@ findMax' (_:xs) = findMax' xs findMax' _ = error "RangeSet.List.findMax: empty set" +-- MISSING: deleteMin deleteMax deleteFindMin deleteFindMax minView maxView + {- Conversion -} --- | /O(n*r)/. Convert the set to a list of elements. /r/ is the size of longest range. +-- | /O(n*r)/. An alias of 'toAscList'. The elements of a set in ascending +-- order. /r/ is the size of longest range. elems :: Enum a => RSet a -> [a] -elems = toList +elems = toAscList --- | /O(n*r)/. Convert the set to a list of elements. /r/ is the size of longest range. +-- | /O(n*r)/. Convert the set to a list of elements. /r/ is the size of +-- longest range. toList :: Enum a => RSet a -> [a] toList (RSet xs) = concatMap (uncurry enumFromTo) xs --- | /O(n^2)/. Create a set from a list of elements. +-- | /O(n*log n)/. Create a set from a list of elements. fromList :: (Ord a, Enum a) => [a] -> RSet a -fromList = fromRangeList . Prelude.map f - where f a = (a, a) +fromList = RSet . fromElemList +-- | /O(n)/. Create a set from a list of ascending elements. +-- +-- /The precondition is not checked./ You may use 'valid' to check the result. +fromAscList :: (Ord a, Enum a) => [a] -> RSet a +fromAscList = RSet . fromAscElemList + +-- | /O(n*r)/. Convert the set to an ascending list of elements. +toAscList :: Enum a => RSet a -> [a] +toAscList = toList + -- | /O(1)/. Convert the set to a list of range pairs. toRangeList :: RSet a -> [(a, a)] toRangeList (RSet xs) = xs --- | /O(n^2)/. Create a set from a list of range pairs. +-- | /O(n*log n)/. Create a set from a list of range pairs. fromRangeList :: (Ord a, Enum a) => [(a, a)] -> RSet a -fromRangeList = Prelude.foldr insertRange empty +fromRangeList = RSet . normalizeRangeList + +-- | /O(n*r)/. Convert the set to a 'Set.Set' of elements. /r/ is the size of +-- longest range. +toSet :: Enum a => RSet a -> Set.Set a +toSet = Set.fromDistinctAscList . toAscList + +-- | /O(1)/. Convert a normalized, non-adjacent, ascending list of ranges to a +-- set. +-- +-- /The precondition is not checked./ In general you should only use this +-- function on the result of 'toRangeList' or ensure 'valid' on the result. +fromNormalizedRangeList :: [(a, a)] -> RSet a +fromNormalizedRangeList = RSet + +-- | /O(n)/. Ensure that a set is valid. All functions should return valid sets +-- except those with unchecked preconditions: 'fromAscList', +-- 'fromNormalizedRangeList' +valid :: (Ord a, Enum a, Bounded a) => RSet a -> Bool +valid (RSet xs) = validRangeList xs + +-- MISSING: fromDistinctAscList fromAscRangeList diff --git a/src/Data/RangeSet/Map.hs b/src/Data/RangeSet/Map.hs new file mode 100644 --- /dev/null +++ b/src/Data/RangeSet/Map.hs @@ -0,0 +1,342 @@ +{- | +Module : Data.RangeSet.Map +Description : A slightly less trivial implementation of range sets +Copyright : (c) Dylan Simon, 2015 +License : MIT + +A slightly less trivial implementation of range sets. + +This is nearly identical to "Data.RangeSet.List" except for some important +performance differences: + +* Most query functions in this module are /O(log n)/ rather than /O(n)/, so may + be much faster. +* Most composition functions have the same time complexity but a higher + constant, so may be somewhat slower. + +If you're mainly calling 'member', you should consider using this module, but +if you're calling 'union', 'deleteRange', and other range manipulation +functions as often as querying, you might stick with the list implementation. + +This module is intended to be imported qualified, to avoid name +clashes with Prelude functions, e.g. + +> import Data.RangeSet.Map (RSet) +> import qualified Data.RangeSet.Map as RSet + +The implementation of 'RSet' is based on "Data.Map.Strict". + +-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Safe #-} +module Data.RangeSet.Map ( + -- * Range set type + RSet + + -- * Operators + , (\\) + + -- * Query + , null + , isFull + , size + , member + , notMember + , lookupLT + , lookupGT + , lookupLE + , lookupGE + , containsRange + , isSubsetOf + , valid + + -- * Construction + , empty + , full + , singleton + , singletonRange + , insert + , insertRange + , delete + , deleteRange + + -- * Combine + , union + , difference + , intersection + + -- * Filter + , split + , splitMember + + -- * Min/Max + , findMin + , findMax + + -- * Complement + , complement + + -- * Conversion + , elems + , toList + , fromList + , fromAscList + , toAscList + , toRangeList + , fromRangeList + , fromRList + , toRList + , fromNormalizedRangeList + + ) where + +import Prelude hiding (filter, foldl, foldr, map, null) + +import Control.DeepSeq (NFData (..)) +import qualified Data.Foldable as Fold +import Data.Functor ((<$>)) +import qualified Data.Map.Strict as Map +import Data.Monoid (Monoid (..), getSum) +import Data.Semigroup (Semigroup (..)) +import Data.Typeable (Typeable) + +import Data.RangeSet.Internal +import qualified Data.RangeSet.List as RList + +-- | Internally set is represented as sorted list of distinct inclusive ranges. +newtype RSet a = RSet (Map.Map a a) + deriving (Eq, Ord, Typeable) + +instance Show a => Show (RSet a) where + show x = "fromRangeList " ++ show (toRangeList x) + +instance (Ord a, Enum a) => Semigroup (RSet a) where + (<>) = union + +instance (Ord a, Enum a) => Monoid (RSet a) where + mempty = empty + mappend = union + +instance NFData a => NFData (RSet a) where + rnf (RSet xs) = rnf xs + +{- Operators -} +infixl 9 \\ -- + +-- | /O(n+m)/. See 'difference'. +(\\) :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a +m1 \\ m2 = difference m1 m2 + +{- Query -} + +-- | /O(1)/. Is this the empty set? +null :: RSet a -> Bool +null (RSet m) = Map.null m + +-- | /O(1)/. Is this the empty set? +isFull :: (Eq a, Bounded a) => RSet a -> Bool +isFull = (==) full + +-- | /O(n)/. The number of the elements in the set. +size :: Enum a => RSet a -> Int +size (RSet xm) = getSum $ Map.foldMapWithKey rangeSize xm + +contains' :: Ord a => a -> a -> RSet a -> Bool +contains' x y (RSet xm) = Fold.any ((y <=) . snd) $ Map.lookupLE x xm + +-- | /O(log n)/. Is the element in the set? +member :: (Ord a, Enum a) => a -> RSet a -> Bool +member x = contains' x x + +-- | /O(log n)/. Is the element not in the set? +notMember :: (Ord a, Enum a) => a -> RSet a -> Bool +notMember a r = not $ member a r + +-- | /O(log n)/. Find largest element smaller than the given one. +lookupLT :: (Ord a, Enum a) => a -> RSet a -> Maybe a +lookupLT x (RSet xm) = min (pred x) . snd <$> Map.lookupLT x xm + +-- | /O(log n)/. Find smallest element greater than the given one. +lookupGT :: (Ord a, Enum a) => a -> RSet a -> Maybe a +lookupGT x (RSet xm) + | Just (_, b) <- Map.lookupLE x xm, x < b = Just (succ x) + | otherwise = fst <$> Map.lookupGT x xm + +-- | /O(log n)/. Find largest element smaller or equal to than the given one. +lookupLE :: Ord a => a -> RSet a -> Maybe a +lookupLE x (RSet xm) = min x . snd <$> Map.lookupLE x xm + +-- | /O(log n)/. Find smallest element greater or equal to than the given one. +lookupGE :: Ord a => a -> RSet a -> Maybe a +lookupGE x (RSet xm) + | Just (_, b) <- Map.lookupLE x xm, x <= b = Just x + | otherwise = fst <$> Map.lookupGT x xm + +-- | /O(log n)/. Is the entire range contained within the set? +containsRange :: Ord a => (a, a) -> RSet a -> Bool +containsRange (x,y) s + | x <= y = contains' x y s + | otherwise = True + +-- | /O(n+m)/. Is this a subset? +-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +isSubsetOf :: Ord a => RSet a -> RSet a -> Bool +isSubsetOf x y = isSubsetRangeList (toRangeList x) (toRangeList y) + +{- Construction -} + +-- | /O(1)/. The empty set. +empty :: RSet a +empty = RSet Map.empty + +-- | /O(1)/. The full set. +full :: Bounded a => RSet a +full = singletonRange' minBound maxBound + +singletonRange' :: a -> a -> RSet a +singletonRange' x y = RSet $ Map.singleton x y + +-- | /O(1)/. Create a singleton set. +singleton :: a -> RSet a +singleton x = singletonRange' x x + +-- | /O(1)/. Create a continuos range set. +singletonRange :: Ord a => (a, a) -> RSet a +singletonRange (x, y) | x > y = empty + | otherwise = singletonRange' x y + +{- Construction -} + +insertRange' :: (Ord a, Enum a) => a -> a -> RSet a -> RSet a +insertRange' x y s = unRangeList $ insertRangeList x y $ toRangeList s + +-- | /O(n)/. Insert an element in a set. +insert :: (Ord a, Enum a) => a -> RSet a -> RSet a +insert x = insertRange' x x + +-- | /O(n)/. Insert a continuos range in a set. +insertRange :: (Ord a, Enum a) => (a, a) -> RSet a -> RSet a +insertRange (x, y) set + | x > y = set + | otherwise = insertRange' x y set + +deleteRange' :: (Ord a, Enum a) => a -> a -> RSet a -> RSet a +deleteRange' x y = unRangeList . deleteRangeList x y . toRangeList + +-- | /O(n). Delete an element from a set. +delete :: (Ord a, Enum a) => a -> RSet a -> RSet a +delete x = deleteRange' x x + +-- | /O(n). Delete a continuos range from a set. +deleteRange :: (Ord a, Enum a) => (a, a) -> RSet a -> RSet a +deleteRange (x, y) set + | x > y = set + | otherwise = deleteRange' x y set + +{- Combination -} + +-- | /O(n*m)/. The union of two sets. +union :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a +union x y = unRangeList $ unionRangeList (toRangeList x) (toRangeList y) + +-- | /O(n*m)/. Difference of two sets. +difference :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a +difference x y = unRangeList $ differenceRangeList (toRangeList x) (toRangeList y) + +-- | /O(n*m)/. The intersection of two sets. +intersection :: (Ord a, Enum a) => RSet a -> RSet a -> RSet a +intersection x y = unRangeList $ intersectRangeList (toRangeList x) (toRangeList y) + +{- Complement -} + +-- | /O(n)/. Complement of the set. +complement :: (Ord a, Enum a, Bounded a) => RSet a -> RSet a +complement = unRangeList . complementRangeList . toRangeList + +{- Filter -} + +-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ +-- comprises the elements of @set@ greater than @x@. +split :: (Ord a, Enum a) => a -> RSet a -> (RSet a, RSet a) +split x s = (l, r) where (l, _, r) = splitMember x s + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: (Ord a, Enum a) => a -> RSet a -> (RSet a, Bool, RSet a) +splitMember x (RSet xm) + | Just y <- xv = (RSet ml, True, RSet $ insertIf (x < y) (succ x) y mr) + | Just ((u,v), ml') <- Map.maxViewWithKey ml = + if v < x + then (RSet ml, False, RSet mr) + else (RSet $ insertIf (u < x) u (pred x) ml', True, RSet $ insertIf (x < v) (succ x) v mr) + | otherwise = (RSet ml {- empty -}, False, RSet {- mr -} xm) + where + (ml, xv, mr) = Map.splitLookup x xm + insertIf False _ _ = id + insertIf True a b = Map.insert a b + +{- Min/Max -} + +-- | /O(log n)/. The minimal element of a set. +findMin :: RSet a -> a +findMin (RSet m) = fst $ Map.findMin m + +-- | /O(log n)/. The maximal element of a set. +findMax :: RSet a -> a +findMax (RSet m) = snd $ Map.findMax m + +{- Conversion -} + +unRangeList :: [(a, a)] -> RSet a +unRangeList = RSet . Map.fromDistinctAscList + +-- | /O(n*r)/. An alias of 'toAscList'. The elements of a set in ascending order. /r/ is the size of longest range. +elems :: Enum a => RSet a -> [a] +elems = toAscList + +-- | /O(n*r)/. Convert the set to a list of elements (in arbitrary order). /r/ is the size of longest range. +toList :: Enum a => RSet a -> [a] +toList (RSet xm) = Map.foldMapWithKey enumFromTo xm + +-- | /O(n*log n)/. Create a set from a list of elements. +-- Note that unlike "Data.Set" and other binary trees, this always requires a full sort and traversal to create distinct, disjoint ranges before constructing the tree. +fromList :: (Ord a, Enum a) => [a] -> RSet a +fromList = unRangeList . fromElemList + +-- | /O(n)/. Create a set from a list of ascending elements. +-- /The precondition is not checked./ You may use 'valid' to check the result. +-- Note that unlike "Data.Set" and other binary trees, this always requires a full traversal to create distinct, disjoint ranges before constructing the tree. +fromAscList :: (Ord a, Enum a) => [a] -> RSet a +fromAscList = unRangeList . fromAscElemList + +-- | /O(n*r)/. Convert the set to an ascending list of elements. +toAscList :: Enum a => RSet a -> [a] +toAscList (RSet xm) = Map.foldrWithKey (\a -> (++) . enumFromTo a) [] xm + +-- | /O(n)/. Convert the set to a list of range pairs. +toRangeList :: RSet a -> [(a, a)] +toRangeList (RSet xs) = Map.toAscList xs + +-- | /O(n*log n)/. Create a set from a list of range pairs. +-- Note that unlike "Data.Set" and other binary trees, this always requires a full sort and traversal to create distinct, disjoint ranges before constructing the tree. +fromRangeList :: (Ord a, Enum a) => [(a, a)] -> RSet a +fromRangeList = unRangeList . normalizeRangeList + +-- | /O(n)/. Convert a list-based 'RList.RSet' to a map-based 'RSet'. +fromRList :: RList.RSet a -> RSet a +fromRList = fromNormalizedRangeList . RList.toRangeList + +-- | /O(n)/. Convert a map-based 'RSet' to a list-based 'RList.RSet'. +toRList :: RSet a -> RList.RSet a +toRList = RList.fromNormalizedRangeList . toRangeList + +-- | /O(n)/. Convert a normalized, non-adjacent, ascending list of ranges to a set. +-- /The precondition is not checked./ In general you should only use this function on the result of 'toRangeList' or ensure 'valid' on the result. +fromNormalizedRangeList :: [(a, a)] -> RSet a +fromNormalizedRangeList = RSet . Map.fromDistinctAscList + +-- | /O(n)/. Ensure that a set is valid. All functions should return valid sets except those with unchecked preconditions: 'fromAscList', 'fromNormalizedRangeList' +valid :: (Ord a, Enum a, Bounded a) => RSet a -> Bool +valid (RSet xm) = Map.valid xm && validRangeList (Map.toAscList xm) + diff --git a/tests/IntMap.hs b/tests/IntMap.hs new file mode 100644 --- /dev/null +++ b/tests/IntMap.hs @@ -0,0 +1,164 @@ +module IntMap (intMapProps) where + +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import qualified Data.Set as Set + +import Data.RangeSet.IntMap (RIntSet) +import qualified Data.RangeSet.IntMap as RSet + +import Control.Applicative + +import Data.Semigroup + +import SetAction + +toRSet :: SetAction Int -> RIntSet +toRSet AEmpty = RSet.empty +toRSet (ASingleton a) = RSet.singleton a +toRSet (AFromList l) = RSet.fromList l +toRSet (AInsert a set) = RSet.insert a $ toRSet set +toRSet (ADelete a set) = RSet.delete a $ toRSet set +toRSet (AUnion a b) = RSet.union (toRSet a) (toRSet b) +toRSet (ADifference a b) = RSet.difference (toRSet a) (toRSet b) +toRSet (AIntersection a b) = RSet.intersection (toRSet a) (toRSet b) + +elementsProp :: SetAction Int -> Property +elementsProp seta = Set.elems (toSet seta) === RSet.elems (toRSet seta) + +sizeProp :: SetAction Int -> Property +sizeProp seta = Set.size (toSet seta) === RSet.size (toRSet seta) + +nullProp :: SetAction Int -> Property +nullProp seta = Set.null (toSet seta) === RSet.null (toRSet seta) + +memberProp :: Int -> SetAction Int -> Property +memberProp x seta = Set.member x (toSet seta) === RSet.member x (toRSet seta) + +notMemberProp :: Int -> RSetAction Int -> Property +notMemberProp x seta = Set.notMember x (rangeToSet seta) === RSet.notMember x (rangeToRSet seta) + +lookupLTProp :: Int -> RSetAction Int -> Property +lookupLTProp x seta = Set.lookupLT x (rangeToSet seta) === RSet.lookupLT x (rangeToRSet seta) + +lookupGTProp :: Int -> SetAction Int -> Property +lookupGTProp x seta = Set.lookupGT x (toSet seta) === RSet.lookupGT x (toRSet seta) + +lookupLEProp :: Int -> SetAction Int -> Property +lookupLEProp x seta = Set.lookupLE x (toSet seta) === RSet.lookupLE x (toRSet seta) + +lookupGEProp :: Int -> RSetAction Int -> Property +lookupGEProp x seta = Set.lookupGE x (rangeToSet seta) === RSet.lookupGE x (rangeToRSet seta) + +isSubsetProp :: SetAction Int -> RSetAction Int -> Property +isSubsetProp seta setb = Set.isSubsetOf (toSet seta) (rangeToSet setb) === RSet.isSubsetOf (toRSet seta) (rangeToRSet setb) + +splitProp :: Int -> RSetAction Int -> Property +splitProp x seta = Set.elems sl === RSet.elems rl .&&. sm === rm .&&. Set.elems su === RSet.elems ru where + (sl, sm, su) = Set.splitMember x (rangeToSet seta) + (rl, rm, ru) = RSet.splitMember x (rangeToRSet seta) + +rangeToRSet :: RSetAction Int -> RIntSet +rangeToRSet RAEmpty = RSet.empty +rangeToRSet (RASingleton a) = RSet.singletonRange a +rangeToRSet (RAFromList l) = RSet.fromRangeList l +rangeToRSet (RAInsert a set) = RSet.insertRange a $ rangeToRSet set +rangeToRSet (RADelete a set) = RSet.deleteRange a $ rangeToRSet set +rangeToRSet (RAUnion a b) = RSet.union (rangeToRSet a) (rangeToRSet b) +rangeToRSet (RADifference a b) = RSet.difference (rangeToRSet a) (rangeToRSet b) +rangeToRSet (RAIntersection a b) = RSet.intersection (rangeToRSet a) (rangeToRSet b) + +rangeProp :: RSetAction Int -> Property +rangeProp seta = Set.elems (rangeToSet seta) === RSet.elems (rangeToRSet seta) + +ordered :: Ord a => [(a,a)] -> Bool +ordered rs = all lt $ zip rs (tail rs) + where + lt :: Ord a => ((a,a),(a,a)) -> Bool + lt ((_,y),(u,_)) = y < u + +pairOrdered :: Ord a => [(a, a)] -> Bool +pairOrdered = all (uncurry (<=)) + +orderedProp :: RSetAction Int -> Bool +orderedProp setAction = ordered rs && pairOrdered rs + where rs = RSet.toRangeList $ rangeToRSet $ setAction + +ascListProp :: RSetAction Int -> Property +ascListProp setAction = RSet.fromAscList (RSet.toAscList rs) === rs + where rs = rangeToRSet setAction + +-- Complement laws +complementProps :: TestTree +complementProps = testGroup "complement" + [ QC.testProperty "definition" (\a e -> RSet.member e (rs a) === RSet.notMember e (RSet.complement (rs a))) + , QC.testProperty "involutive" (\a -> rs a === RSet.complement (RSet.complement (rs a))) + , QC.testProperty "(full \\\\)" (\a -> RSet.complement (rs a) === RSet.full RSet.\\ (rs a)) + ] + where rs = rangeToRSet :: RSetAction Int -> RIntSet + +-- Min/Max laws + +findMinProp :: RSetAction Int -> Property +findMinProp seta + | Set.null s = label "trivial" $ property True + | otherwise = Set.findMin s === RSet.findMin rs + where s = rangeToSet seta + rs = rangeToRSet seta + +findMaxProp :: RSetAction Int -> Property +findMaxProp seta + | Set.null s = label "trivial" $ property True + | otherwise = Set.findMax s === RSet.findMax rs + where s = rangeToSet seta + rs = rangeToRSet seta + +minMaxProps :: TestTree +minMaxProps = testGroup "Min/Max properties" + [ QC.testProperty "findMin" findMinProp + , QC.testProperty "findMax" findMaxProp + ] + +-- Monoid laws +monoidLaws :: TestTree +monoidLaws = testGroup "Monoid laws" + [ QC.testProperty "left identity" (\a -> rs a === mempty <> rs a) + , QC.testProperty "right identity" (\a -> rs a === rs a <> mempty) + , QC.testProperty "associativity" (\a b c -> rs a <> (rs b <> rs c) === (rs a <> rs b) <> rs c) + ] + where rs = rangeToRSet :: RSetAction Int -> RIntSet + +validProp :: SetAction Int -> Property +validProp s = RSet.valid (toRSet s) === True + +validRProp :: RSetAction Int -> Property +validRProp s = RSet.valid (rangeToRSet s) === True + +invalidProp :: Property +invalidProp = RSet.valid (RSet.fromNormalizedRangeList [(-10,-1),(1,0),(2,3 :: Int)]) === False + +-- All QuickCheck properties +intMapProps :: TestTree +intMapProps = testGroup "QuickCheck IntMap properties" + [ QC.testProperty "element operations are similar" elementsProp + , QC.testProperty "size is consistent" sizeProp + , QC.testProperty "null operation is similar" nullProp + , QC.testProperty "member operation is similar" memberProp + , QC.testProperty "notMember operation is similar" notMemberProp + , QC.testProperty "lookupLT operation is similar" lookupLTProp + , QC.testProperty "lookupGT operation is similar" lookupGTProp + , QC.testProperty "lookupLE operation is similar" lookupLEProp + , QC.testProperty "lookupGE operation is similar" lookupGEProp + , QC.testProperty "isSubset operation is similar" isSubsetProp + , QC.testProperty "split operation is similar" splitProp + , QC.testProperty "range operations is similar" rangeProp + , QC.testProperty "ranges remain is ordered" orderedProp + , QC.testProperty "fromAscList . toAscList === id" ascListProp + , complementProps + , minMaxProps + , monoidLaws + , QC.testProperty "item sets valid" validProp + , QC.testProperty "range sets valid" validRProp + , QC.testProperty "fromNormalizedRangeList invalid" invalidProp + ] diff --git a/tests/List.hs b/tests/List.hs new file mode 100644 --- /dev/null +++ b/tests/List.hs @@ -0,0 +1,165 @@ +module List (listProps) where + +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import qualified Data.Set as Set + +import Data.RangeSet.List (RSet) +import qualified Data.RangeSet.List as RSet + +import Control.Applicative +import Data.Int + +import Data.Semigroup + +import SetAction + +toRSet :: (Enum a, Ord a) => SetAction a -> RSet a +toRSet AEmpty = RSet.empty +toRSet (ASingleton a) = RSet.singleton a +toRSet (AFromList l) = RSet.fromList l +toRSet (AInsert a set) = RSet.insert a $ toRSet set +toRSet (ADelete a set) = RSet.delete a $ toRSet set +toRSet (AUnion a b) = RSet.union (toRSet a) (toRSet b) +toRSet (ADifference a b) = RSet.difference (toRSet a) (toRSet b) +toRSet (AIntersection a b) = RSet.intersection (toRSet a) (toRSet b) + +elementsProp :: SetAction Int -> Property +elementsProp seta = Set.elems (toSet seta) === RSet.elems (toRSet seta) + +sizeProp :: SetAction Int -> Property +sizeProp seta = Set.size (toSet seta) === RSet.size (toRSet seta) + +nullProp :: SetAction Int -> Property +nullProp seta = Set.null (toSet seta) === RSet.null (toRSet seta) + +memberProp :: Int -> SetAction Int -> Property +memberProp x seta = Set.member x (toSet seta) === RSet.member x (toRSet seta) + +notMemberProp :: Int -> RSetAction Int -> Property +notMemberProp x seta = Set.notMember x (rangeToSet seta) === RSet.notMember x (rangeToRSet seta) + +lookupLTProp :: Int -> RSetAction Int -> Property +lookupLTProp x seta = Set.lookupLT x (rangeToSet seta) === RSet.lookupLT x (rangeToRSet seta) + +lookupGTProp :: Int -> SetAction Int -> Property +lookupGTProp x seta = Set.lookupGT x (toSet seta) === RSet.lookupGT x (toRSet seta) + +lookupLEProp :: Int -> SetAction Int -> Property +lookupLEProp x seta = Set.lookupLE x (toSet seta) === RSet.lookupLE x (toRSet seta) + +lookupGEProp :: Int -> RSetAction Int -> Property +lookupGEProp x seta = Set.lookupGE x (rangeToSet seta) === RSet.lookupGE x (rangeToRSet seta) + +isSubsetProp :: SetAction Int -> RSetAction Int -> Property +isSubsetProp seta setb = Set.isSubsetOf (toSet seta) (rangeToSet setb) === RSet.isSubsetOf (toRSet seta) (rangeToRSet setb) + +splitProp :: Int -> RSetAction Int -> Property +splitProp x seta = Set.elems sl === RSet.elems rl .&&. sm === rm .&&. Set.elems su === RSet.elems ru where + (sl, sm, su) = Set.splitMember x (rangeToSet seta) + (rl, rm, ru) = RSet.splitMember x (rangeToRSet seta) + +rangeToRSet :: (Enum a, Ord a) => RSetAction a -> RSet a +rangeToRSet RAEmpty = RSet.empty +rangeToRSet (RASingleton a) = RSet.singletonRange a +rangeToRSet (RAFromList l) = RSet.fromRangeList l +rangeToRSet (RAInsert a set) = RSet.insertRange a $ rangeToRSet set +rangeToRSet (RADelete a set) = RSet.deleteRange a $ rangeToRSet set +rangeToRSet (RAUnion a b) = RSet.union (rangeToRSet a) (rangeToRSet b) +rangeToRSet (RADifference a b) = RSet.difference (rangeToRSet a) (rangeToRSet b) +rangeToRSet (RAIntersection a b) = RSet.intersection (rangeToRSet a) (rangeToRSet b) + +rangeProp :: RSetAction Int8 -> Property +rangeProp seta = Set.elems (rangeToSet seta) === RSet.elems (rangeToRSet seta) + +ordered :: Ord a => [(a,a)] -> Bool +ordered rs = all lt $ zip rs (tail rs) + where + lt :: Ord a => ((a,a),(a,a)) -> Bool + lt ((_,y),(u,_)) = y < u + +pairOrdered :: Ord a => [(a, a)] -> Bool +pairOrdered = all (uncurry (<=)) + +orderedProp :: RSetAction Int8 -> Bool +orderedProp setAction = ordered rs && pairOrdered rs + where rs = RSet.toRangeList $ rangeToRSet $ setAction + +ascListProp :: RSetAction Int8 -> Property +ascListProp setAction = RSet.fromAscList (RSet.toAscList rs) === rs + where rs = rangeToRSet setAction + +-- Complement laws +complementProps :: TestTree +complementProps = testGroup "complement" + [ QC.testProperty "definition" (\a e -> RSet.member e (rs a) === RSet.notMember e (RSet.complement (rs a))) + , QC.testProperty "involutive" (\a -> rs a === RSet.complement (RSet.complement (rs a))) + , QC.testProperty "(full \\\\)" (\a -> RSet.complement (rs a) === RSet.full RSet.\\ (rs a)) + ] + where rs = rangeToRSet :: RSetAction Int -> RSet Int + +-- Min/Max laws + +findMinProp :: RSetAction Int8 -> Property +findMinProp seta + | Set.null s = label "trivial" $ property True + | otherwise = Set.findMin s === RSet.findMin rs + where s = rangeToSet seta + rs = rangeToRSet seta + +findMaxProp :: RSetAction Int8 -> Property +findMaxProp seta + | Set.null s = label "trivial" $ property True + | otherwise = Set.findMax s === RSet.findMax rs + where s = rangeToSet seta + rs = rangeToRSet seta + +minMaxProps :: TestTree +minMaxProps = testGroup "Min/Max properties" + [ QC.testProperty "findMin" findMinProp + , QC.testProperty "findMax" findMaxProp + ] + +-- Monoid laws +monoidLaws :: TestTree +monoidLaws = testGroup "Monoid laws" + [ QC.testProperty "left identity" (\a -> rs a === mempty <> rs a) + , QC.testProperty "right identity" (\a -> rs a === rs a <> mempty) + , QC.testProperty "associativity" (\a b c -> rs a <> (rs b <> rs c) === (rs a <> rs b) <> rs c) + ] + where rs = rangeToRSet :: RSetAction Int -> RSet Int + +validProp :: SetAction Int -> Property +validProp s = RSet.valid (toRSet s) === True + +validRProp :: RSetAction Int -> Property +validRProp s = RSet.valid (rangeToRSet s) === True + +invalidProp :: Property +invalidProp = RSet.valid (RSet.fromNormalizedRangeList [(-10,-1),(1,0),(2,3 :: Int)]) === False + +-- All QuickCheck properties +listProps :: TestTree +listProps = testGroup "QuickCheck List properties" + [ QC.testProperty "element operations are similar" elementsProp + , QC.testProperty "size is consistent" sizeProp + , QC.testProperty "null operation is similar" nullProp + , QC.testProperty "member operation is similar" memberProp + , QC.testProperty "notMember operation is similar" notMemberProp + , QC.testProperty "lookupLT operation is similar" lookupLTProp + , QC.testProperty "lookupGT operation is similar" lookupGTProp + , QC.testProperty "lookupLE operation is similar" lookupLEProp + , QC.testProperty "lookupGE operation is similar" lookupGEProp + , QC.testProperty "isSubset operation is similar" isSubsetProp + , QC.testProperty "split operation is similar" splitProp + , QC.testProperty "range operations is similar" rangeProp + , QC.testProperty "ranges remain is ordered" orderedProp + , QC.testProperty "fromAscList . toAscList === id" ascListProp + , complementProps + , minMaxProps + , monoidLaws + , QC.testProperty "item sets valid" validProp + , QC.testProperty "range sets valid" validRProp + , QC.testProperty "fromNormalizedRangeList invalid" invalidProp + ] diff --git a/tests/Map.hs b/tests/Map.hs new file mode 100644 --- /dev/null +++ b/tests/Map.hs @@ -0,0 +1,165 @@ +module Map (mapProps) where + +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import qualified Data.Set as Set + +import Data.RangeSet.Map (RSet) +import qualified Data.RangeSet.Map as RSet + +import Control.Applicative +import Data.Int + +import Data.Semigroup + +import SetAction + +toRSet :: (Enum a, Ord a) => SetAction a -> RSet a +toRSet AEmpty = RSet.empty +toRSet (ASingleton a) = RSet.singleton a +toRSet (AFromList l) = RSet.fromList l +toRSet (AInsert a set) = RSet.insert a $ toRSet set +toRSet (ADelete a set) = RSet.delete a $ toRSet set +toRSet (AUnion a b) = RSet.union (toRSet a) (toRSet b) +toRSet (ADifference a b) = RSet.difference (toRSet a) (toRSet b) +toRSet (AIntersection a b) = RSet.intersection (toRSet a) (toRSet b) + +elementsProp :: SetAction Int -> Property +elementsProp seta = Set.elems (toSet seta) === RSet.elems (toRSet seta) + +sizeProp :: SetAction Int -> Property +sizeProp seta = Set.size (toSet seta) === RSet.size (toRSet seta) + +nullProp :: SetAction Int -> Property +nullProp seta = Set.null (toSet seta) === RSet.null (toRSet seta) + +memberProp :: Int -> SetAction Int -> Property +memberProp x seta = Set.member x (toSet seta) === RSet.member x (toRSet seta) + +notMemberProp :: Int -> RSetAction Int -> Property +notMemberProp x seta = Set.notMember x (rangeToSet seta) === RSet.notMember x (rangeToRSet seta) + +lookupLTProp :: Int -> RSetAction Int -> Property +lookupLTProp x seta = Set.lookupLT x (rangeToSet seta) === RSet.lookupLT x (rangeToRSet seta) + +lookupGTProp :: Int -> SetAction Int -> Property +lookupGTProp x seta = Set.lookupGT x (toSet seta) === RSet.lookupGT x (toRSet seta) + +lookupLEProp :: Int -> SetAction Int -> Property +lookupLEProp x seta = Set.lookupLE x (toSet seta) === RSet.lookupLE x (toRSet seta) + +lookupGEProp :: Int -> RSetAction Int -> Property +lookupGEProp x seta = Set.lookupGE x (rangeToSet seta) === RSet.lookupGE x (rangeToRSet seta) + +isSubsetProp :: SetAction Int -> RSetAction Int -> Property +isSubsetProp seta setb = Set.isSubsetOf (toSet seta) (rangeToSet setb) === RSet.isSubsetOf (toRSet seta) (rangeToRSet setb) + +splitProp :: Int -> RSetAction Int -> Property +splitProp x seta = Set.elems sl === RSet.elems rl .&&. sm === rm .&&. Set.elems su === RSet.elems ru where + (sl, sm, su) = Set.splitMember x (rangeToSet seta) + (rl, rm, ru) = RSet.splitMember x (rangeToRSet seta) + +rangeToRSet :: (Enum a, Ord a) => RSetAction a -> RSet a +rangeToRSet RAEmpty = RSet.empty +rangeToRSet (RASingleton a) = RSet.singletonRange a +rangeToRSet (RAFromList l) = RSet.fromRangeList l +rangeToRSet (RAInsert a set) = RSet.insertRange a $ rangeToRSet set +rangeToRSet (RADelete a set) = RSet.deleteRange a $ rangeToRSet set +rangeToRSet (RAUnion a b) = RSet.union (rangeToRSet a) (rangeToRSet b) +rangeToRSet (RADifference a b) = RSet.difference (rangeToRSet a) (rangeToRSet b) +rangeToRSet (RAIntersection a b) = RSet.intersection (rangeToRSet a) (rangeToRSet b) + +rangeProp :: RSetAction Int8 -> Property +rangeProp seta = Set.elems (rangeToSet seta) === RSet.elems (rangeToRSet seta) + +ordered :: Ord a => [(a,a)] -> Bool +ordered rs = all lt $ zip rs (tail rs) + where + lt :: Ord a => ((a,a),(a,a)) -> Bool + lt ((_,y),(u,_)) = y < u + +pairOrdered :: Ord a => [(a, a)] -> Bool +pairOrdered = all (uncurry (<=)) + +orderedProp :: RSetAction Int8 -> Bool +orderedProp setAction = ordered rs && pairOrdered rs + where rs = RSet.toRangeList $ rangeToRSet $ setAction + +ascListProp :: RSetAction Int8 -> Property +ascListProp setAction = RSet.fromAscList (RSet.toAscList rs) === rs + where rs = rangeToRSet setAction + +-- Complement laws +complementProps :: TestTree +complementProps = testGroup "complement" + [ QC.testProperty "definition" (\a e -> RSet.member e (rs a) === RSet.notMember e (RSet.complement (rs a))) + , QC.testProperty "involutive" (\a -> rs a === RSet.complement (RSet.complement (rs a))) + , QC.testProperty "(full \\\\)" (\a -> RSet.complement (rs a) === RSet.full RSet.\\ (rs a)) + ] + where rs = rangeToRSet :: RSetAction Int -> RSet Int + +-- Min/Max laws + +findMinProp :: RSetAction Int8 -> Property +findMinProp seta + | Set.null s = label "trivial" $ property True + | otherwise = Set.findMin s === RSet.findMin rs + where s = rangeToSet seta + rs = rangeToRSet seta + +findMaxProp :: RSetAction Int8 -> Property +findMaxProp seta + | Set.null s = label "trivial" $ property True + | otherwise = Set.findMax s === RSet.findMax rs + where s = rangeToSet seta + rs = rangeToRSet seta + +minMaxProps :: TestTree +minMaxProps = testGroup "Min/Max properties" + [ QC.testProperty "findMin" findMinProp + , QC.testProperty "findMax" findMaxProp + ] + +-- Monoid laws +monoidLaws :: TestTree +monoidLaws = testGroup "Monoid laws" + [ QC.testProperty "left identity" (\a -> rs a === mempty <> rs a) + , QC.testProperty "right identity" (\a -> rs a === rs a <> mempty) + , QC.testProperty "associativity" (\a b c -> rs a <> (rs b <> rs c) === (rs a <> rs b) <> rs c) + ] + where rs = rangeToRSet :: RSetAction Int -> RSet Int + +validProp :: SetAction Int -> Property +validProp s = RSet.valid (toRSet s) === True + +validRProp :: RSetAction Int -> Property +validRProp s = RSet.valid (rangeToRSet s) === True + +invalidProp :: Property +invalidProp = RSet.valid (RSet.fromNormalizedRangeList [(-10,-1),(1,0),(2,3 :: Int)]) === False + +-- All QuickCheck properties +mapProps :: TestTree +mapProps = testGroup "QuickCheck Map properties" + [ QC.testProperty "element operations are similar" elementsProp + , QC.testProperty "size is consistent" sizeProp + , QC.testProperty "null operation is similar" nullProp + , QC.testProperty "member operation is similar" memberProp + , QC.testProperty "notMember operation is similar" notMemberProp + , QC.testProperty "lookupLT operation is similar" lookupLTProp + , QC.testProperty "lookupGT operation is similar" lookupGTProp + , QC.testProperty "lookupLE operation is similar" lookupLEProp + , QC.testProperty "lookupGE operation is similar" lookupGEProp + , QC.testProperty "isSubset operation is similar" isSubsetProp + , QC.testProperty "split operation is similar" splitProp + , QC.testProperty "range operations is similar" rangeProp + , QC.testProperty "ranges remain is ordered" orderedProp + , QC.testProperty "fromAscList . toAscList === id" ascListProp + , complementProps + , minMaxProps + , monoidLaws + , QC.testProperty "item sets valid" validProp + , QC.testProperty "range sets valid" validRProp + , QC.testProperty "fromNormalizedRangeList invalid" invalidProp + ] diff --git a/tests/SetAction.hs b/tests/SetAction.hs new file mode 100644 --- /dev/null +++ b/tests/SetAction.hs @@ -0,0 +1,81 @@ +module SetAction where + +import Test.Tasty.QuickCheck as QC + +import Data.Set (Set) +import qualified Data.Set as Set + +import Control.Applicative + +data SetAction a = AEmpty + | ASingleton a + | AFromList [a] + | AInsert a (SetAction a) + | ADelete a (SetAction a) + | AUnion (SetAction a) (SetAction a) + | ADifference (SetAction a) (SetAction a) + | AIntersection (SetAction a) (SetAction a) + deriving (Show) + +instance Arbitrary a => Arbitrary (SetAction a) where + arbitrary = sized arbitrary' + where arbitrary' n + | n <= 0 = oneof [pure AEmpty, ASingleton <$> arbitrary] + | otherwise = oneof [ pure AEmpty + , ASingleton <$> arbitrary + , AFromList <$> arbitrary + , AInsert <$> arbitrary <*> arbitrary1 + , ADelete <$> arbitrary <*> arbitrary1 + , AUnion <$> arbitrary2 <*> arbitrary2 + , ADifference <$> arbitrary2 <*> arbitrary2 + , AIntersection <$> arbitrary2 <*> arbitrary2 + ] + where arbitrary1 = arbitrary' $ n - 1 + arbitrary2 = arbitrary' $ n `div` 2 + +toSet :: (Ord a) => SetAction a -> Set a +toSet AEmpty = Set.empty +toSet (ASingleton a) = Set.singleton a +toSet (AFromList l) = Set.fromList l +toSet (AInsert a set) = Set.insert a $ toSet set +toSet (ADelete a set) = Set.delete a $ toSet set +toSet (AUnion a b) = Set.union (toSet a) (toSet b) +toSet (ADifference a b) = Set.difference (toSet a) (toSet b) +toSet (AIntersection a b) = Set.intersection (toSet a) (toSet b) + +data RSetAction a = RAEmpty + | RASingleton (a, a) + | RAFromList [(a, a)] + | RAInsert (a, a) (RSetAction a) + | RADelete (a, a) (RSetAction a) + | RAUnion (RSetAction a) (RSetAction a) + | RADifference (RSetAction a) (RSetAction a) + | RAIntersection (RSetAction a) (RSetAction a) + deriving (Show) + +instance Arbitrary a => Arbitrary (RSetAction a) where + arbitrary = sized arbitrary' + where arbitrary' n + | n <= 0 = oneof [pure RAEmpty, RASingleton <$> arbitrary] + | otherwise = oneof [ pure RAEmpty + , RASingleton <$> arbitrary + , RAFromList <$> arbitrary + , RAInsert <$> arbitrary <*> arbitrary1 + , RADelete <$> arbitrary <*> arbitrary1 + , RAUnion <$> arbitrary2 <*> arbitrary2 + , RADifference <$> arbitrary2 <*> arbitrary2 + , RAIntersection <$> arbitrary2 <*> arbitrary2 + ] + where arbitrary1 = arbitrary' $ n - 1 + arbitrary2 = arbitrary' $ n `div` 2 + +rangeToSet :: (Enum a, Ord a) => RSetAction a -> Set a +rangeToSet RAEmpty = Set.empty +rangeToSet (RASingleton a) = Set.fromList $ uncurry enumFromTo a +rangeToSet (RAFromList l) = Set.fromList $ concatMap (uncurry enumFromTo) l +rangeToSet (RAInsert a set) = foldr Set.insert (rangeToSet set) $ uncurry enumFromTo a +rangeToSet (RADelete a set) = foldr Set.delete (rangeToSet set) $ uncurry enumFromTo a +rangeToSet (RAUnion a b) = Set.union (rangeToSet a) (rangeToSet b) +rangeToSet (RADifference a b) = Set.difference (rangeToSet a) (rangeToSet b) +rangeToSet (RAIntersection a b) = Set.intersection (rangeToSet a) (rangeToSet b) + diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,197 +1,11 @@ import Test.Tasty -import Test.Tasty.QuickCheck as QC -import Data.Set (Set) -import qualified Data.Set as Set - -import Data.RangeSet.List (RSet) -import qualified Data.RangeSet.List as RSet - -import Control.Applicative -import Data.Int - -import Data.Semigroup +import IntMap +import List +import Map main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [qcProps] - -data SetAction a = AEmpty - | ASingleton a - | AFromList [a] - | AInsert a (SetAction a) - | ADelete a (SetAction a) - | AUnion (SetAction a) (SetAction a) - | ADifference (SetAction a) (SetAction a) - | AIntersection (SetAction a) (SetAction a) - deriving (Show) - -instance Arbitrary a => Arbitrary (SetAction a) where - arbitrary = sized arbitrary' - where arbitrary' n - | n <= 0 = oneof [pure AEmpty, ASingleton <$> arbitrary] - | otherwise = oneof [ pure AEmpty - , ASingleton <$> arbitrary - , AFromList <$> arbitrary - , AInsert <$> arbitrary <*> arbitrary1 - , ADelete <$> arbitrary <*> arbitrary1 - , AUnion <$> arbitrary2 <*> arbitrary2 - , ADifference <$> arbitrary2 <*> arbitrary2 - , AIntersection <$> arbitrary2 <*> arbitrary2 - ] - where arbitrary1 = arbitrary' $ n - 1 - arbitrary2 = arbitrary' $ n `div` 2 - -toSet :: (Ord a) => SetAction a -> Set a -toSet AEmpty = Set.empty -toSet (ASingleton a) = Set.singleton a -toSet (AFromList l) = Set.fromList l -toSet (AInsert a set) = Set.insert a $ toSet set -toSet (ADelete a set) = Set.delete a $ toSet set -toSet (AUnion a b) = Set.union (toSet a) (toSet b) -toSet (ADifference a b) = Set.difference (toSet a) (toSet b) -toSet (AIntersection a b) = Set.intersection (toSet a) (toSet b) - -toRSet :: (Enum a, Ord a) => SetAction a -> RSet a -toRSet AEmpty = RSet.empty -toRSet (ASingleton a) = RSet.singleton a -toRSet (AFromList l) = RSet.fromList l -toRSet (AInsert a set) = RSet.insert a $ toRSet set -toRSet (ADelete a set) = RSet.delete a $ toRSet set -toRSet (AUnion a b) = RSet.union (toRSet a) (toRSet b) -toRSet (ADifference a b) = RSet.difference (toRSet a) (toRSet b) -toRSet (AIntersection a b) = RSet.intersection (toRSet a) (toRSet b) - -elementsProp :: SetAction Int -> Property -elementsProp seta = Set.elems (toSet seta) === RSet.elems (toRSet seta) - -sizeProp :: SetAction Int -> Property -sizeProp seta = Set.size (toSet seta) === RSet.size (toRSet seta) - -nullProp :: SetAction Int -> Property -nullProp seta = Set.null (toSet seta) === RSet.null (toRSet seta) - -memberProp :: Int -> SetAction Int -> Property -memberProp x seta = Set.member x (toSet seta) === RSet.member x (toRSet seta) - -notMemberProp :: Int -> SetAction Int -> Property -notMemberProp x seta = Set.notMember x (toSet seta) === RSet.notMember x (toRSet seta) - -data RSetAction a = RAEmpty - | RASingleton (a, a) - | RAFromList [(a, a)] - | RAInsert (a, a) (RSetAction a) - | RADelete (a, a) (RSetAction a) - | RAUnion (RSetAction a) (RSetAction a) - | RADifference (RSetAction a) (RSetAction a) - | RAIntersection (RSetAction a) (RSetAction a) - deriving (Show) - -instance Arbitrary a => Arbitrary (RSetAction a) where - arbitrary = sized arbitrary' - where arbitrary' n - | n <= 0 = oneof [pure RAEmpty, RASingleton <$> arbitrary] - | otherwise = oneof [ pure RAEmpty - , RASingleton <$> arbitrary - , RAFromList <$> arbitrary - , RAInsert <$> arbitrary <*> arbitrary1 - , RADelete <$> arbitrary <*> arbitrary1 - , RAUnion <$> arbitrary2 <*> arbitrary2 - , RADifference <$> arbitrary2 <*> arbitrary2 - , RAIntersection <$> arbitrary2 <*> arbitrary2 - ] - where arbitrary1 = arbitrary' $ n - 1 - arbitrary2 = arbitrary' $ n `div` 2 - -rangeToSet :: (Enum a, Ord a) => RSetAction a -> Set a -rangeToSet RAEmpty = Set.empty -rangeToSet (RASingleton a) = Set.fromList $ uncurry enumFromTo a -rangeToSet (RAFromList l) = Set.fromList $ concatMap (uncurry enumFromTo) l -rangeToSet (RAInsert a set) = foldr Set.insert (rangeToSet set) $ uncurry enumFromTo a -rangeToSet (RADelete a set) = foldr Set.delete (rangeToSet set) $ uncurry enumFromTo a -rangeToSet (RAUnion a b) = Set.union (rangeToSet a) (rangeToSet b) -rangeToSet (RADifference a b) = Set.difference (rangeToSet a) (rangeToSet b) -rangeToSet (RAIntersection a b) = Set.intersection (rangeToSet a) (rangeToSet b) - -rangeToRSet :: (Enum a, Ord a) => RSetAction a -> RSet a -rangeToRSet RAEmpty = RSet.empty -rangeToRSet (RASingleton a) = RSet.singletonRange a -rangeToRSet (RAFromList l) = RSet.fromRangeList l -rangeToRSet (RAInsert a set) = RSet.insertRange a $ rangeToRSet set -rangeToRSet (RADelete a set) = RSet.deleteRange a $ rangeToRSet set -rangeToRSet (RAUnion a b) = RSet.union (rangeToRSet a) (rangeToRSet b) -rangeToRSet (RADifference a b) = RSet.difference (rangeToRSet a) (rangeToRSet b) -rangeToRSet (RAIntersection a b) = RSet.intersection (rangeToRSet a) (rangeToRSet b) - -rangeProp :: RSetAction Int8 -> Property -rangeProp seta = Set.elems (rangeToSet seta) === RSet.elems (rangeToRSet seta) - -ordered :: Ord a => [(a,a)] -> Bool -ordered rs = all lt $ zip rs (tail rs) - where - lt :: Ord a => ((a,a),(a,a)) -> Bool - lt ((_,y),(u,_)) = y < u - -pairOrdered :: Ord a => [(a, a)] -> Bool -pairOrdered = all (uncurry (<=)) - -orderedProp :: RSetAction Int8 -> Bool -orderedProp setAction = ordered rs && pairOrdered rs - where rs = RSet.toRangeList . rangeToRSet $ setAction - --- Complement laws -complementProps :: TestTree -complementProps = testGroup "complement" - [ QC.testProperty "definition" (\a e -> RSet.member e (rs a) === RSet.notMember e (RSet.complement (rs a))) - , QC.testProperty "involutive" (\a -> rs a === RSet.complement (RSet.complement (rs a))) - , QC.testProperty "(full \\\\)" (\a -> RSet.complement (rs a) === RSet.full RSet.\\ (rs a)) - ] - where rs = rangeToRSet :: RSetAction Int -> RSet Int - --- Min/Max laws - -findMinProp :: RSetAction Int8 -> Property -findMinProp seta - | Set.null s = label "trivial" $ property True - | otherwise = Set.findMin s === RSet.findMin rs - where s = rangeToSet seta - rs = rangeToRSet seta - -findMaxProp :: RSetAction Int8 -> Property -findMaxProp seta - | Set.null s = label "trivial" $ property True - | otherwise = Set.findMax s === RSet.findMax rs - where s = rangeToSet seta - rs = rangeToRSet seta - -minMaxProps :: TestTree -minMaxProps = testGroup "Min/Max properties" - [ QC.testProperty "findMin" findMinProp - , QC.testProperty "findMax" findMaxProp - ] - --- Monoid laws -monoidLaws :: TestTree -monoidLaws = testGroup "Monoid laws" - [ QC.testProperty "left identity" (\a -> rs a === mempty <> rs a) - , QC.testProperty "right identity" (\a -> rs a === rs a <> mempty) - , QC.testProperty "associativity" (\a b c -> rs a <> (rs b <> rs c) === (rs a <> rs b) <> rs c) - ] - where rs = rangeToRSet :: RSetAction Int -> RSet Int - --- All QuickCheck properties -qcProps :: TestTree -qcProps = testGroup "QuickCheck properties" - [ QC.testProperty "element operations are similar" elementsProp - , QC.testProperty "size is consistent" sizeProp - , QC.testProperty "null operation is similar" nullProp - , QC.testProperty "member operation is similar" memberProp - , QC.testProperty "notMember operation is similar" notMemberProp - , QC.testProperty "range operations is similar" rangeProp - , QC.testProperty "ranges remain is ordered" orderedProp - , complementProps - , minMaxProps - , monoidLaws - ] +tests = testGroup "Tests" [listProps, mapProps, intMapProps]