Commit | Line | Data |
---|---|---|
182a2654 AC |
1 | (* binary-map-fn.sml |
2 | * | |
3 | * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. | |
4 | * | |
5 | * This code was adapted from Stephen Adams' binary tree implementation | |
6 | * of applicative integer sets. | |
7 | * | |
8 | * Copyright 1992 Stephen Adams. | |
9 | * | |
10 | * This software may be used freely provided that: | |
11 | * 1. This copyright notice is attached to any copy, derived work, | |
12 | * or work including all or part of this software. | |
13 | * 2. Any derived work must contain a prominent notice stating that | |
14 | * it has been altered from the original. | |
15 | * | |
16 | * | |
17 | * Name(s): Stephen Adams. | |
18 | * Department, Institution: Electronics & Computer Science, | |
19 | * University of Southampton | |
20 | * Address: Electronics & Computer Science | |
21 | * University of Southampton | |
22 | * Southampton SO9 5NH | |
23 | * Great Britian | |
24 | * E-mail: sra@ecs.soton.ac.uk | |
25 | * | |
26 | * Comments: | |
27 | * | |
28 | * 1. The implementation is based on Binary search trees of Bounded | |
29 | * Balance, similar to Nievergelt & Reingold, SIAM J. Computing | |
30 | * 2(1), March 1973. The main advantage of these trees is that | |
31 | * they keep the size of the tree in the node, giving a constant | |
32 | * time size operation. | |
33 | * | |
34 | * 2. The bounded balance criterion is simpler than N&R's alpha. | |
35 | * Simply, one subtree must not have more than `weight' times as | |
36 | * many elements as the opposite subtree. Rebalancing is | |
37 | * guaranteed to reinstate the criterion for weight>2.23, but | |
38 | * the occasional incorrect behaviour for weight=2 is not | |
39 | * detrimental to performance. | |
40 | * | |
41 | *) | |
42 | ||
43 | functor BinaryMapFn (K : ORD_KEY) : ORD_MAP = | |
44 | struct | |
45 | ||
46 | structure Key = K | |
47 | ||
48 | (* | |
49 | ** val weight = 3 | |
50 | ** fun wt i = weight * i | |
51 | *) | |
52 | fun wt (i : int) = i + i + i | |
53 | ||
54 | datatype 'a map | |
55 | = E | |
56 | | T of { | |
57 | key : K.ord_key, | |
58 | value : 'a, | |
59 | cnt : int, | |
60 | left : 'a map, | |
61 | right : 'a map | |
62 | } | |
63 | ||
64 | val empty = E | |
65 | ||
66 | fun isEmpty E = true | |
67 | | isEmpty _ = false | |
68 | ||
69 | fun numItems E = 0 | |
70 | | numItems (T{cnt,...}) = cnt | |
71 | ||
72 | (* return the first item in the map (or NONE if it is empty) *) | |
73 | fun first E = NONE | |
74 | | first (T{value, left=E, ...}) = SOME value | |
75 | | first (T{left, ...}) = first left | |
76 | ||
77 | (* return the first item in the map and its key (or NONE if it is empty) *) | |
78 | fun firsti E = NONE | |
79 | | firsti (T{key, value, left=E, ...}) = SOME(key, value) | |
80 | | firsti (T{left, ...}) = firsti left | |
81 | ||
82 | local | |
83 | fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} | |
84 | | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} | |
85 | | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} | |
86 | | N(k,v,l as T n,r as T n') = | |
87 | T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} | |
88 | ||
89 | fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = | |
90 | N(b,bv,N(a,av,x,y),z) | |
91 | | single_L _ = raise Match | |
92 | fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = | |
93 | N(a,av,x,N(b,bv,y,z)) | |
94 | | single_R _ = raise Match | |
95 | fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) = | |
96 | N(b,bv,N(a,av,w,x),N(c,cv,y,z)) | |
97 | | double_L _ = raise Match | |
98 | fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = | |
99 | N(b,bv,N(a,av,w,x),N(c,cv,y,z)) | |
100 | | double_R _ = raise Match | |
101 | ||
102 | fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} | |
103 | | T' (k,v,E,r as T{right=E,left=E,...}) = | |
104 | T{key=k,value=v,cnt=2,left=E,right=r} | |
105 | | T' (k,v,l as T{right=E,left=E,...},E) = | |
106 | T{key=k,value=v,cnt=2,left=l,right=E} | |
107 | ||
108 | | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p | |
109 | | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p | |
110 | ||
111 | (* these cases almost never happen with small weight*) | |
112 | | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = | |
113 | if ln < rn then single_L p else double_L p | |
114 | | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = | |
115 | if ln > rn then single_R p else double_R p | |
116 | ||
117 | | T' (p as (_,_,E,T{left=E,...})) = single_L p | |
118 | | T' (p as (_,_,T{right=E,...},E)) = single_R p | |
119 | ||
120 | | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, | |
121 | r as T{cnt=rn,left=rl,right=rr,...})) = | |
122 | if rn >= wt ln then (*right is too big*) | |
123 | let val rln = numItems rl | |
124 | val rrn = numItems rr | |
125 | in | |
126 | if rln < rrn then single_L p else double_L p | |
127 | end | |
128 | ||
129 | else if ln >= wt rn then (*left is too big*) | |
130 | let val lln = numItems ll | |
131 | val lrn = numItems lr | |
132 | in | |
133 | if lrn < lln then single_R p else double_R p | |
134 | end | |
135 | ||
136 | else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} | |
137 | ||
138 | local | |
139 | fun min (T{left=E,key,value,...}) = (key,value) | |
140 | | min (T{left,...}) = min left | |
141 | | min _ = raise Match | |
142 | ||
143 | fun delmin (T{left=E,right,...}) = right | |
144 | | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right) | |
145 | | delmin _ = raise Match | |
146 | in | |
147 | fun delete' (E,r) = r | |
148 | | delete' (l,E) = l | |
149 | | delete' (l,r) = let val (mink,minv) = min r in | |
150 | T'(mink,minv,l,delmin r) | |
151 | end | |
152 | end | |
153 | in | |
154 | fun mkDict () = E | |
155 | ||
156 | fun singleton (x,v) = T{key=x,value=v,cnt=1,left=E,right=E} | |
157 | ||
158 | fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E} | |
159 | | insert (T(set as {key,left,right,value,...}),x,v) = | |
160 | case K.compare (key,x) of | |
161 | GREATER => T'(key,value,insert(left,x,v),right) | |
162 | | LESS => T'(key,value,left,insert(right,x,v)) | |
163 | | _ => T{key=x,value=v,left=left,right=right,cnt= #cnt set} | |
164 | fun insert' ((k, x), m) = insert(m, k, x) | |
165 | ||
166 | fun inDomain (set, x) = let | |
167 | fun mem E = false | |
168 | | mem (T(n as {key,left,right,...})) = (case K.compare (x,key) | |
169 | of GREATER => mem right | |
170 | | EQUAL => true | |
171 | | LESS => mem left | |
172 | (* end case *)) | |
173 | in | |
174 | mem set | |
175 | end | |
176 | ||
177 | fun find (set, x) = let | |
178 | fun mem E = NONE | |
179 | | mem (T(n as {key,left,right,...})) = (case K.compare (x,key) | |
180 | of GREATER => mem right | |
181 | | EQUAL => SOME(#value n) | |
182 | | LESS => mem left | |
183 | (* end case *)) | |
184 | in | |
185 | mem set | |
186 | end | |
187 | ||
188 | fun remove (E,x) = raise LibBase.NotFound | |
189 | | remove (set as T{key,left,right,value,...},x) = ( | |
190 | case K.compare (key,x) | |
191 | of GREATER => let | |
192 | val (left', v) = remove(left, x) | |
193 | in | |
194 | (T'(key, value, left', right), v) | |
195 | end | |
196 | | LESS => let | |
197 | val (right', v) = remove (right, x) | |
198 | in | |
199 | (T'(key, value, left, right'), v) | |
200 | end | |
201 | | _ => (delete'(left,right),value) | |
202 | (* end case *)) | |
203 | ||
204 | fun listItems d = let | |
205 | fun d2l (E, l) = l | |
206 | | d2l (T{key,value,left,right,...}, l) = | |
207 | d2l(left, value::(d2l(right,l))) | |
208 | in | |
209 | d2l (d,[]) | |
210 | end | |
211 | ||
212 | fun listItemsi d = let | |
213 | fun d2l (E, l) = l | |
214 | | d2l (T{key,value,left,right,...}, l) = | |
215 | d2l(left, (key,value)::(d2l(right,l))) | |
216 | in | |
217 | d2l (d,[]) | |
218 | end | |
219 | ||
220 | fun listKeys d = let | |
221 | fun d2l (E, l) = l | |
222 | | d2l (T{key,left,right,...}, l) = d2l(left, key::(d2l(right,l))) | |
223 | in | |
224 | d2l (d,[]) | |
225 | end | |
226 | ||
227 | local | |
228 | fun next ((t as T{right, ...})::rest) = (t, left(right, rest)) | |
229 | | next _ = (E, []) | |
230 | and left (E, rest) = rest | |
231 | | left (t as T{left=l, ...}, rest) = left(l, t::rest) | |
232 | in | |
233 | fun collate cmpRng (s1, s2) = let | |
234 | fun cmp (t1, t2) = (case (next t1, next t2) | |
235 | of ((E, _), (E, _)) => EQUAL | |
236 | | ((E, _), _) => LESS | |
237 | | (_, (E, _)) => GREATER | |
238 | | ((T{key=x1, value=y1, ...}, r1), (T{key=x2, value=y2, ...}, r2)) => ( | |
239 | case Key.compare(x1, x2) | |
240 | of EQUAL => (case cmpRng(y1, y2) | |
241 | of EQUAL => cmp (r1, r2) | |
242 | | order => order | |
243 | (* end case *)) | |
244 | | order => order | |
245 | (* end case *)) | |
246 | (* end case *)) | |
247 | in | |
248 | cmp (left(s1, []), left(s2, [])) | |
249 | end | |
250 | end (* local *) | |
251 | ||
252 | fun appi f d = let | |
253 | fun app' E = () | |
254 | | app' (T{key,value,left,right,...}) = ( | |
255 | app' left; f(key, value); app' right) | |
256 | in | |
257 | app' d | |
258 | end | |
259 | fun app f d = let | |
260 | fun app' E = () | |
261 | | app' (T{value,left,right,...}) = ( | |
262 | app' left; f value; app' right) | |
263 | in | |
264 | app' d | |
265 | end | |
266 | ||
267 | fun mapi f d = let | |
268 | fun map' E = E | |
269 | | map' (T{key,value,left,right,cnt}) = let | |
270 | val left' = map' left | |
271 | val value' = f(key, value) | |
272 | val right' = map' right | |
273 | in | |
274 | T{cnt=cnt, key=key, value=value', left = left', right = right'} | |
275 | end | |
276 | in | |
277 | map' d | |
278 | end | |
279 | fun map f d = mapi (fn (_, x) => f x) d | |
280 | ||
281 | fun foldli f init d = let | |
282 | fun fold (E, v) = v | |
283 | | fold (T{key,value,left,right,...}, v) = | |
284 | fold (right, f(key, value, fold(left, v))) | |
285 | in | |
286 | fold (d, init) | |
287 | end | |
288 | fun foldl f init d = foldli (fn (_, v, accum) => f (v, accum)) init d | |
289 | ||
290 | fun foldri f init d = let | |
291 | fun fold (E,v) = v | |
292 | | fold (T{key,value,left,right,...},v) = | |
293 | fold (left, f(key, value, fold(right, v))) | |
294 | in | |
295 | fold (d, init) | |
296 | end | |
297 | fun foldr f init d = foldri (fn (_, v, accum) => f (v, accum)) init d | |
298 | ||
299 | (** To be implemented ** | |
300 | val filter : ('a -> bool) -> 'a map -> 'a map | |
301 | val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map | |
302 | **) | |
303 | ||
304 | end (* local *) | |
305 | ||
306 | (* the following are generic implementations of the unionWith, intersectWith, | |
307 | * and mergeWith operetions. These should be specialized for the internal | |
308 | * representations at some point. | |
309 | *) | |
310 | fun unionWith f (m1, m2) = let | |
311 | fun ins f (key, x, m) = (case find(m, key) | |
312 | of NONE => insert(m, key, x) | |
313 | | (SOME x') => insert(m, key, f(x, x')) | |
314 | (* end case *)) | |
315 | in | |
316 | if (numItems m1 > numItems m2) | |
317 | then foldli (ins (fn (a, b) => f (b, a))) m1 m2 | |
318 | else foldli (ins f) m2 m1 | |
319 | end | |
320 | fun unionWithi f (m1, m2) = let | |
321 | fun ins f (key, x, m) = (case find(m, key) | |
322 | of NONE => insert(m, key, x) | |
323 | | (SOME x') => insert(m, key, f(key, x, x')) | |
324 | (* end case *)) | |
325 | in | |
326 | if (numItems m1 > numItems m2) | |
327 | then foldli (ins (fn (k, a, b) => f (k, b, a))) m1 m2 | |
328 | else foldli (ins f) m2 m1 | |
329 | end | |
330 | ||
331 | fun intersectWith f (m1, m2) = let | |
332 | (* iterate over the elements of m1, checking for membership in m2 *) | |
333 | fun intersect f (m1, m2) = let | |
334 | fun ins (key, x, m) = (case find(m2, key) | |
335 | of NONE => m | |
336 | | (SOME x') => insert(m, key, f(x, x')) | |
337 | (* end case *)) | |
338 | in | |
339 | foldli ins empty m1 | |
340 | end | |
341 | in | |
342 | if (numItems m1 > numItems m2) | |
343 | then intersect f (m1, m2) | |
344 | else intersect (fn (a, b) => f(b, a)) (m2, m1) | |
345 | end | |
346 | fun intersectWithi f (m1, m2) = let | |
347 | (* iterate over the elements of m1, checking for membership in m2 *) | |
348 | fun intersect f (m1, m2) = let | |
349 | fun ins (key, x, m) = (case find(m2, key) | |
350 | of NONE => m | |
351 | | (SOME x') => insert(m, key, f(key, x, x')) | |
352 | (* end case *)) | |
353 | in | |
354 | foldli ins empty m1 | |
355 | end | |
356 | in | |
357 | if (numItems m1 > numItems m2) | |
358 | then intersect f (m1, m2) | |
359 | else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1) | |
360 | end | |
361 | ||
362 | fun mergeWith f (m1, m2) = let | |
363 | fun merge ([], [], m) = m | |
364 | | merge ((k1, x1)::r1, [], m) = mergef (k1, SOME x1, NONE, r1, [], m) | |
365 | | merge ([], (k2, x2)::r2, m) = mergef (k2, NONE, SOME x2, [], r2, m) | |
366 | | merge (m1 as ((k1, x1)::r1), m2 as ((k2, x2)::r2), m) = ( | |
367 | case Key.compare (k1, k2) | |
368 | of LESS => mergef (k1, SOME x1, NONE, r1, m2, m) | |
369 | | EQUAL => mergef (k1, SOME x1, SOME x2, r1, r2, m) | |
370 | | GREATER => mergef (k2, NONE, SOME x2, m1, r2, m) | |
371 | (* end case *)) | |
372 | and mergef (k, x1, x2, r1, r2, m) = (case f (x1, x2) | |
373 | of NONE => merge (r1, r2, m) | |
374 | | SOME y => merge (r1, r2, insert(m, k, y)) | |
375 | (* end case *)) | |
376 | in | |
377 | merge (listItemsi m1, listItemsi m2, empty) | |
378 | end | |
379 | fun mergeWithi f (m1, m2) = let | |
380 | fun merge ([], [], m) = m | |
381 | | merge ((k1, x1)::r1, [], m) = mergef (k1, SOME x1, NONE, r1, [], m) | |
382 | | merge ([], (k2, x2)::r2, m) = mergef (k2, NONE, SOME x2, [], r2, m) | |
383 | | merge (m1 as ((k1, x1)::r1), m2 as ((k2, x2)::r2), m) = ( | |
384 | case Key.compare (k1, k2) | |
385 | of LESS => mergef (k1, SOME x1, NONE, r1, m2, m) | |
386 | | EQUAL => mergef (k1, SOME x1, SOME x2, r1, r2, m) | |
387 | | GREATER => mergef (k2, NONE, SOME x2, m1, r2, m) | |
388 | (* end case *)) | |
389 | and mergef (k, x1, x2, r1, r2, m) = (case f (k, x1, x2) | |
390 | of NONE => merge (r1, r2, m) | |
391 | | SOME y => merge (r1, r2, insert(m, k, y)) | |
392 | (* end case *)) | |
393 | in | |
394 | merge (listItemsi m1, listItemsi m2, empty) | |
395 | end | |
396 | ||
397 | (* this is a generic implementation of filter. It should | |
398 | * be specialized to the data-structure at some point. | |
399 | *) | |
400 | fun filter predFn m = let | |
401 | fun f (key, item, m) = if predFn item | |
402 | then insert(m, key, item) | |
403 | else m | |
404 | in | |
405 | foldli f empty m | |
406 | end | |
407 | fun filteri predFn m = let | |
408 | fun f (key, item, m) = if predFn(key, item) | |
409 | then insert(m, key, item) | |
410 | else m | |
411 | in | |
412 | foldli f empty m | |
413 | end | |
414 | ||
415 | (* this is a generic implementation of mapPartial. It should | |
416 | * be specialized to the data-structure at some point. | |
417 | *) | |
418 | fun mapPartial f m = let | |
419 | fun g (key, item, m) = (case f item | |
420 | of NONE => m | |
421 | | (SOME item') => insert(m, key, item') | |
422 | (* end case *)) | |
423 | in | |
424 | foldli g empty m | |
425 | end | |
426 | fun mapPartiali f m = let | |
427 | fun g (key, item, m) = (case f(key, item) | |
428 | of NONE => m | |
429 | | (SOME item') => insert(m, key, item') | |
430 | (* end case *)) | |
431 | in | |
432 | foldli g empty m | |
433 | end | |
434 | ||
435 | end (* functor BinaryMapFn *) |