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/branches/SMLNJ/src/smlnj-lib/Util/binary-map-fn.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/smlnj-lib/Util/binary-map-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 411 - (view) (download)

1 : monnier 2 (* 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 : monnier 289 fun isEmpty E = true
67 :     | isEmpty _ = false
68 :    
69 : monnier 2 fun numItems E = 0
70 :     | numItems (T{cnt,...}) = cnt
71 :    
72 : monnier 289 (* 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 : monnier 2 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 : monnier 411 fun singleton (x,v) = T{key=x,value=v,cnt=1,left=E,right=E}
157 :    
158 : monnier 2 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 : monnier 29 fun insert' ((k, x), m) = insert(m, k, x)
165 : monnier 2
166 : monnier 411 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 : monnier 2 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 : monnier 411 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 : monnier 2 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 and intersectWith
307 :     * operetions. These should be specialized for the internal representations
308 :     * 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 :     (* this is a generic implementation of filter. It should
363 :     * be specialized to the data-structure at some point.
364 :     *)
365 :     fun filter predFn m = let
366 :     fun f (key, item, m) = if predFn item
367 :     then insert(m, key, item)
368 :     else m
369 :     in
370 :     foldli f empty m
371 :     end
372 :     fun filteri predFn m = let
373 :     fun f (key, item, m) = if predFn(key, item)
374 :     then insert(m, key, item)
375 :     else m
376 :     in
377 :     foldli f empty m
378 :     end
379 :    
380 :     (* this is a generic implementation of mapPartial. It should
381 :     * be specialized to the data-structure at some point.
382 :     *)
383 :     fun mapPartial f m = let
384 :     fun g (key, item, m) = (case f item
385 :     of NONE => m
386 :     | (SOME item') => insert(m, key, item')
387 :     (* end case *))
388 :     in
389 :     foldli g empty m
390 :     end
391 :     fun mapPartiali f m = let
392 :     fun g (key, item, m) = (case f(key, item)
393 :     of NONE => m
394 :     | (SOME item') => insert(m, key, item')
395 :     (* end case *))
396 :     in
397 :     foldli g empty m
398 :     end
399 :    
400 :     end (* functor BinaryMapFn *)

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