1module Data.Ranged.RangedSet ( 2 -- ** Ranged Set Type 3 RSet, 4 rSetRanges, 5 -- ** Ranged Set construction functions and their preconditions 6 makeRangedSet, 7 unsafeRangedSet, 8 validRangeList, 9 normaliseRangeList, 10 rSingleton, 11 rSetUnfold, 12 -- ** Predicates 13 rSetIsEmpty, 14 rSetIsFull, 15 (-?-), rSetHas, 16 (-<=-), rSetIsSubset, 17 (-<-), rSetIsSubsetStrict, 18 -- ** Set Operations 19 (-\/-), rSetUnion, 20 (-/\-), rSetIntersection, 21 (-!-), rSetDifference, 22 rSetNegation, 23 -- ** Useful Sets 24 rSetEmpty, 25 rSetFull, 26) where 27 28import Data.Ranged.Boundaries 29import Data.Ranged.Ranges 30#if __GLASGOW_HASKELL__ >= 800 31import Data.Semigroup 32#elif __GLASGOW_HASKELL__ < 710 33import Data.Monoid 34#endif 35 36import Data.List 37 38infixl 7 -/\- 39infixl 6 -\/-, -!- 40infixl 5 -<=-, -<-, -?- 41 42-- | An RSet (for Ranged Set) is a list of ranges. The ranges must be sorted 43-- and not overlap. 44newtype DiscreteOrdered v => RSet v = RSet {rSetRanges :: [Range v]} 45 deriving (Eq, Show, Ord) 46 47#if __GLASGOW_HASKELL__ >= 800 48instance DiscreteOrdered a => Semigroup (RSet a) where 49 (<>) = rSetUnion 50 51instance DiscreteOrdered a => Monoid (RSet a) where 52 mappend = (<>) 53 mempty = rSetEmpty 54#else 55instance DiscreteOrdered a => Monoid (RSet a) where 56 mappend = rSetUnion 57 mempty = rSetEmpty 58#endif 59 60-- | Determine if the ranges in the list are both in order and non-overlapping. 61-- If so then they are suitable input for the unsafeRangedSet function. 62validRangeList :: DiscreteOrdered v => [Range v] -> Bool 63 64validRangeList [] = True 65validRangeList [Range lower upper] = lower <= upper 66validRangeList rs = and $ zipWith okAdjacent rs (tail rs) 67 where 68 okAdjacent (Range lower1 upper1) (Range lower2 upper2) = 69 lower1 <= upper1 && upper1 <= lower2 && lower2 <= upper2 70 71 72-- | Rearrange and merge the ranges in the list so that they are in order and 73-- non-overlapping. 74normaliseRangeList :: DiscreteOrdered v => [Range v] -> [Range v] 75normaliseRangeList = normalise . sort . filter (not . rangeIsEmpty) 76 77 78-- Private routine: normalise a range list that is known to be already sorted. 79-- This precondition is not checked. 80normalise :: DiscreteOrdered v => [Range v] -> [Range v] 81normalise (r1:r2:rs) = 82 if overlap r1 r2 83 then normalise $ 84 Range (rangeLower r1) 85 (max (rangeUpper r1) (rangeUpper r2)) 86 : rs 87 else r1 : (normalise $ r2 : rs) 88 where 89 overlap (Range _ upper1) (Range lower2 _) = upper1 >= lower2 90 91normalise rs = rs 92 93 94-- | Create a new Ranged Set from a list of ranges. The list may contain 95-- ranges that overlap or are not in ascending order. 96makeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v 97makeRangedSet = RSet . normaliseRangeList 98 99 100-- | Create a new Ranged Set from a list of ranges. @validRangeList ranges@ 101-- must return @True@. This precondition is not checked. 102unsafeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v 103unsafeRangedSet = RSet 104 105-- | Create a Ranged Set from a single element. 106rSingleton :: DiscreteOrdered v => v -> RSet v 107rSingleton v = unsafeRangedSet [singletonRange v] 108 109-- | True if the set has no members. 110rSetIsEmpty :: DiscreteOrdered v => RSet v -> Bool 111rSetIsEmpty = null . rSetRanges 112 113 114-- | True if the negation of the set has no members. 115rSetIsFull :: DiscreteOrdered v => RSet v -> Bool 116rSetIsFull = rSetIsEmpty . rSetNegation 117 118 119-- | True if the value is within the ranged set. Infix precedence is left 5. 120rSetHas, (-?-) :: DiscreteOrdered v => RSet v -> v -> Bool 121rSetHas (RSet ls) value = rSetHas1 ls 122 where 123 rSetHas1 [] = False 124 rSetHas1 (r:rs) 125 | value />/ rangeLower r = rangeHas r value || rSetHas1 rs 126 | otherwise = False 127 128(-?-) = rSetHas 129 130-- | True if the first argument is a subset of the second argument, or is 131-- equal. 132-- 133-- Infix precedence is left 5. 134rSetIsSubset, (-<=-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool 135rSetIsSubset rs1 rs2 = rSetIsEmpty (rs1 -!- rs2) 136(-<=-) = rSetIsSubset 137 138 139-- | True if the first argument is a strict subset of the second argument. 140-- 141-- Infix precedence is left 5. 142rSetIsSubsetStrict, (-<-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool 143rSetIsSubsetStrict rs1 rs2 = 144 rSetIsEmpty (rs1 -!- rs2) 145 && not (rSetIsEmpty (rs2 -!- rs1)) 146 147(-<-) = rSetIsSubsetStrict 148 149-- | Set union for ranged sets. Infix precedence is left 6. 150rSetUnion, (-\/-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v 151-- Implementation note: rSetUnion merges the two lists into a single 152-- sorted list and then calls normalise to combine overlapping ranges. 153rSetUnion (RSet ls1) (RSet ls2) = RSet $ normalise $ merge ls1 ls2 154 where 155 merge ms1 [] = ms1 156 merge [] ms2 = ms2 157 merge ms1@(h1:t1) ms2@(h2:t2) = 158 if h1 < h2 159 then h1 : merge t1 ms2 160 else h2 : merge ms1 t2 161 162(-\/-) = rSetUnion 163 164-- | Set intersection for ranged sets. Infix precedence is left 7. 165rSetIntersection, (-/\-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v 166rSetIntersection (RSet ls1) (RSet ls2) = 167 RSet $ filter (not . rangeIsEmpty) $ merge ls1 ls2 168 where 169 merge ms1@(h1:t1) ms2@(h2:t2) = 170 rangeIntersection h1 h2 171 : if rangeUpper h1 < rangeUpper h2 172 then merge t1 ms2 173 else merge ms1 t2 174 merge _ _ = [] 175 176(-/\-) = rSetIntersection 177 178 179-- | Set difference. Infix precedence is left 6. 180rSetDifference, (-!-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v 181rSetDifference rs1 rs2 = rs1 -/\- (rSetNegation rs2) 182(-!-) = rSetDifference 183 184 185-- | Set negation. 186rSetNegation :: DiscreteOrdered a => RSet a -> RSet a 187rSetNegation set = RSet $ ranges1 $ setBounds1 188 where 189 ranges1 (b1:b2:bs) = Range b1 b2 : ranges1 bs 190 ranges1 [BoundaryAboveAll] = [] 191 ranges1 [b] = [Range b BoundaryAboveAll] 192 ranges1 _ = [] 193 setBounds1 = case setBounds of 194 (BoundaryBelowAll : bs) -> bs 195 _ -> BoundaryBelowAll : setBounds 196 setBounds = bounds $ rSetRanges set 197 bounds (r:rs) = rangeLower r : rangeUpper r : bounds rs 198 bounds _ = [] 199 200-- | The empty set. 201rSetEmpty :: DiscreteOrdered a => RSet a 202rSetEmpty = RSet [] 203 204-- | The set that contains everything. 205rSetFull :: DiscreteOrdered a => RSet a 206rSetFull = RSet [Range BoundaryBelowAll BoundaryAboveAll] 207 208-- | Construct a range set. 209rSetUnfold :: DiscreteOrdered a => 210 Boundary a 211 -- ^ A first lower boundary. 212 -> (Boundary a -> Boundary a) 213 -- ^ A function from a lower boundary to an upper boundary, which must 214 -- return a result greater than the argument (not checked). 215 -> (Boundary a -> Maybe (Boundary a)) 216 -- ^ A function from a lower boundary to @Maybe@ the successor lower 217 -- boundary, which must return a result greater than the argument 218 -- (not checked). If ranges overlap then they will be merged. 219 -> RSet a 220rSetUnfold bound upperFunc succFunc = RSet $ normalise $ ranges1 bound 221 where 222 ranges1 b = 223 Range b (upperFunc b) 224 : case succFunc b of 225 Just b2 -> ranges1 b2 226 Nothing -> [] 227