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