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/int-binary-map.sml
ViewVC logotype

Annotation of /smlnj-lib/trunk/Util/int-binary-map.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3759 - (view) (download)

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

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