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/trunk/Util/redblack-map-fn.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3894 - (view) (download)

1 : monnier 467 (* redblack-map-fn.sml
2 :     *
3 : jhr 3894 * COPYRIGHT (c) 2014 The Fellowship of SML/NJ (http://www.smlnj.org)
4 : jhr 3759 * All rights reserved.
5 :     *
6 : monnier 467 * COPYRIGHT (c) 1999 Bell Labs, Lucent Technologies.
7 :     *
8 :     * This code is based on Chris Okasaki's implementation of
9 :     * red-black trees. The linear-time tree construction code is
10 :     * based on the paper "Constructing red-black trees" by Hinze,
11 :     * and the delete function is based on the description in Cormen,
12 :     * Leiserson, and Rivest.
13 :     *
14 :     * A red-black tree should satisfy the following two invariants:
15 :     *
16 : jhr 3894 * Red Invariant: each red node has black children (empty nodes are
17 :     * considered black).
18 : monnier 467 *
19 : jhr 3894 * Black Invariant: each path from the root to an empty node has the
20 : monnier 467 * same number of black nodes (the tree's black height).
21 :     *
22 : jhr 3894 * The Black invariant implies that any node with only one child
23 :     * will be black and its child will be a red leaf.
24 : monnier 467 *)
25 :    
26 :     functor RedBlackMapFn (K : ORD_KEY) :> ORD_MAP where Key = K =
27 :     struct
28 :    
29 :     structure Key = K
30 :    
31 :     datatype color = R | B
32 : jhr 3894
33 :     datatype 'a tree
34 : monnier 467 = E
35 :     | T of (color * 'a tree * K.ord_key * '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 : jhr 3894 fun singleton (xk, x) = MAP(1, T(B, E, xk, x, E))
45 : monnier 467
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)) = (case K.compare(xk, yk)
50 :     of LESS => (case a
51 :     of T(R, c, zk, z, d) => (case K.compare(xk, zk)
52 :     of LESS => (case ins c
53 :     of T(R, e, wk, w, f) =>
54 :     T(R, T(B,e,wk, w,f), zk, z, T(B,d,yk,y,b))
55 :     | c => T(B, T(R,c,zk,z,d), yk, y, b)
56 :     (* end case *))
57 : monnier 475 | EQUAL => T(color, T(R, c, xk, x, d), yk, y, b)
58 : monnier 467 | GREATER => (case ins d
59 :     of T(R, e, wk, w, f) =>
60 :     T(R, T(B,c,zk,z,e), wk, w, T(B,f,yk,y,b))
61 :     | d => T(B, T(R,c,zk,z,d), yk, y, b)
62 :     (* end case *))
63 :     (* end case *))
64 :     | _ => T(B, ins a, yk, y, b)
65 :     (* end case *))
66 : monnier 475 | EQUAL => T(color, a, xk, x, b)
67 : monnier 467 | GREATER => (case b
68 :     of T(R, c, zk, z, d) => (case K.compare(xk, zk)
69 :     of LESS => (case ins c
70 :     of T(R, e, wk, w, f) =>
71 :     T(R, T(B,a,yk,y,e), wk, w, T(B,f,zk,z,d))
72 :     | c => T(B, a, yk, y, T(R,c,zk,z,d))
73 :     (* end case *))
74 : monnier 475 | EQUAL => T(color, a, yk, y, T(R, c, xk, x, d))
75 : monnier 467 | GREATER => (case ins d
76 :     of T(R, e, wk, w, f) =>
77 :     T(R, T(B,a,yk,y,c), zk, z, T(B,e,wk,w,f))
78 :     | d => T(B, a, yk, y, T(R,c,zk,z,d))
79 :     (* end case *))
80 :     (* end case *))
81 :     | _ => T(B, a, yk, y, ins b)
82 :     (* end case *))
83 :     (* end case *))
84 : jhr 3894 val T(_, a, yk, y, b) = ins m
85 : monnier 467 in
86 : jhr 3894 MAP(!nItems', T(B, a, yk, y, b))
87 : monnier 467 end
88 :     fun insert' ((xk, x), m) = insert (m, xk, x)
89 :    
90 :     (* Is a key in the domain of the map? *)
91 :     fun inDomain (MAP(_, t), k) = let
92 :     fun find' E = false
93 :     | find' (T(_, a, yk, y, b)) = (case K.compare(k, yk)
94 :     of LESS => find' a
95 :     | EQUAL => true
96 :     | GREATER => find' b
97 :     (* end case *))
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)) = (case K.compare(k, yk)
106 :     of LESS => find' a
107 :     | EQUAL => SOME y
108 :     | GREATER => find' b
109 :     (* end case *))
110 :     in
111 :     find' t
112 :     end
113 :    
114 : jhr 2274 (* Look for an item, raise NotFound if the item doesn't exist *)
115 :     fun lookup (MAP(_, t), k) = let
116 :     fun look E = raise LibBase.NotFound
117 :     | look (T(_, a, yk, y, b)) = (case K.compare(k, yk)
118 :     of LESS => look a
119 :     | EQUAL => y
120 :     | GREATER => look b
121 :     (* end case *))
122 :     in
123 :     look t
124 :     end
125 :    
126 : monnier 467 (* Remove an item, returning new map and value removed.
127 :     * Raises LibBase.NotFound if not found.
128 :     *)
129 :     local
130 :     datatype 'a zipper
131 :     = TOP
132 :     | LEFT of (color * K.ord_key * 'a * 'a tree * 'a zipper)
133 :     | RIGHT of (color * 'a tree * K.ord_key * 'a * 'a zipper)
134 :     in
135 :     fun remove (MAP(nItems, t), k) = let
136 : jhr 3894 (* zip the zipper *)
137 : monnier 467 fun zip (TOP, t) = t
138 :     | zip (LEFT(color, xk, x, b, z), a) = zip(z, T(color, a, xk, x, b))
139 :     | zip (RIGHT(color, a, xk, x, z), b) = zip(z, T(color, a, xk, x, b))
140 : jhr 3894 (* zip the zipper while resolving a black deficit *)
141 :     fun fixupZip (TOP, t) = (true, t)
142 :     (* case 1 from CLR *)
143 :     | fixupZip (LEFT(B, xk, x, T(R, a, yk, y, b), p), t) = (case a
144 :     of T(_, T(R, a11, wk, w, a12), zk, z, a2) => (* case 1L ==> case 3L ==> case 4L *)
145 :     (false, zip (p, T(B, T(R, T(B, t, xk, x, a11), wk, w, T(B, a12, zk, z, a2)), yk, y, b)))
146 :     | T(_, a1, zk, z, T(R, a21, wk, w, t22)) => (* case 1L ==> case 4L *)
147 :     (false, zip (p, T(B, T(R, T(B, t, xk, x, a1), zk, z, T(B, a21, wk, w, t22)), yk, y, b)))
148 :     | T(_, a1, zk, z, a2) => (* case 1L ==> case 2L; rotate + recolor fixes deficit *)
149 :     (false, zip (p, T(B, T(B, t, xk, x, T(R, a1, zk, z, a2)), yk, y, b)))
150 :     | _ => fixupZip (LEFT(R, xk, x, a, LEFT(B, yk, y, b, p)), t)
151 :     (* end case *))
152 :     | fixupZip (RIGHT(B, T(R, a, xk, x, b), yk, y, p), t) = (case b
153 :     of T(_, b1, zk, z, T(R, b21, wk, w, b22)) => (* case 1R ==> case 3R ==> case 4R *)
154 :     (false, zip (p, T(B, a, xk, x, T(R, T(B, b1, zk, z, b21), wk, w, T(B, b22, yk, y, t)))))
155 :     | T(_, T(R, b11, wk, w, b12), zk, z, b2) => (* case 1R ==> case 4R *)
156 :     (false, zip (p, T(B, a, xk, x, T(R, T(B, b11, wk, w, b12), zk, z, T(B, b2, yk, y, t)))))
157 :     | T(_, b1, zk, z, b2) => (* case 1L ==> case 2L; rotate + recolor fixes deficit *)
158 :     (false, zip (p, T(B, a, xk, x, T(B, T(R, b1, zk, z, b2), yk, y, t))))
159 :     | _ => fixupZip (RIGHT(R, b, yk, y, RIGHT(B, a, xk, x, p)), t)
160 :     (* end case *))
161 :     (* case 3 from CLR *)
162 :     | fixupZip (LEFT(color, xk, x, T(B, T(R, a1, yk, y, a2), zk, z, b), p), t) =
163 :     (* case 3L ==> case 4L *)
164 :     (false, zip (p, T(color, T(B, t, xk, x, a1), yk, y, T(B, a2, zk, z, b))))
165 :     | fixupZip (RIGHT(color, T(B, a, xk, x, T(R, b1, yk, y, b2)), zk, z, p), t) =
166 :     (* case 3R ==> case 4R; rotate, recolor, plus rotate fixes deficit *)
167 :     (false, zip (p, T(color, T(B, a, xk, x, b1), yk, y, T(B, b2, zk, z, t))))
168 :     (* case 4 from CLR *)
169 :     | fixupZip (LEFT(color, xk, x, T(B, a, yk, y, T(R, b1, zk, z, b2)), p), t) =
170 :     (false, zip (p, T(color, T(B, t, xk, x, a), yk, y, T(B, b1, zk, z, b2))))
171 :     | fixupZip (RIGHT(color, T(B, T(R, a1, zk, z, a2), xk, x, b), yk, y, p), t) =
172 :     (false, zip (p, T(color, T(B, a1, zk, z, a2), xk, x, T(B, b, yk, y, t))))
173 :     (* case 2 from CLR; note that "a" and "b" are guaranteed to be black, since we did
174 :     * not match cases 3 or 4.
175 :     *)
176 :     | fixupZip (LEFT(R, xk, x, T(B, a, yk, y, b), p), t) =
177 :     (false, zip (p, T(B, t, xk, x, T(R, a, yk, y, b))))
178 :     | fixupZip (LEFT(B, xk, x, T(B, a, yk, y, b), p), t) =
179 :     fixupZip (p, T(B, t, xk, x, T(R, a, yk, y, b)))
180 :     | fixupZip (RIGHT(R, T(B, a, xk, x, b), yk, y, p), t) =
181 :     (false, zip (p, T(B, T(R, a, xk, x, b), yk, y, t)))
182 :     | fixupZip (RIGHT(B, T(B, a, xk, x, b), yk, y, p), t) =
183 :     fixupZip (p, T(B, T(R, a, xk, x, b), yk, y, t))
184 :     (* push deficit up the tree by recoloring a black node as red *)
185 :     | fixupZip (LEFT(_, yk, y, E, p), t) = fixupZip (p, T(R, t, yk, y, E))
186 :     | fixupZip (RIGHT(_, E, yk, y, p), t) = fixupZip (p, T(R, E, yk, y, t))
187 :     (* impossible cases that violate the red invariant *)
188 :     | fixupZip _ = raise Fail "Red invariant violation"
189 :     (* delete the minimum value from a non-empty tree, returning a 4-tuple
190 :     * (key, elem, bd, tr), where key is the minimum key, elem is the element
191 :     * named by key, tr is the residual tree with elem removed, and bd is true
192 :     * if tr has a black-depth that is less than the original tree.
193 : monnier 467 *)
194 : jhr 3894 fun delMin (T(R, E, yk, y, b), p) =
195 :     (* replace the node by its right subtree (which must be E) *)
196 :     (yk, y, false, zip(p, b))
197 :     | delMin (T(B, E, yk, y, T(R, a', yk', y', b')), p) =
198 :     (* replace the node with its right child, while recoloring the child black to
199 :     * preserve the black invariant.
200 :     *)
201 :     (yk, y, false, zip (p, T(B, a', yk', y', b')))
202 :     | delMin (T(B, E, yk, y, E), p) = let
203 :     (* delete the node, which reduces the black-depth by one, so we attempt to fix
204 :     * the deficit on the path back.
205 :     *)
206 :     val (blkDeficit, t) = fixupZip (p, E)
207 :     in
208 :     (yk, y, blkDeficit, t)
209 :     end
210 : monnier 467 | delMin (T(color, a, yk, y, b), z) = delMin(a, LEFT(color, yk, y, b, z))
211 : monnier 498 | delMin (E, _) = raise Match
212 : jhr 3894 fun del (E, p) = raise LibBase.NotFound
213 :     | del (T(color, a, yk, y, b), p) = (case K.compare(k, yk)
214 :     of LESS => del (a, LEFT(color, yk, y, b, p))
215 :     | EQUAL => (case (color, a, b)
216 :     of (R, E, E) => (y, zip(p, E))
217 :     | (B, E, E) => (y, #2 (fixupZip (p, E)))
218 :     | (_, T(_, a', yk', y', b'), E) =>
219 :     (* node is black and left child is red; we replace the node with its
220 :     * left child recolored to black.
221 :     *)
222 :     (y, zip(p, T(B, a', yk', y', b')))
223 :     | (_, E, T(_, a', yk', y', b')) =>
224 :     (* node is black and right child is red; we replace the node with its
225 :     * right child recolored to black.
226 :     *)
227 :     (y, zip(p, T(B, a', yk', y', b')))
228 :     | _ => let
229 :     val (minKey, minElem, blkDeficit, b) = delMin (b, TOP)
230 :     in
231 :     if blkDeficit
232 :     then (y, #2 (fixupZip (RIGHT(color, a, minKey, minElem, p), b)))
233 :     else (y, zip (p, T(color, a, minKey, minElem, b)))
234 :     end
235 :     (* end case *))
236 :     | GREATER => del (b, RIGHT(color, a, yk, y, p))
237 : monnier 467 (* end case *))
238 :     val (item, t) = del(t, TOP)
239 :     in
240 : jhr 3894 case t
241 :     of T(R, a, xk, x, b) => (MAP(nItems-1, T(B, a, xk, x, b)), item)
242 :     | t => (MAP(nItems-1, t), item)
243 :     (* end case *)
244 : monnier 467 end
245 :     end (* local *)
246 :    
247 :     (* return the first item in the map (or NONE if it is empty) *)
248 :     fun first (MAP(_, t)) = let
249 :     fun f E = NONE
250 :     | f (T(_, E, _, x, _)) = SOME x
251 :     | f (T(_, a, _, _, _)) = f a
252 :     in
253 :     f t
254 :     end
255 :     fun firsti (MAP(_, t)) = let
256 :     fun f E = NONE
257 :     | f (T(_, E, xk, x, _)) = SOME(xk, x)
258 :     | f (T(_, a, _, _, _)) = f a
259 :     in
260 :     f t
261 :     end
262 :    
263 :     (* Return the number of items in the map *)
264 :     fun numItems (MAP(n, _)) = n
265 :    
266 :     fun foldl f = let
267 :     fun foldf (E, accum) = accum
268 :     | foldf (T(_, a, _, x, b), accum) =
269 :     foldf(b, f(x, foldf(a, accum)))
270 :     in
271 :     fn init => fn (MAP(_, m)) => foldf(m, init)
272 :     end
273 :     fun foldli f = let
274 :     fun foldf (E, accum) = accum
275 :     | foldf (T(_, a, xk, x, b), accum) =
276 :     foldf(b, f(xk, x, foldf(a, accum)))
277 :     in
278 :     fn init => fn (MAP(_, m)) => foldf(m, init)
279 :     end
280 :    
281 :     fun foldr f = let
282 :     fun foldf (E, accum) = accum
283 :     | foldf (T(_, a, _, x, b), accum) =
284 :     foldf(a, f(x, foldf(b, accum)))
285 :     in
286 :     fn init => fn (MAP(_, m)) => foldf(m, init)
287 :     end
288 :     fun foldri f = let
289 :     fun foldf (E, accum) = accum
290 :     | foldf (T(_, a, xk, x, b), accum) =
291 :     foldf(a, f(xk, x, foldf(b, accum)))
292 :     in
293 :     fn init => fn (MAP(_, m)) => foldf(m, init)
294 :     end
295 :    
296 :     fun listItems m = foldr (op ::) [] m
297 :     fun listItemsi m = foldri (fn (xk, x, l) => (xk, x)::l) [] m
298 :    
299 :     (* return an ordered list of the keys in the map. *)
300 :     fun listKeys m = foldri (fn (k, _, l) => k::l) [] m
301 :    
302 :     (* functions for walking the tree while keeping a stack of parents
303 :     * to be visited.
304 :     *)
305 :     fun next ((t as T(_, _, _, _, b))::rest) = (t, left(b, rest))
306 :     | next _ = (E, [])
307 :     and left (E, rest) = rest
308 :     | left (t as T(_, a, _, _, _), rest) = left(a, t::rest)
309 :     fun start m = left(m, [])
310 :    
311 :     (* given an ordering on the map's range, return an ordering
312 :     * on the map.
313 :     *)
314 :     fun collate cmpRng = let
315 :     fun cmp (t1, t2) = (case (next t1, next t2)
316 :     of ((E, _), (E, _)) => EQUAL
317 :     | ((E, _), _) => LESS
318 :     | (_, (E, _)) => GREATER
319 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
320 :     case Key.compare(xk, yk)
321 :     of EQUAL => (case cmpRng(x, y)
322 :     of EQUAL => cmp (r1, r2)
323 :     | order => order
324 :     (* end case *))
325 :     | order => order
326 :     (* end case *))
327 :     (* end case *))
328 :     in
329 :     fn (MAP(_, m1), MAP(_, m2)) => cmp (start m1, start m2)
330 :     end
331 :    
332 : monnier 475 (* support for constructing red-black trees in linear time from increasing
333 :     * ordered sequences (based on a description by R. Hinze). Note that the
334 :     * elements in the digits are ordered with the largest on the left, whereas
335 :     * the elements of the trees are ordered with the largest on the right.
336 : monnier 467 *)
337 :     datatype 'a digit
338 :     = ZERO
339 :     | ONE of (K.ord_key * 'a * 'a tree * 'a digit)
340 :     | TWO of (K.ord_key * 'a * 'a tree * K.ord_key * 'a * 'a tree * 'a digit)
341 : monnier 475 (* add an item that is guaranteed to be larger than any in l *)
342 : monnier 467 fun addItem (ak, a, l) = let
343 :     fun incr (ak, a, t, ZERO) = ONE(ak, a, t, ZERO)
344 :     | incr (ak1, a1, t1, ONE(ak2, a2, t2, r)) =
345 :     TWO(ak1, a1, t1, ak2, a2, t2, r)
346 :     | incr (ak1, a1, t1, TWO(ak2, a2, t2, ak3, a3, t3, r)) =
347 : monnier 475 ONE(ak1, a1, t1, incr(ak2, a2, T(B, t3, ak3, a3, t2), r))
348 : monnier 467 in
349 :     incr(ak, a, E, l)
350 :     end
351 : monnier 475 (* link the digits into a tree *)
352 : monnier 467 fun linkAll t = let
353 :     fun link (t, ZERO) = t
354 : monnier 475 | link (t1, ONE(ak, a, t2, r)) = link(T(B, t2, ak, a, t1), r)
355 : monnier 467 | link (t, TWO(ak1, a1, t1, ak2, a2, t2, r)) =
356 : monnier 475 link(T(B, T(R, t2, ak2, a2, t1), ak1, a1, t), r)
357 : monnier 467 in
358 :     link (E, t)
359 :     end
360 :    
361 :     local
362 :     fun wrap f (MAP(_, m1), MAP(_, m2)) = let
363 :     val (n, result) = f (start m1, start m2, 0, ZERO)
364 :     in
365 :     MAP(n, linkAll result)
366 :     end
367 :     fun ins ((E, _), n, result) = (n, result)
368 :     | ins ((T(_, _, xk, x, _), r), n, result) =
369 :     ins(next r, n+1, addItem(xk, x, result))
370 :     in
371 :    
372 :     (* return a map whose domain is the union of the domains of the two input
373 :     * maps, using the supplied function to define the map on elements that
374 :     * are in both domains.
375 :     *)
376 :     fun unionWith mergeFn = let
377 :     fun union (t1, t2, n, result) = (case (next t1, next t2)
378 :     of ((E, _), (E, _)) => (n, result)
379 :     | ((E, _), t2) => ins(t2, n, result)
380 :     | (t1, (E, _)) => ins(t1, n, result)
381 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
382 :     case Key.compare(xk, yk)
383 :     of LESS => union (r1, t2, n+1, addItem(xk, x, result))
384 :     | EQUAL =>
385 :     union (r1, r2, n+1, addItem(xk, mergeFn(x, y), result))
386 :     | GREATER => union (t1, r2, n+1, addItem(yk, y, result))
387 :     (* end case *))
388 :     (* end case *))
389 :     in
390 :     wrap union
391 :     end
392 :     fun unionWithi mergeFn = let
393 :     fun union (t1, t2, n, result) = (case (next t1, next t2)
394 :     of ((E, _), (E, _)) => (n, result)
395 :     | ((E, _), t2) => ins(t2, n, result)
396 :     | (t1, (E, _)) => ins(t1, n, result)
397 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
398 :     case Key.compare(xk, yk)
399 :     of LESS => union (r1, t2, n+1, addItem(xk, x, result))
400 :     | EQUAL => union (
401 :     r1, r2, n+1, addItem(xk, mergeFn(xk, x, y), result))
402 :     | GREATER => union (t1, r2, n+1, addItem(yk, y, result))
403 :     (* end case *))
404 :     (* end case *))
405 :     in
406 :     wrap union
407 :     end
408 :    
409 :     (* return a map whose domain is the intersection of the domains of the
410 :     * two input maps, using the supplied function to define the range.
411 :     *)
412 :     fun intersectWith mergeFn = let
413 :     fun intersect (t1, t2, n, result) = (case (next t1, next t2)
414 :     of ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
415 :     case Key.compare(xk, yk)
416 :     of LESS => intersect (r1, t2, n, result)
417 :     | EQUAL =>
418 :     intersect (r1, r2, n+1,
419 :     addItem(xk, mergeFn(x, y), result))
420 :     | GREATER => intersect (t1, r2, n, result)
421 :     (* end case *))
422 :     | _ => (n, result)
423 :     (* end case *))
424 :     in
425 :     wrap intersect
426 :     end
427 :     fun intersectWithi mergeFn = let
428 :     fun intersect (t1, t2, n, result) = (case (next t1, next t2)
429 :     of ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
430 :     case Key.compare(xk, yk)
431 :     of LESS => intersect (r1, t2, n, result)
432 :     | EQUAL =>
433 :     intersect (r1, r2, n+1,
434 :     addItem(xk, mergeFn(xk, x, y), result))
435 :     | GREATER => intersect (t1, r2, n, result)
436 :     (* end case *))
437 :     | _ => (n, result)
438 :     (* end case *))
439 :     in
440 :     wrap intersect
441 :     end
442 : jhr 1193
443 :     fun mergeWith mergeFn = let
444 :     fun merge (t1, t2, n, result) = (case (next t1, next t2)
445 :     of ((E, _), (E, _)) => (n, result)
446 :     | ((E, _), (T(_, _, yk, y, _), r2)) =>
447 :     mergef(yk, NONE, SOME y, t1, r2, n, result)
448 :     | ((T(_, _, xk, x, _), r1), (E, _)) =>
449 :     mergef(xk, SOME x, NONE, r1, t2, n, result)
450 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
451 :     case Key.compare(xk, yk)
452 :     of LESS => mergef(xk, SOME x, NONE, r1, t2, n, result)
453 :     | EQUAL => mergef(xk, SOME x, SOME y, r1, r2, n, result)
454 :     | GREATER => mergef(yk, NONE, SOME y, t1, r2, n, result)
455 :     (* end case *))
456 :     (* end case *))
457 :     and mergef (k, x1, x2, r1, r2, n, result) = (case mergeFn(x1, x2)
458 :     of NONE => merge (r1, r2, n, result)
459 :     | SOME y => merge (r1, r2, n+1, addItem(k, y, result))
460 :     (* end case *))
461 :     in
462 :     wrap merge
463 :     end
464 :     fun mergeWithi mergeFn = let
465 :     fun merge (t1, t2, n, result) = (case (next t1, next t2)
466 :     of ((E, _), (E, _)) => (n, result)
467 :     | ((E, _), (T(_, _, yk, y, _), r2)) =>
468 :     mergef(yk, NONE, SOME y, t1, r2, n, result)
469 :     | ((T(_, _, xk, x, _), r1), (E, _)) =>
470 :     mergef(xk, SOME x, NONE, r1, t2, n, result)
471 :     | ((T(_, _, xk, x, _), r1), (T(_, _, yk, y, _), r2)) => (
472 :     case Key.compare(xk, yk)
473 :     of LESS => mergef(xk, SOME x, NONE, r1, t2, n, result)
474 :     | EQUAL => mergef(xk, SOME x, SOME y, r1, r2, n, result)
475 :     | GREATER => mergef(yk, NONE, SOME y, t1, r2, n, result)
476 :     (* end case *))
477 :     (* end case *))
478 :     and mergef (k, x1, x2, r1, r2, n, result) = (case mergeFn(k, x1, x2)
479 :     of NONE => merge (r1, r2, n, result)
480 :     | SOME y => merge (r1, r2, n+1, addItem(k, y, result))
481 :     (* end case *))
482 :     in
483 :     wrap merge
484 :     end
485 : monnier 467 end (* local *)
486 :    
487 :     fun app f = let
488 :     fun appf E = ()
489 :     | appf (T(_, a, _, x, b)) = (appf a; f x; appf b)
490 :     in
491 :     fn (MAP(_, m)) => appf m
492 :     end
493 :     fun appi f = let
494 :     fun appf E = ()
495 :     | appf (T(_, a, xk, x, b)) = (appf a; f(xk, x); appf b)
496 :     in
497 :     fn (MAP(_, m)) => appf m
498 :     end
499 :    
500 :     fun map f = let
501 :     fun mapf E = E
502 :     | mapf (T(color, a, xk, x, b)) =
503 :     T(color, mapf a, xk, f x, mapf b)
504 :     in
505 :     fn (MAP(n, m)) => MAP(n, mapf m)
506 :     end
507 :     fun mapi f = let
508 :     fun mapf E = E
509 :     | mapf (T(color, a, xk, x, b)) =
510 :     T(color, mapf a, xk, f(xk, x), mapf b)
511 :     in
512 :     fn (MAP(n, m)) => MAP(n, mapf m)
513 :     end
514 :    
515 :     (* Filter out those elements of the map that do not satisfy the
516 :     * predicate. The filtering is done in increasing map order.
517 :     *)
518 :     fun filter pred (MAP(_, t)) = let
519 :     fun walk (E, n, result) = (n, result)
520 :     | walk (T(_, a, xk, x, b), n, result) = let
521 :     val (n, result) = walk(a, n, result)
522 :     in
523 :     if (pred x)
524 :     then walk(b, n+1, addItem(xk, x, result))
525 :     else walk(b, n, result)
526 :     end
527 :     val (n, result) = walk (t, 0, ZERO)
528 :     in
529 :     MAP(n, linkAll result)
530 :     end
531 :     fun filteri pred (MAP(_, t)) = let
532 :     fun walk (E, n, result) = (n, result)
533 :     | walk (T(_, a, xk, x, b), n, result) = let
534 :     val (n, result) = walk(a, n, result)
535 :     in
536 :     if (pred(xk, x))
537 :     then walk(b, n+1, addItem(xk, x, result))
538 :     else walk(b, n, result)
539 :     end
540 :     val (n, result) = walk (t, 0, ZERO)
541 :     in
542 :     MAP(n, linkAll result)
543 :     end
544 :    
545 :     (* map a partial function over the elements of a map in increasing
546 :     * map order.
547 :     *)
548 :     fun mapPartial f = let
549 :     fun f' (xk, x, m) = (case f x
550 :     of NONE => m
551 :     | (SOME y) => insert(m, xk, y)
552 :     (* end case *))
553 :     in
554 :     foldli f' empty
555 :     end
556 :     fun mapPartiali f = let
557 :     fun f' (xk, x, m) = (case f(xk, x)
558 :     of NONE => m
559 :     | (SOME y) => insert(m, xk, y)
560 :     (* end case *))
561 :     in
562 :     foldli f' empty
563 :     end
564 :    
565 : jhr 3759 (* check the elements of a map with a predicate and return true if
566 :     * any element satisfies the predicate. Return false otherwise.
567 :     * Elements are checked in key order.
568 :     *)
569 :     fun exists pred = let
570 :     fun exists' E = false
571 :     | exists' (T(_, a, _, x, b)) = exists' a orelse pred x orelse exists' b
572 :     in
573 :     fn (MAP(_, m)) => exists' m
574 :     end
575 :     fun existsi pred = let
576 :     fun exists' E = false
577 :     | exists' (T(_, a, k, x, b)) = exists' a orelse pred(k, x) orelse exists' b
578 :     in
579 :     fn (MAP(_, m)) => exists' m
580 :     end
581 :    
582 :     (* check the elements of a map with a predicate and return true if
583 :     * they all satisfy the predicate. Return false otherwise. Elements
584 :     * are checked in key order.
585 :     *)
586 :     fun all pred = let
587 :     fun all' E = true
588 :     | all' (T(_, a, _, x, b)) = all' a andalso pred x andalso all' b
589 :     in
590 :     fn (MAP(_, m)) => all' m
591 :     end
592 :     fun alli pred = let
593 :     fun all' E = true
594 :     | all' (T(_, a, k, x, b)) = all' a andalso pred(k, x) andalso all' b
595 :     in
596 :     fn (MAP(_, m)) => all' m
597 :     end
598 :    
599 : monnier 467 end;

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