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