module Data.Ranged.RangedSet ( -- ** Ranged Set Type RSet, rSetRanges, -- ** Ranged Set construction functions and their Preconditions makeRangedSet, unsafeRangedSet, validRangeList, normaliseRangeList, rSingleton, -- ** Predicates rSetIsEmpty, (-?-), rSetHas, (-<=-), rSetIsSubset, (-<-), rSetIsSubsetStrict, -- ** Set Operations (-\/-), rSetUnion, (-/\-), rSetIntersection, (-!-), rSetDifference, rSetNegation, -- ** Useful Sets rSetEmpty, rSetFull, rSetUnfold -- ** QuickCheck Properties -- *** Construction -- $ConstructionProperties -- *** Basic Operations -- $BasicOperationProperties -- *** Some Identities and Inequalities -- $SomeIdentitiesAndInequalities ) where import Data.Ranged.Boundaries import Data.Ranged.Ranges import Data.Monoid import Data.List import Test.QuickCheck import Data.Typeable infixl 7 -/\- infixl 6 -\/-, -!- infixl 5 -<=-, -<-, -?- -- | An RSet (for Ranged Set) is a list of ranges. The ranges must be sorted -- and not overlap. newtype DiscreteOrdered v => RSet v = RSet {rSetRanges :: [Range v]} deriving (Eq, Show) instance DiscreteOrdered a => Monoid (RSet a) where mappend = rSetUnion mempty = rSetEmpty #include "Typeable.h" INSTANCE_TYPEABLE1(RSet,theTc,"Data.RangedSet") -- | Determine if the ranges in the list are both in order and non-overlapping. -- If so then they are suitable input for the unsafeRangedSet function. validRangeList :: DiscreteOrdered v => [Range v] -> Bool validRangeList [] = True validRangeList [Range lower upper] = lower <= upper validRangeList ranges = and $ zipWith okAdjacent ranges (tail ranges) where okAdjacent (Range lower1 upper1) (Range lower2 upper2) = lower1 <= upper1 && upper1 <= lower2 && lower2 <= upper2 -- | Rearrange and merge the ranges in the list so that they are in order and -- non-overlapping. normaliseRangeList :: DiscreteOrdered v => [Range v] -> [Range v] normaliseRangeList ranges = normalise $ sort $ filter (not . rangeIsEmpty) ranges -- Private routine: normalise a range list that is known to be already sorted. -- This precondition is not checked. normalise :: DiscreteOrdered v => [Range v] -> [Range v] normalise (r1:r2:rs) = if overlap r1 r2 then normalise $ Range (rangeLower r1) (max (rangeUpper r1) (rangeUpper r2)) : rs else r1 : (normalise $ r2 : rs) where overlap (Range _ upper1) (Range lower2 _) = upper1 >= lower2 normalise rs = rs -- | Create a new Ranged Set from a list of ranges. The list may contain -- ranges that overlap or are not in ascending order. makeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v makeRangedSet = RSet . normaliseRangeList -- | Create a new Ranged Set from a list of ranges. @validRangeList ranges@ -- must return @True@. This precondition is not checked. unsafeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v unsafeRangedSet = RSet -- | Create a Ranged Set from a single element. rSingleton :: DiscreteOrdered v => v -> RSet v rSingleton v = unsafeRangedSet [singletonRange v] -- | True if the set has no members. rSetIsEmpty :: DiscreteOrdered v => RSet v -> Bool rSetIsEmpty = null . rSetRanges -- | True if the negation of the set has no members. rSetIsFull :: DiscreteOrdered v => RSet v -> Bool rSetIsFull = rSetIsEmpty . rSetNegation -- | True if the value is within the ranged set. Infix precedence is left 5. rSetHas, (-?-) :: DiscreteOrdered v => RSet v -> v -> Bool rSetHas (RSet ls) value = rSetHas1 ls where rSetHas1 [] = False rSetHas1 (r:rs) | value />/ rangeLower r = rangeHas r value || rSetHas1 rs | otherwise = False (-?-) = rSetHas -- | True if the first argument is a subset of the second argument, or is -- equal. -- -- Infix precedence is left 5. rSetIsSubset, (-<=-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool rSetIsSubset rs1 rs2 = rSetIsEmpty (rs1 -!- rs2) (-<=-) = rSetIsSubset -- | True if the first argument is a strict subset of the second argument. -- -- Infix precedence is left 5. rSetIsSubsetStrict, (-<-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool rSetIsSubsetStrict rs1 rs2 = rSetIsEmpty (rs1 -!- rs2) && not (rSetIsEmpty (rs2 -!- rs1)) (-<-) = rSetIsSubsetStrict -- | Set union for ranged sets. Infix precedence is left 6. rSetUnion, (-\/-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v -- Implementation note: rSetUnion merges the two lists into a single -- sorted list and then calls normalise to combine overlapping ranges. rSetUnion (RSet ls1) (RSet ls2) = RSet $ normalise $ merge ls1 ls2 where merge ls1 [] = ls1 merge [] ls2 = ls2 merge ls1@(h1:t1) ls2@(h2:t2) = if h1 < h2 then h1 : merge t1 ls2 else h2 : merge ls1 t2 (-\/-) = rSetUnion -- | Set intersection for ranged sets. Infix precedence is left 7. rSetIntersection, (-/\-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v rSetIntersection (RSet ls1) (RSet ls2) = RSet $ filter (not . rangeIsEmpty) $ merge ls1 ls2 where merge ls1@(h1:t1) ls2@(h2:t2) = rangeIntersection h1 h2 : if rangeUpper h1 < rangeUpper h2 then merge t1 ls2 else merge ls1 t2 merge _ _ = [] (-/\-) = rSetIntersection -- | Set difference. Infix precedence is left 6. rSetDifference, (-!-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v rSetDifference rs1 rs2 = rs1 -/\- (rSetNegation rs2) (-!-) = rSetDifference -- | Set negation. rSetNegation :: DiscreteOrdered a => RSet a -> RSet a rSetNegation set = RSet $ ranges $ setBounds1 where ranges (b1:b2:bs) = Range b1 b2 : ranges bs ranges [BoundaryAboveAll] = [] ranges [b] = [Range b BoundaryAboveAll] ranges _ = [] setBounds1 = case setBounds of (BoundaryBelowAll : bs) -> bs _ -> BoundaryBelowAll : setBounds setBounds = bounds $ rSetRanges set bounds (r:rs) = rangeLower r : rangeUpper r : bounds rs bounds _ = [] -- | The empty set. rSetEmpty :: DiscreteOrdered a => RSet a rSetEmpty = RSet [] -- | The set that contains everything. rSetFull :: DiscreteOrdered a => RSet a rSetFull = RSet [Range BoundaryBelowAll BoundaryAboveAll] -- | Construct a range set. rSetUnfold :: DiscreteOrdered a => Boundary a -- ^ A first lower boundary. -> (Boundary a -> Boundary a) -- ^ A function from a lower boundary to an upper boundary, which must -- return a result greater than the argument (not checked). -> (Boundary a -> Maybe (Boundary a)) -- ^ A function from a lower boundary to @Maybe@ the successor lower -- boundary, which must return a result greater than the argument -- (not checked). -> RSet a rSetUnfold bound upperFunc succFunc = RSet $ normalise $ ranges bound where ranges b = Range b (upperFunc bound) : case succFunc b of Just b2 -> ranges b2 Nothing -> [] -- QuickCheck Generators instance (Arbitrary v, DiscreteOrdered v, Show v) => Arbitrary (RSet v) where arbitrary = frequency [ (1, return rSetEmpty), (1, return rSetFull), (18, do ls <- arbitrary return $ makeRangedSet $ rangeList $ sort ls )] where -- Arbitrary lists of ranges don't give many interesting sets after -- normalisation. So instead generate a sorted list of boundaries -- and pair them off. Odd boundaries are dropped. rangeList (b1:b2:bs) = Range b1 b2 : rangeList bs rangeList _ = [] coarbitrary (RSet ls) = variant 0 . coarbitrary ls -- ================================================================== -- QuickCheck Properties -- ================================================================== -- Note for maintenance: Haddock does not include QuickCheck properties, -- so they have to be copied into documentation blocks manually. This -- process must be repeated for new or modified properties. --------------------------------------------------------------------- -- Construction properties --------------------------------------------------------------------- {- $ConstructionProperties A normalised range list is valid for unsafeRangedSet > prop_validNormalised ls = validRangeList $ normaliseRangeList ls > where types = ls :: [Range Double] Iff a value is in a range list then it is in a ranged set constructed from that list. > prop_has ls v = (ls `rangeListHas` v) == rangedSet ls -?- v -} -- A normalised range list is valid for unsafeRangedSet prop_validNormalised ls = validRangeList $ normaliseRangeList ls where types = ls :: [Range Integer] -- Iff a value is in a range list then it is in a ranged set -- constructed from that list. prop_has ls v = (ls `rangeListHas` v) == makeRangedSet ls -?- v where types = v :: Integer --------------------------------------------------------------------- -- Basic operation properties --------------------------------------------------------------------- {- $BasicOperationProperties Iff a value is in either of two ranged sets then it is in the union of those two sets. > prop_union rs1 rs2 v = > (rs1 -?- v || rs2 -?- v) == ((rs1 -\/- rs2) -?- v) Iff a value is in both of two ranged sets then it is in the intersection of those two sets. > prop_intersection rs1 rs2 v = > (rs1 -?- v && rs2 -?- v) == ((rs1 -/\- rs2) -?- v) Iff a value is in ranged set 1 and not in ranged set 2 then it is in the difference of the two. > prop_difference rs1 rs2 v = > (rs1 -?- v && not (rs2 -?- v)) == ((rs1 -!- rs2) -?- v) Iff a value is not in a ranged set then it is in its negation. > prop_negation rs v = rs -?- v == not (rSetNegation rs -?- v) A set that contains a value is not empty > prop_not_empty rs v = (rs -?- v) ==> not (rSetIsEmpty rs) -} -- Iff a value is in either of two ranged sets then it is in the union of -- those two sets. prop_union rs1 rs2 v = (rs1 -?- v || rs2 -?- v) == ((rs1 -\/- rs2) -?- v) where types = v :: Integer -- Iff a value is in both of two ranged sets then it is in the intersection -- of those two sets. prop_intersection rs1 rs2 v = (rs1 -?- v && rs2 -?- v) == ((rs1 `rSetIntersection` rs2) -?- v) where types = v :: Integer -- Iff a value is in ranged set 1 and not in ranged set 2 then it is in the -- difference of the two. prop_difference rs1 rs2 v = (rs1 -?- v && not (rs2 -?- v)) == ((rs1 -!- rs2) -?- v) where types = v :: Integer -- Iff a value is not in a ranged set then it is in its negation. prop_negation rs v = rs -?- v == not (rSetNegation rs -?- v) where types = v :: Integer -- A set that contains a value is not empty prop_not_empty rs v = (rs -?- v) ==> not (rSetIsEmpty rs) where types = v :: Integer --------------------------------------------------------------------- -- Some identities and inequalities of sets --------------------------------------------------------------------- {- $SomeIdentitiesAndInequalities The empty set has no members. > prop_empty v = not (rSetEmpty -?- v) The full set has every member. > prop_full v = rSetFull -?- v The intersection of a set with its negation is empty. > prop_empty_intersection rs = > rSetIsEmpty (rs -/\- rSetNegation rs) The union of a set with its negation is full. > prop_full_union rs v = > rSetIsFull (rs -\/- rSetNegation rs) The union of two sets is the non-strict superset of both. > prop_union_superset rs1 rs2 = > rs1 -<=- u && rs2 -<=- u > where > u = rs1 -\/- rs2 The intersection of two sets is the non-strict subset of both. > prop_intersection_subset rs1 rs2 = > i -<=- rs1 && i -<=- rs2 > where > i = rs1 -/\- rs2 The difference of two sets intersected with the subtractand is empty. > prop_diff_intersect rs1 rs2 = > rSetIsEmpty ((rs1 -!- rs2) -/\- rs2) A set is the non-strict subset of itself. > prop_subset rs = rs -<=- rs A set is not the strict subset of itself. > prop_strict_subset rs = not (rs -<- rs) If rs1 - rs2 is not empty then the union of rs1 and rs2 will be a strict superset of rs2. > prop_union_strict_superset rs1 rs2 = > (not $ rSetIsEmpty (rs1 -!- rs2)) > ==> (rs2 -<- (rs1 -\/- rs2)) Intersection commutes > prop_intersection_commutes rs1 rs2 = > (rs1 -/\- rs2) == (rs2 -/\- rs1) Union commutes > prop_union_commutes rs1 rs2 = > (rs1 -\/- rs2) == (rs2 -\/- rs1) Intersection associates > prop_intersection_associates rs1 rs2 rs3 = > ((rs1 -/\- rs2) -/\- rs3) == (rs1 -/\- (rs2 -/\- rs3)) Union associates > prop_union_associates rs1 rs2 rs3 = > ((rs1 -\/- rs2) -\/- rs3) == (rs1 -\/- (rs2 -\/- rs3)) De Morgan's Law for Intersection > prop_de_morgan_intersection rs1 rs2 = > rSetNegation (rs1 -/\- rs2) == (rSetNegation rs1 -\/- rSetNegation rs2) De Morgan's Law for Union > prop_de_morgan_union rs1 rs2 = > rSetNegation (rs1 -\/- rs2) == (rSetNegation rs1 -/\- rSetNegation rs2) -} -- The empty set has no members. prop_empty v = not (rSetEmpty -?- v) where types = v :: Integer -- The full set has every member. prop_full v = rSetFull -?- v where types = v :: Integer -- The intersection of a set with its negation is empty. prop_empty_intersection rs = rSetIsEmpty (rs -/\- rSetNegation rs) where types = rs :: RSet Integer -- The union of a set with its negation is full. prop_full_union rs = rSetIsFull (rs -\/- rSetNegation rs) where types = rs :: RSet Integer -- The union of two sets is the non-strict superset of both. prop_union_superset rs1 rs2 = rs1 -<=- u && rs2 -<=- u where u :: RSet Integer u = rs1 -\/- rs2 -- The intersection of two sets is the non-strict subset of both. prop_intersection_subset rs1 rs2 = i -<=- rs1 && i -<=- rs2 where i :: RSet Integer i = rs1 -/\- rs2 -- The difference of two sets intersected with the subtractand is empty. prop_diff_intersect rs1 rs2 = rSetIsEmpty ((rs1 -!- rs2) -/\- rs2) where types = rs1 :: RSet Integer -- A set is the non-strict subset of itself. prop_subset rs = rs -<=- rs where types = rs :: RSet Integer -- A set is not the strict subset of itself. prop_strict_subset rs = not (rs -<- rs) where types = rs :: RSet Integer -- If rs1 - rs2 is not empty then the union of rs1 and rs2 will be a strict -- superset of rs2. prop_union_strict_superset rs1 rs2 = (not $ rSetIsEmpty (rs1 -!- rs2)) ==> (rs2 -<- (rs1 -\/- rs2)) where types = rs1 :: RSet Integer -- Intersection commutes prop_intersection_commutes :: RSet Integer -> RSet Integer -> Bool prop_intersection_commutes rs1 rs2 = (rs1 -/\- rs2) == (rs2 -/\- rs1) where types = rs1 :: RSet Integer -- Union commutes prop_union_commutes rs1 rs2 = (rs1 -\/- rs2) == (rs2 -\/- rs1) where types = rs1 :: RSet Integer -- Intersection associates prop_intersection_associates rs1 rs2 rs3 = ((rs1 -/\- rs2) -/\- rs3) == (rs1 -/\- (rs2 -/\- rs3)) where types = rs1 :: RSet Integer -- Union associates prop_union_associates rs1 rs2 rs3 = ((rs1 -\/- rs2) -\/- rs3) == (rs1 -\/- (rs2 -\/- rs3)) where types = rs1 :: RSet Integer -- De Morgan's Law for Intersection prop_de_morgan_intersection rs1 rs2 = rSetNegation (rs1 -/\- rs2) == (rSetNegation rs1 -\/- rSetNegation rs2) where types = rs1 :: RSet Integer -- De Morgan's Law for Union prop_de_morgan_union rs1 rs2 = rSetNegation (rs1 -\/- rs2) == (rSetNegation rs1 -/\- rSetNegation rs2) where types = rs1 :: RSet Integer