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 /sml/trunk/src/smlnj-lib/Util/redblack-set-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/smlnj-lib/Util/redblack-set-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 816 - (view) (download)

1 : monnier 467 (* redblack-set-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies.
4 :     *
5 :     * This code is based on Chris Okasaki's implementation of
6 :     * red-black trees. The linear-time tree construction code is
7 :     * based on the paper "Constructing red-black trees" by Hinze,
8 :     * and the delete function is based on the description in Cormen,
9 :     * Leiserson, and Rivest.
10 :     *
11 :     * A red-black tree should satisfy the following two invariants:
12 :     *
13 :     * Red Invariant: each red node has a black parent.
14 :     *
15 :     * Black Condition: each path from the root to an empty node has the
16 :     * same number of black nodes (the tree's black height).
17 :     *
18 :     * The Red condition implies that the root is always black and the Black
19 :     * condition implies that any node with only one child will be black and
20 :     * its child will be a red leaf.
21 :     *)
22 :    
23 :     functor RedBlackSetFn (K : ORD_KEY) :> ORD_SET where Key = K =
24 :     struct
25 :    
26 :     structure Key = K
27 :    
28 :     type item = K.ord_key
29 :    
30 :     datatype color = R | B
31 :    
32 :     datatype tree
33 :     = E
34 :     | T of (color * tree * item * tree)
35 :    
36 :     datatype set = SET of (int * tree)
37 :    
38 :     fun isEmpty (SET(_, E)) = true
39 :     | isEmpty _ = false
40 :    
41 :     val empty = SET(0, E)
42 :    
43 :     fun singleton x = SET(1, T(R, E, x, E))
44 :    
45 :     fun add (SET(nItems, m), x) = let
46 :     val nItems' = ref nItems
47 :     fun ins E = (nItems' := nItems+1; T(R, E, x, E))
48 :     | ins (s as T(color, a, y, b)) = (case K.compare(x, y)
49 :     of LESS => (case a
50 :     of T(R, c, z, d) => (case K.compare(x, z)
51 :     of LESS => (case ins c
52 :     of T(R, e, w, f) =>
53 :     T(R, T(B,e,w,f), z, T(B,d,y,b))
54 :     | c => T(B, T(R,c,z,d), y, b)
55 :     (* end case *))
56 :     | EQUAL => T(color, T(R, c, x, d), y, b)
57 :     | GREATER => (case ins d
58 :     of T(R, e, w, f) =>
59 :     T(R, T(B,c,z,e), w, T(B,f,y,b))
60 :     | d => T(B, T(R,c,z,d), y, b)
61 :     (* end case *))
62 :     (* end case *))
63 :     | _ => T(B, ins a, y, b)
64 :     (* end case *))
65 :     | EQUAL => T(color, a, x, b)
66 :     | GREATER => (case b
67 :     of T(R, c, z, d) => (case K.compare(x, z)
68 :     of LESS => (case ins c
69 :     of T(R, e, w, f) =>
70 :     T(R, T(B,a,y,e), w, T(B,f,z,d))
71 :     | c => T(B, a, y, T(R,c,z,d))
72 :     (* end case *))
73 :     | EQUAL => T(color, a, y, T(R, c, x, d))
74 :     | GREATER => (case ins d
75 :     of T(R, e, w, f) =>
76 :     T(R, T(B,a,y,c), z, T(B,e,w,f))
77 :     | d => T(B, a, y, T(R,c,z,d))
78 :     (* end case *))
79 :     (* end case *))
80 :     | _ => T(B, a, y, ins b)
81 :     (* end case *))
82 :     (* end case *))
83 :     val m = ins m
84 :     in
85 :     SET(!nItems', m)
86 :     end
87 :     fun add' (x, m) = add (m, x)
88 :    
89 :     fun addList (s, []) = s
90 :     | addList (s, x::r) = addList(add(s, x), r)
91 :    
92 :     (* Remove an item. Raises LibBase.NotFound if not found. *)
93 :     local
94 :     datatype zipper
95 :     = TOP
96 :     | LEFT of (color * item * tree * zipper)
97 :     | RIGHT of (color * tree * item * zipper)
98 :     in
99 :     fun delete (SET(nItems, t), k) = let
100 :     fun zip (TOP, t) = t
101 :     | zip (LEFT(color, x, b, z), a) = zip(z, T(color, a, x, b))
102 :     | zip (RIGHT(color, a, x, z), b) = zip(z, T(color, a, x, b))
103 :     (* bbZip propagates a black deficit up the tree until either the top
104 :     * is reached, or the deficit can be covered. It returns a boolean
105 :     * that is true if there is still a deficit and the zipped tree.
106 :     *)
107 :     fun bbZip (TOP, t) = (true, t)
108 :     | bbZip (LEFT(B, x, T(R, c, y, d), z), a) = (* case 1L *)
109 :     bbZip (LEFT(R, x, c, LEFT(B, y, d, z)), a)
110 :     | bbZip (LEFT(color, x, T(B, T(R, c, y, d), w, e), z), a) = (* case 3L *)
111 :     bbZip (LEFT(color, x, T(B, c, y, T(R, d, w, e)), z), a)
112 :     | bbZip (LEFT(color, x, T(B, c, y, T(R, d, w, e)), z), a) = (* case 4L *)
113 :     (false, zip (z, T(color, T(B, a, x, c), y, T(B, d, w, e))))
114 :     | bbZip (LEFT(R, x, T(B, c, y, d), z), a) = (* case 2L *)
115 :     (false, zip (z, T(B, a, x, T(R, c, y, d))))
116 :     | bbZip (LEFT(B, x, T(B, c, y, d), z), a) = (* case 2L *)
117 :     bbZip (z, T(B, a, x, T(R, c, y, d)))
118 :     | bbZip (RIGHT(color, T(R, c, y, d), x, z), b) = (* case 1R *)
119 :     bbZip (RIGHT(R, d, x, RIGHT(B, c, y, z)), b)
120 :     | bbZip (RIGHT(color, T(B, T(R, c, w, d), y, e), x, z), b) = (* case 3R *)
121 :     bbZip (RIGHT(color, T(B, c, w, T(R, d, y, e)), x, z), b)
122 :     | bbZip (RIGHT(color, T(B, c, y, T(R, d, w, e)), x, z), b) = (* case 4R *)
123 :     (false, zip (z, T(color, c, y, T(B, T(R, d, w, e), x, b))))
124 :     | bbZip (RIGHT(R, T(B, c, y, d), x, z), b) = (* case 2R *)
125 :     (false, zip (z, T(B, T(R, c, y, d), x, b)))
126 :     | bbZip (RIGHT(B, T(B, c, y, d), x, z), b) = (* case 2R *)
127 :     bbZip (z, T(B, T(R, c, y, d), x, b))
128 :     | bbZip (z, t) = (false, zip(z, t))
129 :     fun delMin (T(R, E, y, b), z) = (y, (false, zip(z, b)))
130 :     | delMin (T(B, E, y, b), z) = (y, bbZip(z, b))
131 :     | delMin (T(color, a, y, b), z) = delMin(a, LEFT(color, y, b, z))
132 : monnier 498 | delMin (E, _) = raise Match
133 : monnier 467 fun join (R, E, E, z) = zip(z, E)
134 :     | join (_, a, E, z) = #2(bbZip(z, a)) (* color = black *)
135 :     | join (_, E, b, z) = #2(bbZip(z, b)) (* color = black *)
136 :     | join (color, a, b, z) = let
137 :     val (x, (needB, b')) = delMin(b, TOP)
138 :     in
139 :     if needB
140 :     then #2(bbZip(z, T(color, a, x, b')))
141 :     else zip(z, T(color, a, x, b'))
142 :     end
143 :     fun del (E, z) = raise LibBase.NotFound
144 :     | del (T(color, a, y, b), z) = (case K.compare(k, y)
145 :     of LESS => del (a, LEFT(color, y, b, z))
146 :     | EQUAL => join (color, a, b, z)
147 :     | GREATER => del (b, RIGHT(color, a, y, z))
148 :     (* end case *))
149 :     in
150 :     SET(nItems-1, del(t, TOP))
151 :     end
152 :     end (* local *)
153 :    
154 :     (* Return true if and only if item is an element in the set *)
155 :     fun member (SET(_, t), k) = let
156 :     fun find' E = false
157 :     | find' (T(_, a, y, b)) = (case K.compare(k, y)
158 :     of LESS => find' a
159 :     | EQUAL => true
160 :     | GREATER => find' b
161 :     (* end case *))
162 :     in
163 :     find' t
164 :     end
165 :    
166 :     (* Return the number of items in the map *)
167 :     fun numItems (SET(n, _)) = n
168 :    
169 :     fun foldl f = let
170 :     fun foldf (E, accum) = accum
171 :     | foldf (T(_, a, x, b), accum) =
172 :     foldf(b, f(x, foldf(a, accum)))
173 :     in
174 :     fn init => fn (SET(_, m)) => foldf(m, init)
175 :     end
176 :    
177 :     fun foldr f = let
178 :     fun foldf (E, accum) = accum
179 :     | foldf (T(_, a, x, b), accum) =
180 :     foldf(a, f(x, foldf(b, accum)))
181 :     in
182 :     fn init => fn (SET(_, m)) => foldf(m, init)
183 :     end
184 :    
185 :     (* return an ordered list of the items in the set. *)
186 :     fun listItems s = foldr (fn (x, l) => x::l) [] s
187 :    
188 :     (* functions for walking the tree while keeping a stack of parents
189 :     * to be visited.
190 :     *)
191 :     fun next ((t as T(_, _, _, b))::rest) = (t, left(b, rest))
192 :     | next _ = (E, [])
193 :     and left (E, rest) = rest
194 :     | left (t as T(_, a, _, _), rest) = left(a, t::rest)
195 :     fun start m = left(m, [])
196 :    
197 :     (* Return true if and only if the two sets are equal *)
198 :     fun equal (SET(_, s1), SET(_, s2)) = let
199 :     fun cmp (t1, t2) = (case (next t1, next t2)
200 :     of ((E, _), (E, _)) => true
201 :     | ((E, _), _) => false
202 :     | (_, (E, _)) => false
203 :     | ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
204 :     case Key.compare(x, y)
205 :     of EQUAL => cmp (r1, r2)
206 :     | _ => false
207 :     (* end case *))
208 :     (* end case *))
209 :     in
210 :     cmp (start s1, start s2)
211 :     end
212 :    
213 :     (* Return the lexical order of two sets *)
214 :     fun compare (SET(_, s1), SET(_, s2)) = let
215 :     fun cmp (t1, t2) = (case (next t1, next t2)
216 :     of ((E, _), (E, _)) => EQUAL
217 :     | ((E, _), _) => LESS
218 :     | (_, (E, _)) => GREATER
219 :     | ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
220 :     case Key.compare(x, y)
221 :     of EQUAL => cmp (r1, r2)
222 :     | order => order
223 :     (* end case *))
224 :     (* end case *))
225 :     in
226 :     cmp (start s1, start s2)
227 :     end
228 :    
229 :     (* Return true if and only if the first set is a subset of the second *)
230 :     fun isSubset (SET(_, s1), SET(_, s2)) = let
231 :     fun cmp (t1, t2) = (case (next t1, next t2)
232 :     of ((E, _), (E, _)) => true
233 :     | ((E, _), _) => true
234 :     | (_, (E, _)) => false
235 :     | ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
236 :     case Key.compare(x, y)
237 :     of LESS => false
238 :     | EQUAL => cmp (r1, r2)
239 :     | GREATER => cmp (t1, r2)
240 :     (* end case *))
241 :     (* end case *))
242 :     in
243 :     cmp (start s1, start s2)
244 :     end
245 :    
246 : monnier 475 (* support for constructing red-black trees in linear time from increasing
247 :     * ordered sequences (based on a description by R. Hinze). Note that the
248 :     * elements in the digits are ordered with the largest on the left, whereas
249 :     * the elements of the trees are ordered with the largest on the right.
250 : monnier 467 *)
251 :     datatype digit
252 :     = ZERO
253 :     | ONE of (item * tree * digit)
254 :     | TWO of (item * tree * item * tree * digit)
255 : monnier 475 (* add an item that is guaranteed to be larger than any in l *)
256 : monnier 467 fun addItem (a, l) = let
257 :     fun incr (a, t, ZERO) = ONE(a, t, ZERO)
258 :     | incr (a1, t1, ONE(a2, t2, r)) = TWO(a1, t1, a2, t2, r)
259 :     | incr (a1, t1, TWO(a2, t2, a3, t3, r)) =
260 : monnier 475 ONE(a1, t1, incr(a2, T(B, t3, a3, t2), r))
261 : monnier 467 in
262 :     incr(a, E, l)
263 :     end
264 : monnier 475 (* link the digits into a tree *)
265 : monnier 467 fun linkAll t = let
266 :     fun link (t, ZERO) = t
267 : monnier 475 | link (t1, ONE(a, t2, r)) = link(T(B, t2, a, t1), r)
268 : monnier 467 | link (t, TWO(a1, t1, a2, t2, r)) =
269 : monnier 475 link(T(B, T(R, t2, a2, t1), a1, t), r)
270 : monnier 467 in
271 :     link (E, t)
272 :     end
273 :    
274 :     (* return the union of the two sets *)
275 :     fun union (SET(_, s1), SET(_, s2)) = let
276 :     fun ins ((E, _), n, result) = (n, result)
277 :     | ins ((T(_, _, x, _), r), n, result) =
278 :     ins(next r, n+1, addItem(x, result))
279 :     fun union' (t1, t2, n, result) = (case (next t1, next t2)
280 :     of ((E, _), (E, _)) => (n, result)
281 :     | ((E, _), t2) => ins(t2, n, result)
282 :     | (t1, (E, _)) => ins(t1, n, result)
283 :     | ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
284 :     case Key.compare(x, y)
285 :     of LESS => union' (r1, t2, n+1, addItem(x, result))
286 :     | EQUAL => union' (r1, r2, n+1, addItem(x, result))
287 :     | GREATER => union' (t1, r2, n+1, addItem(y, result))
288 :     (* end case *))
289 :     (* end case *))
290 :     val (n, result) = union' (start s1, start s2, 0, ZERO)
291 :     in
292 :     SET(n, linkAll result)
293 :     end
294 :    
295 :     (* return the intersection of the two sets *)
296 :     fun intersection (SET(_, s1), SET(_, s2)) = let
297 :     fun intersect (t1, t2, n, result) = (case (next t1, next t2)
298 :     of ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
299 :     case Key.compare(x, y)
300 :     of LESS => intersect (r1, t2, n, result)
301 :     | EQUAL => intersect (r1, r2, n+1, addItem(x, result))
302 :     | GREATER => intersect (t1, r2, n, result)
303 :     (* end case *))
304 :     | _ => (n, result)
305 :     (* end case *))
306 :     val (n, result) = intersect (start s1, start s2, 0, ZERO)
307 :     in
308 :     SET(n, linkAll result)
309 :     end
310 :    
311 :     (* return the set difference *)
312 :     fun difference (SET(_, s1), SET(_, s2)) = let
313 :     fun ins ((E, _), n, result) = (n, result)
314 :     | ins ((T(_, _, x, _), r), n, result) =
315 :     ins(next r, n+1, addItem(x, result))
316 :     fun diff (t1, t2, n, result) = (case (next t1, next t2)
317 :     of ((E, _), _) => (n, result)
318 :     | (t1, (E, _)) => ins(t1, n, result)
319 :     | ((T(_, _, x, _), r1), (T(_, _, y, _), r2)) => (
320 :     case Key.compare(x, y)
321 :     of LESS => diff (r1, t2, n+1, addItem(x, result))
322 :     | EQUAL => diff (r1, r2, n, result)
323 :     | GREATER => diff (t1, r2, n, result)
324 :     (* end case *))
325 :     (* end case *))
326 :     val (n, result) = diff (start s1, start s2, 0, ZERO)
327 :     in
328 :     SET(n, linkAll result)
329 :     end
330 :    
331 :     fun app f = let
332 :     fun appf E = ()
333 :     | appf (T(_, a, x, b)) = (appf a; f x; appf b)
334 :     in
335 :     fn (SET(_, m)) => appf m
336 :     end
337 :    
338 :     fun map f = let
339 :     fun addf (x, m) = add(m, f x)
340 :     in
341 :     foldl addf empty
342 :     end
343 :    
344 :     (* Filter out those elements of the set that do not satisfy the
345 :     * predicate. The filtering is done in increasing map order.
346 :     *)
347 :     fun filter pred (SET(_, t)) = let
348 :     fun walk (E, n, result) = (n, result)
349 :     | walk (T(_, a, x, b), n, result) = let
350 :     val (n, result) = walk(a, n, result)
351 :     in
352 :     if (pred x)
353 :     then walk(b, n+1, addItem(x, result))
354 :     else walk(b, n, result)
355 :     end
356 :     val (n, result) = walk (t, 0, ZERO)
357 :     in
358 :     SET(n, linkAll result)
359 :     end
360 :    
361 : jhr 816 fun partition pred (SET(_, t)) = let
362 :     fun walk (E, n1, result1, n2, result2) = (n1, result1, n2, result2)
363 :     | walk (T(_, a, x, b), n1, result1, n2, result2) = let
364 :     val (n1, result1, n2, result2) = walk(a, n1, result1, n2, result2)
365 :     in
366 :     if (pred x)
367 :     then walk(b, n1+1, addItem(x, result1), n2, result2)
368 :     else walk(b, n1, result1, n2+1, addItem(x, result2))
369 :     end
370 :     val (n1, result1, n2, result2) = walk (t, 0, ZERO, 0, ZERO)
371 :     in
372 :     (SET(n1, linkAll result1), SET(n2, linkAll result2))
373 :     end
374 :    
375 : monnier 467 fun exists pred = let
376 :     fun test E = false
377 :     | test (T(_, a, x, b)) = test a orelse pred x orelse test b
378 :     in
379 :     fn (SET(_, t)) => test t
380 :     end
381 :    
382 :     fun all pred = let
383 :     fun test E = true
384 :     | test (T(_, a, x, b)) = test a andalso pred x andalso test b
385 :     in
386 :     fn (SET(_, t)) => test t
387 :     end
388 :    
389 :     fun find pred = let
390 :     fun test E = NONE
391 :     | test (T(_, a, x, b)) = (case test a
392 :     of NONE => if pred x then SOME x else test b
393 :     | someItem => someItem
394 :     (* end case *))
395 :     in
396 :     fn (SET(_, t)) => test t
397 :     end
398 :    
399 :     end;

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