Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /smlnj-lib/releases/release-110.61/Util/interval-set-fn.sml
ViewVC logotype

Annotation of /smlnj-lib/releases/release-110.61/Util/interval-set-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2253 - (view) (download)

1 : jhr 1840 (* interfun-set-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 2005 John Reppy (http://www.cs.uchicago.edu/~jhr)
4 :     * All rights reserved.
5 :     *
6 :     * An implementation of sets over a discrete ordered domain, where the
7 :     * sets are represented by intervals. It is meant for representing
8 :     * dense sets (e.g., unicode character classes).
9 :     *)
10 :    
11 :     functor IntervalSetFn (D : INTERVAL_DOMAIN) : INTERVAL_SET =
12 :     struct
13 :    
14 :     structure D = D
15 :    
16 :     type item = D.point
17 :     type interval = (D.point * D.point)
18 :    
19 :     fun min (a, b) = (case D.compare(a, b)
20 :     of LESS => a
21 :     | _ => b
22 :     (* end case *))
23 :    
24 :     (* the set is represented by an ordered list of disjoint, non-adjacent intervals *)
25 :     datatype set = SET of interval list
26 :    
27 :     val empty = SET[]
28 :     val universe = SET[(D.minPt, D.maxPt)]
29 :    
30 :     fun isEmpty (SET []) = true
31 :     | isEmpty _ = false
32 :    
33 :     fun isUniverse (SET[(a, b)]) =
34 :     (D.compare(a, D.minPt) = EQUAL) andalso (D.compare(b, D.maxPt) = EQUAL)
35 :     | isUniverse _ = false
36 :    
37 :     fun singleton x = SET[(x, x)]
38 :    
39 :     fun interval (a, b) = (case D.compare(a, b)
40 :     of GREATER => raise Domain
41 :     | _ => SET[(a, b)]
42 :     (* end case *))
43 :    
44 : jhr 1857 fun addInt (SET l, (a, b)) = let
45 : jhr 1840 fun ins (a, b, []) = [(a, b)]
46 :     | ins (a, b, (x, y)::r) = (case D.compare(b, x)
47 :     of LESS => if (D.isSucc(b, x))
48 :     then (a, y)::r
49 :     else (a, b)::(x, y)::r
50 :     | EQUAL => (a, y)::r
51 :     | GREATER => (case D.compare(a, y)
52 :     of GREATER => if (D.isSucc(y, a))
53 :     then (x, b) :: r
54 :     else (x, y) :: ins(a, b, r)
55 :     | EQUAL => ins(x, b, r)
56 :     | LESS => (case D.compare(b, y)
57 :     of GREATER => ins (min(a, x), b, r)
58 :     | _ => ins (min(a, x), y, r)
59 :     (* end case *))
60 :     (* end case *))
61 :     (* end case *))
62 :     in
63 :     case D.compare(a, b)
64 :     of GREATER => raise Domain
65 :     | _ => SET(ins (a, b, l))
66 :     (* end case *)
67 :     end
68 : jhr 1857 fun addInt' (x, m) = addInt (m, x)
69 : jhr 1840
70 :     fun add (SET l, a) = let
71 :     fun ins (a, []) = [(a, a)]
72 :     | ins (a, (x, y)::r) = (case D.compare(a, x)
73 :     of LESS => if (D.isSucc(a, x))
74 :     then (a, y)::r
75 :     else (a, a)::(x, y)::r
76 :     | EQUAL => (a, y)::r
77 :     | GREATER => (case D.compare(a, y)
78 :     of GREATER => if (D.isSucc(y, a))
79 :     then (x, a) :: r
80 :     else (x, y) :: ins(a, r)
81 :     | _ => (x, y)::r
82 :     (* end case *))
83 :     (* end case *))
84 :     in
85 :     SET(ins (a, l))
86 :     end
87 :     fun add' (x, m) = add (m, x)
88 :    
89 :     (* is a point in any of the intervals in the set *)
90 :     fun member (SET l, pt) = let
91 :     fun look [] = false
92 :     | look ((a, b) :: r) = (case D.compare(a, pt)
93 :     of LESS => (case D.compare(pt, b)
94 :     of GREATER => look r
95 :     | _ => true
96 :     (* end case *))
97 :     | EQUAL => true
98 :     | GREATER => false
99 :     (* end case *))
100 :     in
101 :     look l
102 :     end
103 :    
104 :     fun complement (SET[]) = universe
105 :     | complement (SET((a, b)::r)) = let
106 :     fun comp (start, (a, b)::r, l) =
107 :     comp(D.succ b, r, (start, D.pred a)::l)
108 :     | comp (start, [], l) = (case D.compare(start, D.maxPt)
109 :     of LESS => SET(List.rev((start, D.maxPt)::l))
110 :     | _ => SET(List.rev l)
111 :     (* end case *))
112 :     in
113 :     case D.compare(D.minPt, a)
114 :     of LESS => comp(D.succ b, r, [(D.minPt, D.pred a)])
115 :     | _ => comp(D.succ b, r, [])
116 :     (* end case *)
117 :     end
118 :    
119 :     fun union (SET l1, SET l2) = let
120 :     fun join ([], l2) = l2
121 :     | join (l1, []) = l1
122 :     | join ((a1, b1)::r1, (a2, b2)::r2) = (case D.compare(a1, a2)
123 :     of LESS => (case D.compare(b1, b2)
124 :     of LESS => if D.isSucc(b1, a2)
125 :     then join(r1, (a1, b2)::r2)
126 :     else (a1, b1) :: join(r1, (a2, b2)::r2)
127 :     | EQUAL => (a1, b1) :: join(r1, r2)
128 :     | GREATER => join ((a1, b1)::r1, r2)
129 :     (* end case *))
130 :     | EQUAL => (case D.compare(b1, b2)
131 :     of LESS => join(r1, (a2, b2)::r2)
132 :     | EQUAL => (a1, b1) :: join(r1, r2)
133 :     | GREATER => join ((a1, b1)::r1, r2)
134 :     (* end case *))
135 :     | GREATER => (case D.compare(a1, b2)
136 :     of LESS => (case D.compare(b1, b2)
137 :     of LESS => join (r1, (a2, b2)::r2)
138 :     | EQUAL => (a2, b2) :: join(r1, r2)
139 :     | GREATER => join ((a2, b1)::r1, r2)
140 :     (* end case *))
141 :     | EQUAL => (* a2 < a1 = b2 <= b1 *)
142 :     join ((a2, b1)::r1, r2)
143 :     | GREATER => if D.isSucc(b2, a1)
144 :     then join ((a2, b1)::r1, r2)
145 :     else (a2, b2) :: join ((a1, b1)::r1, r2)
146 :     (* end case *))
147 :     (* end case *))
148 :     in
149 :     SET(join(l1, l2))
150 :     end
151 :    
152 :     fun intersect (SET l1, SET l2) = let
153 :     (* cons a possibly empty interval onto the front of l *)
154 :     fun cons (a, b, l) = (case D.compare(a, b)
155 :     of GREATER => l
156 :     | _ => (a, b) :: l
157 :     (* end case *))
158 :     fun meet ([], _) = []
159 :     | meet (_, []) = []
160 :     | meet ((a1, b1)::r1, (a2, b2)::r2) = (case D.compare(a1, a2)
161 :     of LESS => (case D.compare(b1, a2)
162 :     of LESS => (* a1 <= b1 < a2 <= b2 *)
163 :     meet (r1, (a2, b2)::r2)
164 :     | EQUAL => (* a1 <= b1 = a2 <= b2 *)
165 :     (b1, b1) :: meet (r1, cons(D.succ b1, b2, r2))
166 :     | GREATER => (case D.compare (b1, b2)
167 :     of LESS => (* a1 < a2 < b1 < b2 *)
168 :     (a2, b1) :: meet (r1, cons(D.succ b1, b2, r2))
169 :     | EQUAL => (* a1 < a2 < b1 = b2 *)
170 :     (a2, b1) :: meet (r1, r2)
171 :     | GREATER => (* a1 < a2 < b1 & b2 < b1 *)
172 : jhr 1853 (a2, b2) :: meet (cons(D.succ b2, b1, r1), r2)
173 : jhr 1840 (* end case *))
174 :     (* end case *))
175 :     | EQUAL => (case D.compare(b1, b2)
176 :     of LESS => (a1, b1) :: meet (r1, cons(D.succ b1, b2, r2))
177 :     | EQUAL => (a1, b1) :: meet (r1, r2)
178 :     | GREATER => (a1, b2) :: meet ((D.succ b2, b1)::r1, r2)
179 :     (* end case *))
180 :     | GREATER => (case D.compare(b2, a1)
181 :     of LESS => (* a2 <= b2 < a1 <= b1 *)
182 :     meet ((a1, b1)::r1, r2)
183 :     | EQUAL => (* a2 < b2 = a1 <= b1 *)
184 :     (b2, b2) :: meet (cons(D.succ b2, b1, r1), r2)
185 :     | GREATER => (case D.compare(b1, b2)
186 :     of LESS => (* a2 < a1 <= b1 < b2 *)
187 :     (a1, b1) :: meet (r1, cons(D.succ b1, b2, r2))
188 :     | EQUAL => (* a2 < a1 <= b1 = b2 *)
189 :     (a1, b1) :: meet (r1, r2)
190 :     | GREATER => (* a2 < a1 < b2 < b1 *)
191 :     (a1, b2) :: meet (cons(D.succ b2, b1, r1), r2)
192 :     (* end case *))
193 :     (* end case *))
194 :     (* end case *))
195 :     in
196 :     SET(meet(l1, l2))
197 :     end
198 :    
199 :     (* FIXME: replace the following with a direct implementation *)
200 :     fun difference (s1, s2) = intersect(s1, complement s2)
201 :    
202 : jhr 1857 (***** iterators on elements *****)
203 :     local
204 :     fun next [] = NONE
205 :     | next ((a, b)::r) =
206 :     if D.compare(a, b) = EQUAL
207 :     then SOME(a, r)
208 :     else SOME(a, (D.succ a, b)::r)
209 :     in
210 :     fun items (SET l) = let
211 :     fun list (l, items) = (case next l
212 :     of NONE => List.rev items
213 :     | SOME(x, r) => list(r, x::items)
214 :     (* end case *))
215 :     in
216 :     list (l, [])
217 :     end
218 :     fun app f (SET l) = let
219 :     fun appf l = (case next l
220 :     of NONE => ()
221 :     | SOME(x, r) => (f x; appf r)
222 :     (* end case *))
223 :     in
224 :     appf l
225 :     end
226 :     fun foldl f = let
227 :     fun foldf (l, acc) = (case next l
228 :     of NONE => acc
229 :     | SOME(x, r) => foldf(r, f(x, acc))
230 :     (* end case *))
231 :     in
232 :     fn init => fn (SET l) => foldf(l, init)
233 :     end
234 :     fun foldr f init (SET l) = let
235 :     fun foldf l = (case next l
236 :     of NONE => init
237 :     | SOME(x, r) => f (x, foldf r)
238 :     (* end case *))
239 :     in
240 :     foldf l
241 :     end
242 :     fun filter pred (SET l) = let
243 :     (* given an interval [a, b], filter its elements and add the subintervals that pass
244 :     * the predicate to the list l.
245 :     *)
246 :     fun filterInt ((a, b), l) = let
247 :     fun lp (start, item, last, l) = let
248 :     val next = D.succ item
249 :     in
250 :     if pred next
251 :     then if (D.compare(next, last) = EQUAL)
252 :     then (start, next)::l
253 :     else lp(start, next, last, l)
254 :     else scan(D.succ next, last, (start, item)::l)
255 :     end
256 :     and scan (next, last, l) = if pred next
257 :     then lp (next, next, last, l)
258 :     else if (D.compare(next, last) = EQUAL)
259 :     then l
260 :     else scan(D.succ next, last, l)
261 :     in
262 :     scan (a, b, l)
263 :     end
264 :     (* filter the intervals *)
265 :     fun filter' ([], l) = SET(List.rev l)
266 :     | filter' (i::r, l) = filter' (r, filterInt (i, l))
267 :     in
268 :     filter' (l, [])
269 :     end
270 :     fun all pred (SET l) = let
271 :     fun all' l = (case next l
272 :     of NONE => true
273 :     | SOME(x, r) => (pred x andalso all' r)
274 :     (* end case *))
275 :     in
276 :     all' l
277 :     end
278 :     fun exists pred (SET l) = let
279 :     fun exists' l = (case next l
280 :     of NONE => false
281 :     | SOME(x, r) => (pred x orelse exists' r)
282 :     (* end case *))
283 :     in
284 :     exists' l
285 :     end
286 :     end (* local *)
287 : jhr 1840
288 : jhr 1857 (***** Iterators on interfuns *****)
289 :     fun intervals (SET l) = l
290 : jhr 1840
291 : jhr 1857 fun appInt f (SET l) = List.app f l
292 : jhr 1840
293 : jhr 1857 fun foldlInt f init (SET l) = List.foldl f init l
294 : jhr 1840
295 : jhr 1857 fun foldrInt f init (SET l) = List.foldl f init l
296 :    
297 :     fun filterInt pred (SET l) = let
298 : jhr 1840 fun f' ([], l) = SET(List.rev l)
299 :     | f' (i::r, l) = if pred i
300 :     then f'(r, i::l)
301 :     else f'(r, l)
302 :     in
303 :     f' (l, [])
304 :     end
305 :    
306 : jhr 1857 fun existsInt pred (SET l) = List.exists pred l
307 : jhr 1840
308 : jhr 1857 fun allInt pred (SET l) = List.all pred l
309 : jhr 1840
310 :     fun compare (SET l1, SET l2) = let
311 :     fun comp ([], []) = EQUAL
312 :     | comp ((a1, b1)::r1, (a2, b2)::r2) = (case D.compare(a1, a2)
313 :     of EQUAL => (case D.compare(b1, b2)
314 :     of EQUAL => comp (r1, r2)
315 :     | someOrder => someOrder
316 :     (* end case *))
317 :     | someOrder => someOrder
318 :     (* end case *))
319 :     | comp ([], _) = LESS
320 :     | comp (_, []) = GREATER
321 :     in
322 :     comp(l1, l2)
323 :     end
324 :    
325 :     fun isSubset (SET l1, SET l2) = let
326 :     (* is the interval [a, b] covered by [x, y]? *)
327 :     fun isCovered (a, b, x, y) = (case D.compare(a, x)
328 :     of LESS => false
329 :     | _ => (case D.compare(y, b)
330 :     of LESS => false
331 :     | _ => true
332 :     (* end case *))
333 :     (* end case *))
334 :     fun test ([], _) = true
335 :     | test (_, []) = false
336 :     | test ((a1, b1)::r1, (a2, b2)::r2) =
337 :     if isCovered (a1, b1, a2, b2)
338 :     then test (r1, (a2, b2)::r2)
339 :     else (case D.compare(b2, a1)
340 :     of LESS => test ((a1, b1)::r1, r2)
341 :     | _ => false
342 :     (* end case *))
343 :     in
344 :     test (l1, l2)
345 :     end
346 :    
347 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0