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/word-redblack-map.sml
ViewVC logotype

Annotation of /smlnj-lib/releases/release-110.61/Util/word-redblack-map.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2253 - (view) (download)

1 : jhr 702 (* word-redblack-map.sml
2 :     *
3 :     * COPYRIGHT (c) 2000 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 :     structure WordRedBlackMap :> ORD_MAP where type Key.ord_key = word =
24 :     struct
25 :    
26 :     structure Key =
27 :     struct
28 :     type ord_key = word
29 :     val compare = Word.compare
30 :     end
31 :    
32 :     datatype color = R | B
33 :     and 'a tree
34 :     = E
35 :     | T of (color * 'a tree * word * 'a * 'a tree)
36 :    
37 :     datatype 'a map = MAP of (int * 'a tree)
38 :    
39 :     fun isEmpty (MAP(_, E)) = true
40 :     | isEmpty _ = false
41 :    
42 :     val empty = MAP(0, E)
43 :    
44 :     fun singleton (xk, x) = MAP(1, T(R, E, xk, x, E))
45 :    
46 :     fun insert (MAP(nItems, m), xk, x) = let
47 :     val nItems' = ref nItems
48 :     fun ins E = (nItems' := nItems+1; T(R, E, xk, x, E))
49 :     | ins (s as T(color, a, yk, y, b)) =
50 :     if (xk < yk)
51 :     then (case a
52 :     of T(R, c, zk, z, d) =>
53 :     if (xk < zk)
54 :     then (case ins c
55 :     of T(R, e, wk, w, f) =>
56 :     T(R, T(B,e,wk,w,f), zk, z, T(B,d,yk,y,b))
57 :     | c => T(B, T(R,c,zk,z,d), yk, y, b)
58 :     (* end case *))
59 : jhr 785 else if (xk = zk)
60 :     then T(color, T(R, c, xk, x, d), yk, y, b)
61 : jhr 702 else (case ins d
62 :     of T(R, e, wk, w, f) =>
63 :     T(R, T(B,c,zk,z,e), wk, w, T(B,f,yk,y,b))
64 :     | d => T(B, T(R,c,zk,z,d), yk, y, b)
65 :     (* end case *))
66 :     | _ => T(B, ins a, yk, y, b)
67 :     (* end case *))
68 :     else if (xk = yk)
69 : jhr 785 then T(color, a, xk, x, b)
70 : jhr 702 else (case b
71 :     of T(R, c, zk, z, d) =>
72 :     if (xk < zk)
73 :     then (case ins c
74 :     of T(R, e, wk, w, f) =>
75 :     T(R, T(B,a,yk,y,e), wk, w, T(B,f,zk,z,d))
76 :     | c => T(B, a, yk, y, T(R,c,zk,z,d))
77 :     (* end case *))
78 :     else if (xk = zk)
79 : jhr 785 then T(color, a, yk, y, T(R, c, xk, x, d))
80 : jhr 702 else (case ins d
81 :     of T(R, e, wk, w, f) =>
82 :     T(R, T(B,a,yk,y,c), zk, z, T(B,e,wk,w,f))
83 :     | d => T(B, a, yk, y, T(R,c,zk,z,d))
84 :     (* end case *))
85 :     | _ => T(B, a, yk, y, ins b)
86 :     (* end case *))
87 :     val m = ins m
88 :     in
89 :     MAP(!nItems', m)
90 :     end
91 :     fun insert' ((xk, x), m) = insert (m, xk, x)
92 :    
93 :     (* Is a key in the domain of the map? *)
94 :     fun inDomain (MAP(_, t), k) = let
95 :     fun find' E = false
96 :     | find' (T(_, a, yk, y, b)) =
97 :     (k = yk) orelse ((k < yk) andalso find' a) orelse (find' b)
98 :     in
99 :     find' t
100 :     end
101 :    
102 :     (* Look for an item, return NONE if the item doesn't exist *)
103 :     fun find (MAP(_, t), k) = let
104 :     fun find' E = NONE
105 :     | find' (T(_, a, yk, y, b)) =
106 :     if (k < yk)
107 :     then find' a
108 :     else if (k = yk)
109 :     then SOME y
110 :     else find' b
111 :     in
112 :     find' t
113 :     end
114 :    
115 :     (* Remove an item, returning new map and value removed.
116 :     * Raises LibBase.NotFound if not found.
117 :     *)
118 :     local
119 :     datatype 'a zipper
120 :     = TOP
121 :     | LEFT of (color * word * 'a * 'a tree * 'a zipper)
122 :     | RIGHT of (color * 'a tree * word * 'a * 'a zipper)
123 :     in
124 :     fun remove (MAP(nItems, t), k) = let
125 :     fun zip (TOP, t) = t
126 :     | zip (LEFT(color, xk, x, b, z), a) = zip(z, T(color, a, xk, x, b))
127 :     | zip (RIGHT(color, a, xk, x, z), b) = zip(z, T(color, a, xk, x, b))
128 :     (* bbZip propagates a black deficit up the tree until either the top
129 :     * is reached, or the deficit can be covered. It returns a boolean
130 :     * that is true if there is still a deficit and the zipped tree.
131 :     *)
132 :     fun bbZip (TOP, t) = (true, t)
133 :     | bbZip (LEFT(B, xk, x, T(R, c, yk, y, d), z), a) = (* case 1L *)
134 :     bbZip (LEFT(R, xk, x, c, LEFT(B, yk, y, d, z)), a)
135 :     | bbZip (LEFT(color, xk, x, T(B, T(R, c, yk, y, d), wk, w, e), z), a) =
136 :     (* case 3L *)
137 :     bbZip (LEFT(color, xk, x, T(B, c, yk, y, T(R, d, wk, w, e)), z), a)
138 :     | bbZip (LEFT(color, xk, x, T(B, c, yk, y, T(R, d, wk, w, e)), z), a) =
139 :     (* case 4L *)
140 :     (false, zip (z, T(color, T(B, a, xk, x, c), yk, y, T(B, d, wk, w, e))))
141 :     | bbZip (LEFT(R, xk, x, T(B, c, yk, y, d), z), a) = (* case 2L *)
142 :     (false, zip (z, T(B, a, xk, x, T(R, c, yk, y, d))))
143 :     | bbZip (LEFT(B, xk, x, T(B, c, yk, y, d), z), a) = (* case 2L *)
144 :     bbZip (z, T(B, a, xk, x, T(R, c, yk, y, d)))
145 :     | bbZip (RIGHT(color, T(R, c, yk, y, d), xk, x, z), b) = (* case 1R *)
146 :     bbZip (RIGHT(R, d, xk, x, RIGHT(B, c, yk, y, z)), b)
147 :     | bbZip (RIGHT(color, T(B, T(R, c, wk, w, d), yk, y, e), xk, x, z), b) =
148 :     (* case 3R *)
149 :     bbZip (RIGHT(color, T(B, c, wk, w, T(R, d, yk, y, e)), xk, x, z), b)
150 :     | bbZip (RIGHT(color, T(B, c, yk, y, T(R, d, wk, w, e)), xk, x, z), b) =
151 :     (* case 4R *)
152 :     (false, zip (z, T(color, c, yk, y, T(B, T(R, d, wk, w, e), xk, x, b))))
153 :     | bbZip (RIGHT(R, T(B, c, yk, y, d), xk, x, z), b) = (* case 2R *)
154 :     (false, zip (z, T(B, T(R, c, yk, y, d), xk, x, b)))
155 :     | bbZip (RIGHT(B, T(B, c, yk, y, d), xk, x, z), b) = (* case 2R *)
156 :     bbZip (z, T(B, T(R, c, yk, y, d), xk, x, b))
157 :     | bbZip (z, t) = (false, zip(z, t))
158 :     fun delMin (T(R, E, yk, y, b), z) = (yk, y, (false, zip(z, b)))
159 :     | delMin (T(B, E, yk, y, b), z) = (yk, y, bbZip(z, b))
160 :     | delMin (T(color, a, yk, y, b), z) = delMin(a, LEFT(color, yk, y, b, z))
161 :     | delMin (E, _) = raise Match
162 :     fun join (R, E, E, z) = zip(z, E)
163 :     | join (_, a, E, z) = #2(bbZip(z, a)) (* color = black *)
164 :     | join (_, E, b, z) = #2(bbZip(z, b)) (* color = black *)
165 :     | join (color, a, b, z) = let
166 :     val (xk, x, (needB, b')) = delMin(b, TOP)
167 :     in
168 :     if needB
169 :     then #2(bbZip(z, T(color, a, xk, x, b')))
170 :     else zip(z, T(color, a, xk, x, b'))
171 :     end
172 :     fun del (E, z) = raise LibBase.NotFound
173 :     | del (T(color, a, yk, y, b), z) =
174 :     if (k < yk)
175 :     then del (a, LEFT(color, yk, y, b, z))
176 :     else if (k = yk)
177 :     then (y, join (color, a, b, z))
178 :     else del (b, RIGHT(color, a, yk, y, z))
179 :     val (item, t) = del(t, TOP)
180 :     in
181 :     (MAP(nItems-1, t), item)
182 :     end
183 :     end (* local *)
184 :    
185 :     (* return the first item in the map (or NONE if it is empty) *)
186 :     fun first (MAP(_, t)) = let
187 :     fun f E = NONE
188 :     | f (T(_, E, _, x, _)) = SOME x
189 :     | f (T(_, a, _, _, _)) = f a
190 :     in
191 :     f t
192 :     end
193 :     fun firsti (MAP(_, t)) = let
194 :     fun f E = NONE
195 :     | f (T(_, E, xk, x, _)) = SOME(xk, x)
196 :     | f (T(_, a, _, _, _)) = f a
197 :     in
198 :     f t
199 :     end
200 :    
201 :     (* Return the number of items in the map *)
202 :     fun numItems (MAP(n, _)) = n
203 :    
204 :     fun foldl f = let
205 :     fun foldf (E, accum) = accum
206 :     | foldf (T(_, a, _, x, b), accum) =
207 :     foldf(b, f(x, foldf(a, accum)))
208 :     in
209 :     fn init => fn (MAP(_, m)) => foldf(m, init)
210 :     end
211 :     fun foldli f = let
212 :     fun foldf (E, accum) = accum
213 :     | foldf (T(_, a, xk, x, b), accum) =
214 :     foldf(b, f(xk, x, foldf(a, accum)))
215 :     in
216 :     fn init => fn (MAP(_, m)) => foldf(m, init)
217 :     end
218 :    
219 :     fun foldr f = let
220 :     fun foldf (E, accum) = accum
221 :     | foldf (T(_, a, _, x, b), accum) =
222 :     foldf(a, f(x, foldf(b, accum)))
223 :     in
224 :     fn init => fn (MAP(_, m)) => foldf(m, init)
225 :     end
226 :     fun foldri f = let
227 :     fun foldf (E, accum) = accum
228 :     | foldf (T(_, a, xk, x, b), accum) =
229 :     foldf(a, f(xk, x, foldf(b, accum)))
230 :     in
231 :     fn init => fn (MAP(_, m)) => foldf(m, init)
232 :     end
233 :    
234 :     fun listItems m = foldr (op ::) [] m
235 :     fun listItemsi m = foldri (fn (xk, x, l) => (xk, x)::l) [] m
236 :    
237 :     (* return an ordered list of the keys in the map. *)
238 :     fun listKeys m = foldri (fn (k, _, l) => k::l) [] m
239 :    
240 :     (* functions for walking the tree while keeping a stack of parents
241 :     * to be visited.
242 :     *)
243 :     fun next ((t as T(_, _, _, _, b))::rest) = (t, left(b, rest))
244 :     | next _ = (E, [])
245 :     and left (E, rest) = rest
246 :     | left (t as T(_, a, _, _, _), rest) = left(a, t::rest)
247 :     fun start m = left(m, [])
248 :    
249 :     (* given an ordering on the map's range, return an ordering
250 :     * on the map.
251 :     *)
252 :     fun collate cmpRng = let
253 :     fun cmp (t1, t2) = (case (next t1, next t2)
254 :     of ((E, _), (E, _)) => EQUAL
255 :     | ((E, _), _) => LESS
256 :     | (_, (E, _)) => GREATER
257 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
258 :     if (xk = yk)
259 :     then (case cmpRng(x, y)
260 :     of EQUAL => cmp (r1, r2)
261 :     | order => order
262 :     (* end case *))
263 :     else if (xk < yk)
264 :     then LESS
265 :     else GREATER
266 :     (* end case *))
267 :     in
268 :     fn (MAP(_, m1), MAP(_, m2)) => cmp (start m1, start m2)
269 :     end
270 :    
271 :     (* support for constructing red-black trees in linear time from increasing
272 :     * ordered sequences (based on a description by R. Hinze). Note that the
273 :     * elements in the digits are ordered with the largest on the left, whereas
274 :     * the elements of the trees are ordered with the largest on the right.
275 :     *)
276 :     datatype 'a digit
277 :     = ZERO
278 :     | ONE of (word * 'a * 'a tree * 'a digit)
279 :     | TWO of (word * 'a * 'a tree * word * 'a * 'a tree * 'a digit)
280 :     (* add an item that is guaranteed to be larger than any in l *)
281 :     fun addItem (ak, a, l) = let
282 :     fun incr (ak, a, t, ZERO) = ONE(ak, a, t, ZERO)
283 :     | incr (ak1, a1, t1, ONE(ak2, a2, t2, r)) =
284 :     TWO(ak1, a1, t1, ak2, a2, t2, r)
285 :     | incr (ak1, a1, t1, TWO(ak2, a2, t2, ak3, a3, t3, r)) =
286 :     ONE(ak1, a1, t1, incr(ak2, a2, T(B, t3, ak3, a3, t2), r))
287 :     in
288 :     incr(ak, a, E, l)
289 :     end
290 :     (* link the digits into a tree *)
291 :     fun linkAll t = let
292 :     fun link (t, ZERO) = t
293 :     | link (t1, ONE(ak, a, t2, r)) = link(T(B, t2, ak, a, t1), r)
294 :     | link (t, TWO(ak1, a1, t1, ak2, a2, t2, r)) =
295 :     link(T(B, T(R, t2, ak2, a2, t1), ak1, a1, t), r)
296 :     in
297 :     link (E, t)
298 :     end
299 :    
300 :     local
301 :     fun wrap f (MAP(_, m1), MAP(_, m2)) = let
302 :     val (n, result) = f (start m1, start m2, 0, ZERO)
303 :     in
304 :     MAP(n, linkAll result)
305 :     end
306 :     fun ins ((E, _), n, result) = (n, result)
307 :     | ins ((T(_, _, xk, x, _), r), n, result) =
308 :     ins(next r, n+1, addItem(xk, x, result))
309 :     in
310 :    
311 :     (* return a map whose domain is the union of the domains of the two input
312 :     * maps, using the supplied function to define the map on elements that
313 :     * are in both domains.
314 :     *)
315 :     fun unionWith mergeFn = let
316 :     fun union (t1, t2, n, result) = (case (next t1, next t2)
317 :     of ((E, _), (E, _)) => (n, result)
318 :     | ((E, _), t2) => ins(t2, n, result)
319 :     | (t1, (E, _)) => ins(t1, n, result)
320 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
321 :     if (xk < yk)
322 :     then union (r1, t2, n+1, addItem(xk, x, result))
323 :     else if (xk = yk)
324 :     then union (r1, r2, n+1, addItem(xk, mergeFn(x, y), result))
325 :     else union (t1, r2, n+1, addItem(yk, y, result))
326 :     (* end case *))
327 :     in
328 :     wrap union
329 :     end
330 :     fun unionWithi mergeFn = let
331 :     fun union (t1, t2, n, result) = (case (next t1, next t2)
332 :     of ((E, _), (E, _)) => (n, result)
333 :     | ((E, _), t2) => ins(t2, n, result)
334 :     | (t1, (E, _)) => ins(t1, n, result)
335 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
336 :     if (xk < yk)
337 :     then union (r1, t2, n+1, addItem(xk, x, result))
338 :     else if (xk = yk)
339 :     then
340 :     union (r1, r2, n+1, addItem(xk, mergeFn(xk, x, y), result))
341 :     else union (t1, r2, n+1, addItem(yk, y, result))
342 :     (* end case *))
343 :     in
344 :     wrap union
345 :     end
346 :    
347 :     (* return a map whose domain is the intersection of the domains of the
348 :     * two input maps, using the supplied function to define the range.
349 :     *)
350 :     fun intersectWith mergeFn = let
351 :     fun intersect (t1, t2, n, result) = (case (next t1, next t2)
352 :     of ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
353 :     if (xk < yk)
354 :     then intersect (r1, t2, n, result)
355 :     else if (xk = yk)
356 :     then intersect (
357 :     r1, r2, n+1, addItem(xk, mergeFn(x, y), result))
358 :     else intersect (t1, r2, n, result)
359 :     | _ => (n, result)
360 :     (* end case *))
361 :     in
362 :     wrap intersect
363 :     end
364 :     fun intersectWithi mergeFn = let
365 :     fun intersect (t1, t2, n, result) = (case (next t1, next t2)
366 :     of ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
367 :     if (xk < yk)
368 :     then intersect (r1, t2, n, result)
369 :     else if (xk = yk)
370 :     then intersect (r1, r2, n+1,
371 :     addItem(xk, mergeFn(xk, x, y), result))
372 :     else intersect (t1, r2, n, result)
373 :     | _ => (n, result)
374 :     (* end case *))
375 :     in
376 :     wrap intersect
377 :     end
378 : jhr 1193
379 :     fun mergeWith mergeFn = let
380 :     fun merge (t1, t2, n, result) = (case (next t1, next t2)
381 :     of ((E, _), (E, _)) => (n, result)
382 :     | ((E, _), (T(_, _, yk, y, _), r2)) =>
383 :     mergef(yk, NONE, SOME y, t1, r2, n, result)
384 :     | ((T(_, _, xk, x, _), r1), (E, _)) =>
385 :     mergef(xk, SOME x, NONE, r1, t2, n, result)
386 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
387 :     if (xk < yk)
388 :     then mergef(xk, SOME x, NONE, r1, t2, n, result)
389 :     else if (xk = yk)
390 :     then mergef(xk, SOME x, SOME y, r1, r2, n, result)
391 :     else mergef(yk, NONE, SOME y, t1, r2, n, result)
392 :     (* end case *))
393 :     and mergef (k, x1, x2, r1, r2, n, result) = (case mergeFn(x1, x2)
394 :     of NONE => merge (r1, r2, n, result)
395 :     | SOME y => merge (r1, r2, n+1, addItem(k, y, result))
396 :     (* end case *))
397 :     in
398 :     wrap merge
399 :     end
400 :     fun mergeWithi mergeFn = let
401 :     fun merge (t1, t2, n, result) = (case (next t1, next t2)
402 :     of ((E, _), (E, _)) => (n, result)
403 :     | ((E, _), (T(_, _, yk, y, _), r2)) =>
404 :     mergef(yk, NONE, SOME y, t1, r2, n, result)
405 :     | ((T(_, _, xk, x, _), r1), (E, _)) =>
406 :     mergef(xk, SOME x, NONE, r1, t2, n, result)
407 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) =>
408 :     if (xk < yk)
409 :     then mergef(xk, SOME x, NONE, r1, t2, n, result)
410 :     else if (xk = yk)
411 :     then mergef(xk, SOME x, SOME y, r1, r2, n, result)
412 :     else mergef(yk, NONE, SOME y, t1, r2, n, result)
413 :     (* end case *))
414 :     and mergef (k, x1, x2, r1, r2, n, result) = (case mergeFn(k, x1, x2)
415 :     of NONE => merge (r1, r2, n, result)
416 :     | SOME y => merge (r1, r2, n+1, addItem(k, y, result))
417 :     (* end case *))
418 :     in
419 :     wrap merge
420 :     end
421 : jhr 702 end (* local *)
422 :    
423 :     fun app f = let
424 :     fun appf E = ()
425 :     | appf (T(_, a, _, x, b)) = (appf a; f x; appf b)
426 :     in
427 :     fn (MAP(_, m)) => appf m
428 :     end
429 :     fun appi f = let
430 :     fun appf E = ()
431 :     | appf (T(_, a, xk, x, b)) = (appf a; f(xk, x); appf b)
432 :     in
433 :     fn (MAP(_, m)) => appf m
434 :     end
435 :    
436 :     fun map f = let
437 :     fun mapf E = E
438 :     | mapf (T(color, a, xk, x, b)) =
439 :     T(color, mapf a, xk, f x, mapf b)
440 :     in
441 :     fn (MAP(n, m)) => MAP(n, mapf m)
442 :     end
443 :     fun mapi f = let
444 :     fun mapf E = E
445 :     | mapf (T(color, a, xk, x, b)) =
446 :     T(color, mapf a, xk, f(xk, x), mapf b)
447 :     in
448 :     fn (MAP(n, m)) => MAP(n, mapf m)
449 :     end
450 :    
451 :     (* Filter out those elements of the map that do not satisfy the
452 :     * predicate. The filtering is done in increasing map order.
453 :     *)
454 :     fun filter pred (MAP(_, t)) = let
455 :     fun walk (E, n, result) = (n, result)
456 :     | walk (T(_, a, xk, x, b), n, result) = let
457 :     val (n, result) = walk(a, n, result)
458 :     in
459 :     if (pred x)
460 :     then walk(b, n+1, addItem(xk, x, result))
461 :     else walk(b, n, result)
462 :     end
463 :     val (n, result) = walk (t, 0, ZERO)
464 :     in
465 :     MAP(n, linkAll result)
466 :     end
467 :     fun filteri pred (MAP(_, t)) = let
468 :     fun walk (E, n, result) = (n, result)
469 :     | walk (T(_, a, xk, x, b), n, result) = let
470 :     val (n, result) = walk(a, n, result)
471 :     in
472 :     if (pred(xk, x))
473 :     then walk(b, n+1, addItem(xk, x, result))
474 :     else walk(b, n, result)
475 :     end
476 :     val (n, result) = walk (t, 0, ZERO)
477 :     in
478 :     MAP(n, linkAll result)
479 :     end
480 :    
481 :     (* map a partial function over the elements of a map in increasing
482 :     * map order.
483 :     *)
484 :     fun mapPartial f = let
485 :     fun f' (xk, x, m) = (case f x
486 :     of NONE => m
487 :     | (SOME y) => insert(m, xk, y)
488 :     (* end case *))
489 :     in
490 :     foldli f' empty
491 :     end
492 :     fun mapPartiali f = let
493 :     fun f' (xk, x, m) = (case f(xk, x)
494 :     of NONE => m
495 :     | (SOME y) => insert(m, xk, y)
496 :     (* end case *))
497 :     in
498 :     foldli f' empty
499 :     end
500 :    
501 :     end;

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