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 2980 - (view) (download)

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

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