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/branches/rt-transition/Util/splay-map-fn.sml
ViewVC logotype

Annotation of /smlnj-lib/branches/rt-transition/Util/splay-map-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4070 - (view) (download)

1 : monnier 2 (* splay-map-fn.sml
2 :     *
3 : jhr 4070 * 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 :     * Functor implementing dictionaries using splay trees.
9 :     *
10 :     *)
11 :    
12 :     functor SplayMapFn (K : ORD_KEY) : ORD_MAP =
13 :     struct
14 :     structure Key = K
15 :     open SplayTree
16 :    
17 : monnier 289 datatype 'a map
18 :     = EMPTY
19 : monnier 2 | MAP of {
20 : jhr 4070 root : (K.ord_key * 'a) splay ref,
21 :     nobj : int
22 :     }
23 : monnier 2
24 :     fun cmpf k (k', _) = K.compare(k',k)
25 :    
26 :     val empty = EMPTY
27 : monnier 289
28 :     fun isEmpty EMPTY = true
29 :     | isEmpty _ = false
30 :    
31 :     (* return the first item in the map (or NONE if it is empty) *)
32 :     fun first EMPTY = NONE
33 :     | first (MAP{root, ...}) = let
34 :     fun f (SplayObj{value=(_, value), left=SplayNil, ...}) = SOME value
35 :     | f (SplayObj{left, ...}) = f left
36 : monnier 498 | f SplayNil = raise Fail "SplayMapFn.first"
37 : monnier 289 in
38 :     f (!root)
39 :     end
40 :    
41 :     (* return the first item in the map and its key (or NONE if it is empty) *)
42 :     fun firsti EMPTY = NONE
43 :     | firsti (MAP{root, ...}) = let
44 :     fun f (SplayObj{value=(key, value), left=SplayNil, ...}) = SOME(key, value)
45 :     | f (SplayObj{left, ...}) = f left
46 : monnier 498 | f SplayNil = raise Fail "SplayMapFn.firsti"
47 : monnier 289 in
48 :     f (!root)
49 :     end
50 :    
51 : monnier 411 fun singleton (key, v) =
52 :     MAP{nobj=1,root=ref(SplayObj{value=(key,v),left=SplayNil,right=SplayNil})}
53 :    
54 :     (* Insert an item. *)
55 : monnier 2 fun insert (EMPTY,key,v) =
56 :     MAP{nobj=1,root=ref(SplayObj{value=(key,v),left=SplayNil,right=SplayNil})}
57 :     | insert (MAP{root,nobj},key,v) =
58 :     case splay (cmpf key, !root) of
59 :     (EQUAL,SplayObj{value,left,right}) =>
60 :     MAP{nobj=nobj,root=ref(SplayObj{value=(key,v),left=left,right=right})}
61 :     | (LESS,SplayObj{value,left,right}) =>
62 :     MAP{
63 :     nobj=nobj+1,
64 :     root=ref(SplayObj{value=(key,v),left=SplayObj{value=value,left=left,right=SplayNil},right=right})
65 :     }
66 :     | (GREATER,SplayObj{value,left,right}) =>
67 :     MAP{
68 :     nobj=nobj+1,
69 :     root=ref(SplayObj{
70 :     value=(key,v),
71 :     left=left,
72 :     right=SplayObj{value=value,left=SplayNil,right=right}
73 :     })
74 :     }
75 :     | (_,SplayNil) => raise LibBase.Impossible "SplayMapFn.insert SplayNil"
76 : monnier 29 fun insert' ((k, x), m) = insert(m, k, x)
77 : monnier 2
78 : monnier 411 fun inDomain (EMPTY, _) = false
79 :     | inDomain (MAP{root,nobj}, key) = (case splay (cmpf key, !root)
80 :     of (EQUAL, r as SplayObj{value,...}) => (root := r; true)
81 :     | (_, r) => (root := r; false)
82 :     (* end case *))
83 :    
84 : monnier 2 (* Look for an item, return NONE if the item doesn't exist *)
85 :     fun find (EMPTY,_) = NONE
86 :     | find (MAP{root,nobj},key) = (case splay (cmpf key, !root)
87 :     of (EQUAL, r as SplayObj{value,...}) => (root := r; SOME(#2 value))
88 : jhr 2274 | (_, r) => (root := r; NONE)
89 :     (* end case *))
90 : monnier 2
91 : jhr 2274 (* Look for an item, raise NotFound if the item doesn't exist *)
92 :     fun lookup (EMPTY,_) = raise LibBase.NotFound
93 :     | lookup (MAP{root,nobj},key) = (case splay (cmpf key, !root)
94 :     of (EQUAL, r as SplayObj{value,...}) => (root := r; #2 value)
95 :     | (_, r) => (root := r; raise LibBase.NotFound)
96 :     (* end case *))
97 :    
98 : monnier 2 (* Remove an item.
99 :     * Raise LibBase.NotFound if not found
100 :     *)
101 :     fun remove (EMPTY, _) = raise LibBase.NotFound
102 :     | remove (MAP{root,nobj}, key) = (case (splay (cmpf key, !root))
103 :     of (EQUAL, SplayObj{value, left, right}) =>
104 :     if nobj = 1
105 :     then (EMPTY, #2 value)
106 :     else (MAP{root=ref(join(left,right)),nobj=nobj-1}, #2 value)
107 :     | (_,r) => (root := r; raise LibBase.NotFound)
108 :     (* end case *))
109 :    
110 :     (* Return the number of items in the table *)
111 :     fun numItems EMPTY = 0
112 :     | numItems (MAP{nobj,...}) = nobj
113 :    
114 :     (* Return a list of the items (and their keys) in the dictionary *)
115 :     fun listItems EMPTY = []
116 :     | listItems (MAP{root,...}) = let
117 :     fun apply (SplayNil, l) = l
118 :     | apply (SplayObj{value=(_, v), left, right}, l) =
119 :     apply(left, v::(apply (right,l)))
120 :     in
121 :     apply (!root, [])
122 :     end
123 :     fun listItemsi EMPTY = []
124 :     | listItemsi (MAP{root,...}) = let
125 :     fun apply (SplayNil,l) = l
126 :     | apply (SplayObj{value,left,right},l) =
127 :     apply(left, value::(apply (right,l)))
128 :     in
129 :     apply (!root,[])
130 :     end
131 :    
132 : monnier 411 fun listKeys EMPTY = []
133 :     | listKeys (MAP{root,...}) = let
134 :     fun apply (SplayNil, l) = l
135 :     | apply (SplayObj{value=(key, _),left,right},l) =
136 :     apply(left, key::(apply (right,l)))
137 :     in
138 :     apply (!root, [])
139 :     end
140 :    
141 : monnier 2 local
142 :     fun next ((t as SplayObj{right, ...})::rest) = (t, left(right, rest))
143 :     | next _ = (SplayNil, [])
144 :     and left (SplayNil, rest) = rest
145 :     | left (t as SplayObj{left=l, ...}, rest) = left(l, t::rest)
146 :     in
147 :     fun collate cmpRng (EMPTY, EMPTY) = EQUAL
148 :     | collate cmpRng (EMPTY, _) = LESS
149 :     | collate cmpRng (_, EMPTY) = GREATER
150 :     | collate cmpRng (MAP{root=s1, ...}, MAP{root=s2, ...}) = let
151 :     fun cmp (t1, t2) = (case (next t1, next t2)
152 :     of ((SplayNil, _), (SplayNil, _)) => EQUAL
153 :     | ((SplayNil, _), _) => LESS
154 :     | (_, (SplayNil, _)) => GREATER
155 :     | ((SplayObj{value=(x1, y1), ...}, r1),
156 :     (SplayObj{value=(x2, y2), ...}, r2)
157 :     ) => (
158 :     case Key.compare(x1, x2)
159 :     of EQUAL => (case cmpRng (y1, y2)
160 :     of EQUAL => cmp (r1, r2)
161 :     | order => order
162 :     (* end case *))
163 :     | order => order
164 :     (* end case *))
165 :     (* end case *))
166 :     in
167 :     cmp (left(!s1, []), left(!s2, []))
168 :     end
169 :     end (* local *)
170 :    
171 :     (* Apply a function to the entries of the dictionary *)
172 :     fun appi af EMPTY = ()
173 :     | appi af (MAP{root,...}) =
174 :     let fun apply SplayNil = ()
175 :     | apply (SplayObj{value,left,right}) =
176 :     (apply left; af value; apply right)
177 :     in
178 :     apply (!root)
179 :     end
180 :    
181 :     fun app af EMPTY = ()
182 :     | app af (MAP{root,...}) =
183 :     let fun apply SplayNil = ()
184 :     | apply (SplayObj{value=(_,value),left,right}) =
185 :     (apply left; af value; apply right)
186 :     in
187 :     apply (!root)
188 :     end
189 :     (*
190 :     fun revapp af (MAP{root,...}) =
191 :     let fun apply SplayNil = ()
192 :     | apply (SplayObj{value,left,right}) =
193 :     (apply right; af value; apply left)
194 :     in
195 :     apply (!root)
196 :     end
197 :     *)
198 :    
199 :     (* Fold function *)
200 :     fun foldri (abf : K.ord_key * 'a * 'b -> 'b) b EMPTY = b
201 :     | foldri (abf : K.ord_key * 'a * 'b -> 'b) b (MAP{root,...}) =
202 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
203 :     | apply (SplayObj{value,left,right},b) =
204 :     apply(left,abf(#1 value,#2 value,apply(right,b)))
205 :     in
206 :     apply (!root,b)
207 :     end
208 :    
209 :     fun foldr (abf : 'a * 'b -> 'b) b EMPTY = b
210 :     | foldr (abf : 'a * 'b -> 'b) b (MAP{root,...}) =
211 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
212 :     | apply (SplayObj{value=(_,value),left,right},b) =
213 :     apply(left,abf(value,apply(right,b)))
214 :     in
215 :     apply (!root,b)
216 :     end
217 :    
218 :     fun foldli (abf : K.ord_key * 'a * 'b -> 'b) b EMPTY = b
219 :     | foldli (abf : K.ord_key * 'a * 'b -> 'b) b (MAP{root,...}) =
220 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
221 :     | apply (SplayObj{value,left,right},b) =
222 :     apply(right,abf(#1 value,#2 value,apply(left,b)))
223 :     in
224 :     apply (!root,b)
225 :     end
226 :    
227 :     fun foldl (abf : 'a * 'b -> 'b) b EMPTY = b
228 :     | foldl (abf : 'a * 'b -> 'b) b (MAP{root,...}) =
229 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
230 :     | apply (SplayObj{value=(_,value),left,right},b) =
231 :     apply(right,abf(value,apply(left,b)))
232 :     in
233 :     apply (!root,b)
234 :     end
235 :    
236 :     (* Map a table to a new table that has the same keys*)
237 :     fun mapi (af : K.ord_key * 'a -> 'b) EMPTY = EMPTY
238 :     | mapi (af : K.ord_key * 'a -> 'b) (MAP{root,nobj}) =
239 :     let fun ap (SplayNil : (K.ord_key * 'a) splay) = SplayNil
240 :     | ap (SplayObj{value,left,right}) = let
241 :     val left' = ap left
242 :     val value' = (#1 value, af value)
243 :     in
244 :     SplayObj{value = value', left = left', right = ap right}
245 :     end
246 :     in
247 :     MAP{root = ref(ap (!root)), nobj = nobj}
248 :     end
249 :    
250 :     fun map (af : 'a -> 'b) EMPTY = EMPTY
251 :     | map (af : 'a -> 'b) (MAP{root,nobj}) =
252 :     let fun ap (SplayNil : (K.ord_key * 'a) splay) = SplayNil
253 :     | ap (SplayObj{value,left,right}) = let
254 :     val left' = ap left
255 :     val value' = (#1 value, af (#2 value))
256 :     in
257 :     SplayObj{value = value', left = left', right = ap right}
258 :     end
259 :     in
260 :     MAP{root = ref(ap (!root)), nobj = nobj}
261 :     end
262 :    
263 : jhr 1193 (* the following are generic implementations of the unionWith, intersectWith,
264 :     * and mergeWith operetions. These should be specialized for the internal
265 :     * representations at some point.
266 : monnier 2 *)
267 :     fun unionWith f (m1, m2) = let
268 :     fun ins f (key, x, m) = (case find(m, key)
269 :     of NONE => insert(m, key, x)
270 :     | (SOME x') => insert(m, key, f(x, x'))
271 :     (* end case *))
272 :     in
273 :     if (numItems m1 > numItems m2)
274 :     then foldli (ins (fn (a, b) => f(b, a))) m1 m2
275 :     else foldli (ins f) m2 m1
276 :     end
277 :     fun unionWithi f (m1, m2) = let
278 :     fun ins f (key, x, m) = (case find(m, key)
279 :     of NONE => insert(m, key, x)
280 :     | (SOME x') => insert(m, key, f(key, x, x'))
281 :     (* end case *))
282 :     in
283 :     if (numItems m1 > numItems m2)
284 :     then foldli (ins (fn (k, a, b) => f(k, b, a))) m1 m2
285 :     else foldli (ins f) m2 m1
286 :     end
287 :    
288 :     fun intersectWith f (m1, m2) = let
289 :     (* iterate over the elements of m1, checking for membership in m2 *)
290 :     fun intersect f (m1, m2) = let
291 :     fun ins (key, x, m) = (case find(m2, key)
292 :     of NONE => m
293 :     | (SOME x') => insert(m, key, f(x, x'))
294 :     (* end case *))
295 :     in
296 :     foldli ins empty m1
297 :     end
298 :     in
299 :     if (numItems m1 > numItems m2)
300 :     then intersect f (m1, m2)
301 :     else intersect (fn (a, b) => f(b, a)) (m2, m1)
302 :     end
303 :    
304 :     fun intersectWithi f (m1, m2) = let
305 :     (* iterate over the elements of m1, checking for membership in m2 *)
306 :     fun intersect f (m1, m2) = let
307 :     fun ins (key, x, m) = (case find(m2, key)
308 :     of NONE => m
309 :     | (SOME x') => insert(m, key, f(key, x, x'))
310 :     (* end case *))
311 :     in
312 :     foldli ins empty m1
313 :     end
314 :     in
315 :     if (numItems m1 > numItems m2)
316 :     then intersect f (m1, m2)
317 :     else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1)
318 :     end
319 :    
320 : jhr 1193 fun mergeWith f (m1, m2) = let
321 :     fun merge ([], [], m) = m
322 :     | merge ((k1, x1)::r1, [], m) = mergef (k1, SOME x1, NONE, r1, [], m)
323 :     | merge ([], (k2, x2)::r2, m) = mergef (k2, NONE, SOME x2, [], r2, m)
324 :     | merge (m1 as ((k1, x1)::r1), m2 as ((k2, x2)::r2), m) = (
325 :     case Key.compare (k1, k2)
326 :     of LESS => mergef (k1, SOME x1, NONE, r1, m2, m)
327 :     | EQUAL => mergef (k1, SOME x1, SOME x2, r1, r2, m)
328 :     | GREATER => mergef (k2, NONE, SOME x2, m1, r2, m)
329 :     (* end case *))
330 :     and mergef (k, x1, x2, r1, r2, m) = (case f (x1, x2)
331 :     of NONE => merge (r1, r2, m)
332 :     | SOME y => merge (r1, r2, insert(m, k, y))
333 :     (* end case *))
334 :     in
335 :     merge (listItemsi m1, listItemsi m2, empty)
336 :     end
337 :    
338 :     fun mergeWithi f (m1, m2) = let
339 :     fun merge ([], [], m) = m
340 :     | merge ((k1, x1)::r1, [], m) = mergef (k1, SOME x1, NONE, r1, [], m)
341 :     | merge ([], (k2, x2)::r2, m) = mergef (k2, NONE, SOME x2, [], r2, m)
342 :     | merge (m1 as ((k1, x1)::r1), m2 as ((k2, x2)::r2), m) = (
343 :     case Key.compare (k1, k2)
344 :     of LESS => mergef (k1, SOME x1, NONE, r1, m2, m)
345 :     | EQUAL => mergef (k1, SOME x1, SOME x2, r1, r2, m)
346 :     | GREATER => mergef (k2, NONE, SOME x2, m1, r2, m)
347 :     (* end case *))
348 :     and mergef (k, x1, x2, r1, r2, m) = (case f (k, x1, x2)
349 :     of NONE => merge (r1, r2, m)
350 :     | SOME y => merge (r1, r2, insert(m, k, y))
351 :     (* end case *))
352 :     in
353 :     merge (listItemsi m1, listItemsi m2, empty)
354 :     end
355 :    
356 : monnier 2 (* this is a generic implementation of mapPartial. It should
357 :     * be specialized to the data-structure at some point.
358 :     *)
359 :     fun mapPartial f m = let
360 :     fun g (key, item, m) = (case f item
361 :     of NONE => m
362 :     | (SOME item') => insert(m, key, item')
363 :     (* end case *))
364 :     in
365 :     foldli g empty m
366 :     end
367 :     fun mapPartiali f m = let
368 :     fun g (key, item, m) = (case f(key, item)
369 :     of NONE => m
370 :     | (SOME item') => insert(m, key, item')
371 :     (* end case *))
372 :     in
373 :     foldli g empty m
374 :     end
375 :    
376 :     (* this is a generic implementation of filter. It should
377 :     * be specialized to the data-structure at some point.
378 :     *)
379 :     fun filter predFn m = let
380 :     fun f (key, item, m) = if predFn item
381 :     then insert(m, key, item)
382 :     else m
383 :     in
384 :     foldli f empty m
385 :     end
386 :     fun filteri predFn m = let
387 :     fun f (key, item, m) = if predFn(key, item)
388 :     then insert(m, key, item)
389 :     else m
390 :     in
391 :     foldli f empty m
392 :     end
393 :    
394 : jhr 4070 (* check the elements of a map with a predicate and return true if
395 :     * any element satisfies the predicate. Return false otherwise.
396 :     * Elements are checked in key order.
397 :     *)
398 :     fun exists pred = let
399 :     fun exists' SplayNil = false
400 :     | exists' (SplayObj{value=(_, x), left, right}) =
401 :     exists' left orelse pred x orelse exists' right
402 :     in
403 :     fn EMPTY => false | (MAP{root, ...}) => exists' (!root)
404 :     end
405 :     fun existsi pred = let
406 :     fun exists' SplayNil = false
407 :     | exists' (SplayObj{value, left, right}) =
408 :     exists' left orelse pred value orelse exists' right
409 :     in
410 :     fn EMPTY => false | (MAP{root, ...}) => exists' (!root)
411 :     end
412 :    
413 :     (* check the elements of a map with a predicate and return true if
414 :     * they all satisfy the predicate. Return false otherwise. Elements
415 :     * are checked in key order.
416 :     *)
417 :     fun all pred = let
418 :     fun all' SplayNil = true
419 :     | all' (SplayObj{value=(_, x), left, right}) =
420 :     all' left andalso pred x andalso all' right
421 :     in
422 :     fn EMPTY => true | (MAP{root, ...}) => all' (!root)
423 :     end
424 :     fun alli pred = let
425 :     fun all' SplayNil = true
426 :     | all' (SplayObj{value, left, right}) = all' left andalso pred value andalso all' right
427 :     in
428 :     fn EMPTY => true | (MAP{root, ...}) => all' (!root)
429 :     end
430 :    
431 : monnier 2 end (* SplayDictFn *)

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