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 29 - (view) (download)
Original Path: sml/branches/SMLNJ/src/smlnj-lib/Util/splay-map-fn.sml

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 :     datatype 'a map =
15 :     EMPTY
16 :     | 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 :    
25 :     (* Insert an item.
26 :     *)
27 :     fun insert (EMPTY,key,v) =
28 :     MAP{nobj=1,root=ref(SplayObj{value=(key,v),left=SplayNil,right=SplayNil})}
29 :     | insert (MAP{root,nobj},key,v) =
30 :     case splay (cmpf key, !root) of
31 :     (EQUAL,SplayObj{value,left,right}) =>
32 :     MAP{nobj=nobj,root=ref(SplayObj{value=(key,v),left=left,right=right})}
33 :     | (LESS,SplayObj{value,left,right}) =>
34 :     MAP{
35 :     nobj=nobj+1,
36 :     root=ref(SplayObj{value=(key,v),left=SplayObj{value=value,left=left,right=SplayNil},right=right})
37 :     }
38 :     | (GREATER,SplayObj{value,left,right}) =>
39 :     MAP{
40 :     nobj=nobj+1,
41 :     root=ref(SplayObj{
42 :     value=(key,v),
43 :     left=left,
44 :     right=SplayObj{value=value,left=SplayNil,right=right}
45 :     })
46 :     }
47 :     | (_,SplayNil) => raise LibBase.Impossible "SplayMapFn.insert SplayNil"
48 : monnier 29 fun insert' ((k, x), m) = insert(m, k, x)
49 : monnier 2
50 :     (* Look for an item, return NONE if the item doesn't exist *)
51 :     fun find (EMPTY,_) = NONE
52 :     | find (MAP{root,nobj},key) = (case splay (cmpf key, !root)
53 :     of (EQUAL, r as SplayObj{value,...}) => (root := r; SOME(#2 value))
54 :     | (_, r) => (root := r; NONE))
55 :    
56 :     (* Remove an item.
57 :     * Raise LibBase.NotFound if not found
58 :     *)
59 :     fun remove (EMPTY, _) = raise LibBase.NotFound
60 :     | remove (MAP{root,nobj}, key) = (case (splay (cmpf key, !root))
61 :     of (EQUAL, SplayObj{value, left, right}) =>
62 :     if nobj = 1
63 :     then (EMPTY, #2 value)
64 :     else (MAP{root=ref(join(left,right)),nobj=nobj-1}, #2 value)
65 :     | (_,r) => (root := r; raise LibBase.NotFound)
66 :     (* end case *))
67 :    
68 :     (* Return the number of items in the table *)
69 :     fun numItems EMPTY = 0
70 :     | numItems (MAP{nobj,...}) = nobj
71 :    
72 :     (* Return a list of the items (and their keys) in the dictionary *)
73 :     fun listItems EMPTY = []
74 :     | listItems (MAP{root,...}) = let
75 :     fun apply (SplayNil, l) = l
76 :     | apply (SplayObj{value=(_, v), left, right}, l) =
77 :     apply(left, v::(apply (right,l)))
78 :     in
79 :     apply (!root, [])
80 :     end
81 :     fun listItemsi EMPTY = []
82 :     | listItemsi (MAP{root,...}) = let
83 :     fun apply (SplayNil,l) = l
84 :     | apply (SplayObj{value,left,right},l) =
85 :     apply(left, value::(apply (right,l)))
86 :     in
87 :     apply (!root,[])
88 :     end
89 :    
90 :     local
91 :     fun next ((t as SplayObj{right, ...})::rest) = (t, left(right, rest))
92 :     | next _ = (SplayNil, [])
93 :     and left (SplayNil, rest) = rest
94 :     | left (t as SplayObj{left=l, ...}, rest) = left(l, t::rest)
95 :     in
96 :     fun collate cmpRng (EMPTY, EMPTY) = EQUAL
97 :     | collate cmpRng (EMPTY, _) = LESS
98 :     | collate cmpRng (_, EMPTY) = GREATER
99 :     | collate cmpRng (MAP{root=s1, ...}, MAP{root=s2, ...}) = let
100 :     fun cmp (t1, t2) = (case (next t1, next t2)
101 :     of ((SplayNil, _), (SplayNil, _)) => EQUAL
102 :     | ((SplayNil, _), _) => LESS
103 :     | (_, (SplayNil, _)) => GREATER
104 :     | ((SplayObj{value=(x1, y1), ...}, r1),
105 :     (SplayObj{value=(x2, y2), ...}, r2)
106 :     ) => (
107 :     case Key.compare(x1, x2)
108 :     of EQUAL => (case cmpRng (y1, y2)
109 :     of EQUAL => cmp (r1, r2)
110 :     | order => order
111 :     (* end case *))
112 :     | order => order
113 :     (* end case *))
114 :     (* end case *))
115 :     in
116 :     cmp (left(!s1, []), left(!s2, []))
117 :     end
118 :     end (* local *)
119 :    
120 :     (* Apply a function to the entries of the dictionary *)
121 :     fun appi af EMPTY = ()
122 :     | appi af (MAP{root,...}) =
123 :     let fun apply SplayNil = ()
124 :     | apply (SplayObj{value,left,right}) =
125 :     (apply left; af value; apply right)
126 :     in
127 :     apply (!root)
128 :     end
129 :    
130 :     fun app af EMPTY = ()
131 :     | app af (MAP{root,...}) =
132 :     let fun apply SplayNil = ()
133 :     | apply (SplayObj{value=(_,value),left,right}) =
134 :     (apply left; af value; apply right)
135 :     in
136 :     apply (!root)
137 :     end
138 :     (*
139 :     fun revapp af (MAP{root,...}) =
140 :     let fun apply SplayNil = ()
141 :     | apply (SplayObj{value,left,right}) =
142 :     (apply right; af value; apply left)
143 :     in
144 :     apply (!root)
145 :     end
146 :     *)
147 :    
148 :     (* Fold function *)
149 :     fun foldri (abf : K.ord_key * 'a * 'b -> 'b) b EMPTY = b
150 :     | foldri (abf : K.ord_key * 'a * 'b -> 'b) b (MAP{root,...}) =
151 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
152 :     | apply (SplayObj{value,left,right},b) =
153 :     apply(left,abf(#1 value,#2 value,apply(right,b)))
154 :     in
155 :     apply (!root,b)
156 :     end
157 :    
158 :     fun foldr (abf : 'a * 'b -> 'b) b EMPTY = b
159 :     | foldr (abf : 'a * 'b -> 'b) b (MAP{root,...}) =
160 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
161 :     | apply (SplayObj{value=(_,value),left,right},b) =
162 :     apply(left,abf(value,apply(right,b)))
163 :     in
164 :     apply (!root,b)
165 :     end
166 :    
167 :     fun foldli (abf : K.ord_key * 'a * 'b -> 'b) b EMPTY = b
168 :     | foldli (abf : K.ord_key * 'a * 'b -> 'b) b (MAP{root,...}) =
169 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
170 :     | apply (SplayObj{value,left,right},b) =
171 :     apply(right,abf(#1 value,#2 value,apply(left,b)))
172 :     in
173 :     apply (!root,b)
174 :     end
175 :    
176 :     fun foldl (abf : 'a * 'b -> 'b) b EMPTY = b
177 :     | foldl (abf : 'a * 'b -> 'b) b (MAP{root,...}) =
178 :     let fun apply (SplayNil : (K.ord_key * 'a) splay, b) = b
179 :     | apply (SplayObj{value=(_,value),left,right},b) =
180 :     apply(right,abf(value,apply(left,b)))
181 :     in
182 :     apply (!root,b)
183 :     end
184 :    
185 :     (* Map a table to a new table that has the same keys*)
186 :     fun mapi (af : K.ord_key * 'a -> 'b) EMPTY = EMPTY
187 :     | mapi (af : K.ord_key * 'a -> 'b) (MAP{root,nobj}) =
188 :     let fun ap (SplayNil : (K.ord_key * 'a) splay) = SplayNil
189 :     | ap (SplayObj{value,left,right}) = let
190 :     val left' = ap left
191 :     val value' = (#1 value, af value)
192 :     in
193 :     SplayObj{value = value', left = left', right = ap right}
194 :     end
195 :     in
196 :     MAP{root = ref(ap (!root)), nobj = nobj}
197 :     end
198 :    
199 :     fun map (af : 'a -> 'b) EMPTY = EMPTY
200 :     | map (af : 'a -> 'b) (MAP{root,nobj}) =
201 :     let fun ap (SplayNil : (K.ord_key * 'a) splay) = SplayNil
202 :     | ap (SplayObj{value,left,right}) = let
203 :     val left' = ap left
204 :     val value' = (#1 value, af (#2 value))
205 :     in
206 :     SplayObj{value = value', left = left', right = ap right}
207 :     end
208 :     in
209 :     MAP{root = ref(ap (!root)), nobj = nobj}
210 :     end
211 :    
212 :     (* the following are generic implementations of the unionWith and intersectWith
213 :     * operetions. These should be specialized for the internal representations
214 :     * at some point.
215 :     *)
216 :     fun unionWith f (m1, m2) = let
217 :     fun ins f (key, x, m) = (case find(m, key)
218 :     of NONE => insert(m, key, x)
219 :     | (SOME x') => insert(m, key, f(x, x'))
220 :     (* end case *))
221 :     in
222 :     if (numItems m1 > numItems m2)
223 :     then foldli (ins (fn (a, b) => f(b, a))) m1 m2
224 :     else foldli (ins f) m2 m1
225 :     end
226 :     fun unionWithi f (m1, m2) = let
227 :     fun ins f (key, x, m) = (case find(m, key)
228 :     of NONE => insert(m, key, x)
229 :     | (SOME x') => insert(m, key, f(key, x, x'))
230 :     (* end case *))
231 :     in
232 :     if (numItems m1 > numItems m2)
233 :     then foldli (ins (fn (k, a, b) => f(k, b, a))) m1 m2
234 :     else foldli (ins f) m2 m1
235 :     end
236 :    
237 :     fun intersectWith f (m1, m2) = let
238 :     (* iterate over the elements of m1, checking for membership in m2 *)
239 :     fun intersect f (m1, m2) = let
240 :     fun ins (key, x, m) = (case find(m2, key)
241 :     of NONE => m
242 :     | (SOME x') => insert(m, key, f(x, x'))
243 :     (* end case *))
244 :     in
245 :     foldli ins empty m1
246 :     end
247 :     in
248 :     if (numItems m1 > numItems m2)
249 :     then intersect f (m1, m2)
250 :     else intersect (fn (a, b) => f(b, a)) (m2, m1)
251 :     end
252 :    
253 :     fun intersectWithi f (m1, m2) = let
254 :     (* iterate over the elements of m1, checking for membership in m2 *)
255 :     fun intersect f (m1, m2) = let
256 :     fun ins (key, x, m) = (case find(m2, key)
257 :     of NONE => m
258 :     | (SOME x') => insert(m, key, f(key, x, x'))
259 :     (* end case *))
260 :     in
261 :     foldli ins empty m1
262 :     end
263 :     in
264 :     if (numItems m1 > numItems m2)
265 :     then intersect f (m1, m2)
266 :     else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1)
267 :     end
268 :    
269 :     (* this is a generic implementation of mapPartial. It should
270 :     * be specialized to the data-structure at some point.
271 :     *)
272 :     fun mapPartial f m = let
273 :     fun g (key, item, m) = (case f item
274 :     of NONE => m
275 :     | (SOME item') => insert(m, key, item')
276 :     (* end case *))
277 :     in
278 :     foldli g empty m
279 :     end
280 :     fun mapPartiali f m = let
281 :     fun g (key, item, m) = (case f(key, item)
282 :     of NONE => m
283 :     | (SOME item') => insert(m, key, item')
284 :     (* end case *))
285 :     in
286 :     foldli g empty m
287 :     end
288 :    
289 :     (* this is a generic implementation of filter. It should
290 :     * be specialized to the data-structure at some point.
291 :     *)
292 :     fun filter predFn m = let
293 :     fun f (key, item, m) = if predFn item
294 :     then insert(m, key, item)
295 :     else m
296 :     in
297 :     foldli f empty m
298 :     end
299 :     fun filteri predFn m = let
300 :     fun f (key, item, m) = if predFn(key, item)
301 :     then insert(m, key, item)
302 :     else m
303 :     in
304 :     foldli f empty m
305 :     end
306 :    
307 :     end (* SplayDictFn *)

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