RangedSet.hs

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