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/trunk/src/ml-yacc/src/utils.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-yacc/src/utils.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 168 - (view) (download)

1 : monnier 2 (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi
2 :     *
3 :     * $Log$
4 : monnier 167 * Revision 1.1.1.6 1998/11/07 20:11:15 monnier
5 :     * version $version
6 : monnier 2 *
7 : monnier 139 * Revision 1.1.1.1 1998/04/08 18:40:17 george
8 :     * Version 110.5
9 :     *
10 : monnier 8 * Revision 1.1.1.1 1997/01/14 01:38:06 george
11 :     * Version 109.24
12 :     *
13 : monnier 2 * Revision 1.1.1.1 1996/01/31 16:01:47 george
14 :     * Version 109
15 :     *
16 :     *)
17 :    
18 :     (* Implementation of ordered sets using ordered lists and red-black trees. The
19 :     code for red-black trees was originally written by Norris Boyd, which was
20 :     modified for use here.
21 :     *)
22 :    
23 :     (* ordered sets implemented using ordered lists.
24 :    
25 :     Upper bound running times for functions implemented here:
26 :    
27 :     app = O(n)
28 :     card = O(n)
29 :     closure = O(n^2)
30 :     difference = O(n+m), where n,m = the size of the two sets used here.
31 :     empty = O(1)
32 :     exists = O(n)
33 :     find = O(n)
34 :     fold = O(n)
35 :     insert = O(n)
36 :     is_empty = O(1)
37 :     make_list = O(1)
38 :     make_set = O(n^2)
39 :     partition = O(n)
40 :     remove = O(n)
41 :     revfold = O(n)
42 :     select_arb = O(1)
43 :     set_eq = O(n), where n = the cardinality of the smaller set
44 :     set_gt = O(n), ditto
45 :     singleton = O(1)
46 :     union = O(n+m)
47 :     *)
48 :    
49 :     functor ListOrdSet(B : sig type elem
50 :     val gt : elem * elem -> bool
51 :     val eq : elem * elem -> bool
52 :     end ) : ORDSET =
53 :    
54 :     struct
55 :     type elem = B.elem
56 :     val elem_gt = B.gt
57 :     val elem_eq = B.eq
58 :    
59 :     type set = elem list
60 :     exception Select_arb
61 :     val empty = nil
62 :    
63 :     val insert = fn (key,s) =>
64 :     let fun f (l as (h::t)) =
65 :     if elem_gt(key,h) then h::(f t)
66 :     else if elem_eq(key,h) then key::t
67 :     else key::l
68 :     | f nil = [key]
69 :     in f s
70 :     end
71 :    
72 :     val select_arb = fn nil => raise Select_arb
73 :     | a::b => a
74 :    
75 :     val exists = fn (key,s) =>
76 :     let fun f (h::t) = if elem_gt(key,h) then f t
77 :     else elem_eq(h,key)
78 :     | f nil = false
79 :     in f s
80 :     end
81 :    
82 :     val find = fn (key,s) =>
83 :     let fun f (h::t) = if elem_gt(key,h) then f t
84 :     else if elem_eq(h,key) then SOME h
85 :     else NONE
86 :     | f nil = NONE
87 :     in f s
88 :     end
89 :    
90 :     fun revfold f lst init = List.foldl f init lst
91 :     fun fold f lst init = List.foldr f init lst
92 :     val app = List.app
93 :    
94 :     fun set_eq(h::t,h'::t') =
95 :     (case elem_eq(h,h')
96 :     of true => set_eq(t,t')
97 :     | a => a)
98 :     | set_eq(nil,nil) = true
99 :     | set_eq _ = false
100 :    
101 :     fun set_gt(h::t,h'::t') =
102 :     (case elem_gt(h,h')
103 :     of false => (case (elem_eq(h,h'))
104 :     of true => set_gt(t,t')
105 :     | a => a)
106 :     | a => a)
107 :     | set_gt(_::_,nil) = true
108 :     | set_gt _ = false
109 :    
110 :     fun union(a as (h::t),b as (h'::t')) =
111 :     if elem_gt(h',h) then h::union(t,b)
112 :     else if elem_eq(h,h') then h::union(t,t')
113 :     else h'::union(a,t')
114 :     | union(nil,s) = s
115 :     | union(s,nil) = s
116 :    
117 :     val make_list = fn s => s
118 :    
119 :     val is_empty = fn nil => true | _ => false
120 :    
121 :     val make_set = fn l => List.foldr insert [] l
122 :    
123 :     val partition = fn f => fn s =>
124 :     fold (fn (e,(yes,no)) =>
125 :     if (f e) then (e::yes,no) else (e::no,yes)) s (nil,nil)
126 :    
127 :     val remove = fn (e,s) =>
128 :     let fun f (l as (h::t)) = if elem_gt(h,e) then l
129 :     else if elem_eq(h,e) then t
130 :     else h::(f t)
131 :     | f nil = nil
132 :     in f s
133 :     end
134 :    
135 :     (* difference: X-Y *)
136 :    
137 :     fun difference (nil,_) = nil
138 :     | difference (r,nil) = r
139 :     | difference (a as (h::t),b as (h'::t')) =
140 :     if elem_gt (h',h) then h::difference(t,b)
141 :     else if elem_eq(h',h) then difference(t,t')
142 :     else difference(a,t')
143 :    
144 :     fun singleton X = [X]
145 :    
146 :     fun card(S) = fold (fn (a,count) => count+1) S 0
147 :    
148 :     local
149 :     fun closure'(from, f, result) =
150 :     if is_empty from then result
151 :     else
152 :     let val (more,result) =
153 :     fold (fn (a,(more',result')) =>
154 :     let val more = f a
155 :     val new = difference(more,result)
156 :     in (union(more',new),union(result',new))
157 :     end) from
158 :     (empty,result)
159 :     in closure'(more,f,result)
160 :     end
161 :     in
162 :     fun closure(start, f) = closure'(start, f, start)
163 :     end
164 :     end
165 :    
166 :     (* ordered set implemented using red-black trees:
167 :    
168 :     Upper bound running time of the functions below:
169 :    
170 :     app: O(n)
171 :     card: O(n)
172 :     closure: O(n^2 ln n)
173 :     difference: O(n ln n)
174 :     empty: O(1)
175 :     exists: O(ln n)
176 :     find: O(ln n)
177 :     fold: O(n)
178 :     insert: O(ln n)
179 :     is_empty: O(1)
180 :     make_list: O(n)
181 :     make_set: O(n ln n)
182 :     partition: O(n ln n)
183 :     remove: O(n ln n)
184 :     revfold: O(n)
185 :     select_arb: O(1)
186 :     set_eq: O(n)
187 :     set_gt: O(n)
188 :     singleton: O(1)
189 :     union: O(n ln n)
190 :     *)
191 :    
192 :     functor RbOrdSet (B : sig type elem
193 :     val eq : (elem*elem) -> bool
194 :     val gt : (elem*elem) -> bool
195 :     end
196 :     ) : ORDSET =
197 :     struct
198 :    
199 :     type elem = B.elem
200 :     val elem_gt = B.gt
201 :     val elem_eq = B.eq
202 :    
203 :     datatype Color = RED | BLACK
204 :    
205 :     abstype set = EMPTY | TREE of (B.elem * Color * set * set)
206 :     with exception Select_arb
207 :     val empty = EMPTY
208 :    
209 :     fun insert(key,t) =
210 :     let fun f EMPTY = TREE(key,RED,EMPTY,EMPTY)
211 :     | f (TREE(k,BLACK,l,r)) =
212 :     if elem_gt (key,k)
213 :     then case f r
214 :     of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
215 :     (case l
216 :     of TREE(lk,RED,ll,lr) =>
217 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
218 :     TREE(rk,BLACK,rl,rr))
219 :     | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
220 :     TREE(rk,RED,rlr,rr)))
221 :     | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
222 :     (case l
223 :     of TREE(lk,RED,ll,lr) =>
224 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
225 :     TREE(rk,BLACK,rl,rr))
226 :     | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
227 :     | r => TREE(k,BLACK,l,r)
228 :     else if elem_gt(k,key)
229 :     then case f l
230 :     of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
231 :     (case r
232 :     of TREE(rk,RED,rl,rr) =>
233 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
234 :     TREE(rk,BLACK,rl,rr))
235 :     | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
236 :     TREE(k,RED,lrr,r)))
237 :     | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
238 :     (case r
239 :     of TREE(rk,RED,rl,rr) =>
240 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
241 :     TREE(rk,BLACK,rl,rr))
242 :     | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
243 :     | l => TREE(k,BLACK,l,r)
244 :     else TREE(key,BLACK,l,r)
245 :     | f (TREE(k,RED,l,r)) =
246 :     if elem_gt(key,k) then TREE(k,RED,l, f r)
247 :     else if elem_gt(k,key) then TREE(k,RED, f l, r)
248 :     else TREE(key,RED,l,r)
249 :     in case f t
250 :     of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
251 :     | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
252 :     | t => t
253 :     end
254 :    
255 :     fun select_arb (TREE(k,_,l,r)) = k
256 :     | select_arb EMPTY = raise Select_arb
257 :    
258 :     fun exists(key,t) =
259 :     let fun look EMPTY = false
260 :     | look (TREE(k,_,l,r)) =
261 :     if elem_gt(k,key) then look l
262 :     else if elem_gt(key,k) then look r
263 :     else true
264 :     in look t
265 :     end
266 :    
267 :     fun find(key,t) =
268 :     let fun look EMPTY = NONE
269 :     | look (TREE(k,_,l,r)) =
270 :     if elem_gt(k,key) then look l
271 :     else if elem_gt(key,k) then look r
272 :     else SOME k
273 :     in look t
274 :     end
275 :    
276 :     fun revfold f t start =
277 :     let fun scan (EMPTY,value) = value
278 :     | scan (TREE(k,_,l,r),value) = scan(r,f(k,scan(l,value)))
279 :     in scan(t,start)
280 :     end
281 :    
282 :     fun fold f t start =
283 :     let fun scan(EMPTY,value) = value
284 :     | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
285 :     in scan(t,start)
286 :     end
287 :    
288 :     fun app f t =
289 :     let fun scan EMPTY = ()
290 :     | scan(TREE(k,_,l,r)) = (scan l; f k; scan r)
291 :     in scan t
292 :     end
293 :    
294 :     (* equal_tree : test if two trees are equal. Two trees are equal if
295 :     the set of leaves are equal *)
296 :    
297 :     fun set_eq (tree1 as (TREE _),tree2 as (TREE _)) =
298 :     let datatype pos = L | R | M
299 :     exception Done
300 :     fun getvalue(stack as ((a,position)::b)) =
301 :     (case a
302 :     of (TREE(k,_,l,r)) =>
303 :     (case position
304 :     of L => getvalue ((l,L)::(a,M)::b)
305 :     | M => (k,case r of EMPTY => b | _ => (a,R)::b)
306 :     | R => getvalue ((r,L)::b)
307 :     )
308 :     | EMPTY => getvalue b
309 :     )
310 :     | getvalue(nil) = raise Done
311 :     fun f (nil,nil) = true
312 :     | f (s1 as (_ :: _),s2 as (_ :: _ )) =
313 :     let val (v1,news1) = getvalue s1
314 :     and (v2,news2) = getvalue s2
315 :     in (elem_eq(v1,v2)) andalso f(news1,news2)
316 :     end
317 :     | f _ = false
318 :     in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
319 :     end
320 :     | set_eq (EMPTY,EMPTY) = true
321 :     | set_eq _ = false
322 :    
323 :     (* gt_tree : Test if tree1 is greater than tree 2 *)
324 :    
325 :     fun set_gt (tree1,tree2) =
326 :     let datatype pos = L | R | M
327 :     exception Done
328 :     fun getvalue(stack as ((a,position)::b)) =
329 :     (case a
330 :     of (TREE(k,_,l,r)) =>
331 :     (case position
332 :     of L => getvalue ((l,L)::(a,M)::b)
333 :     | M => (k,case r of EMPTY => b | _ => (a,R)::b)
334 :     | R => getvalue ((r,L)::b)
335 :     )
336 :     | EMPTY => getvalue b
337 :     )
338 :     | getvalue(nil) = raise Done
339 :     fun f (nil,nil) = false
340 :     | f (s1 as (_ :: _),s2 as (_ :: _ )) =
341 :     let val (v1,news1) = getvalue s1
342 :     and (v2,news2) = getvalue s2
343 :     in (elem_gt(v1,v2)) orelse (elem_eq(v1,v2) andalso f(news1,news2))
344 :     end
345 :     | f (_,nil) = true
346 :     | f (nil,_) = false
347 :     in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false
348 :     end
349 :    
350 :     fun is_empty S = (let val _ = select_arb S in false end
351 :     handle Select_arb => true)
352 :    
353 :     fun make_list S = fold (op ::) S nil
354 :    
355 :     fun make_set l = List.foldr insert empty l
356 :    
357 :     fun partition F S = fold (fn (a,(Yes,No)) =>
358 :     if F(a) then (insert(a,Yes),No)
359 :     else (Yes,insert(a,No)))
360 :     S (empty,empty)
361 :    
362 :     fun remove(X, XSet) =
363 :     let val (YSet, _) =
364 :     partition (fn a => not (elem_eq (X, a))) XSet
365 :     in YSet
366 :     end
367 :    
368 :     fun difference(Xs, Ys) =
369 :     fold (fn (p as (a,Xs')) =>
370 :     if exists(a,Ys) then Xs' else insert p)
371 :     Xs empty
372 :    
373 :     fun singleton X = insert(X,empty)
374 :    
375 :     fun card(S) = fold (fn (_,count) => count+1) S 0
376 :    
377 :     fun union(Xs,Ys)= fold insert Ys Xs
378 :    
379 :     local
380 :     fun closure'(from, f, result) =
381 :     if is_empty from then result
382 :     else
383 :     let val (more,result) =
384 :     fold (fn (a,(more',result')) =>
385 :     let val more = f a
386 :     val new = difference(more,result)
387 :     in (union(more',new),union(result',new))
388 :     end) from
389 :     (empty,result)
390 :     in closure'(more,f,result)
391 :     end
392 :     in
393 :     fun closure(start, f) = closure'(start, f, start)
394 :     end
395 :     end
396 :     end
397 :    
398 : monnier 139 (* In utils.sig
399 : monnier 2 signature TABLE =
400 :     sig
401 :     type 'a table
402 :     type key
403 :     val size : 'a table -> int
404 :     val empty: 'a table
405 :     val exists: (key * 'a table) -> bool
406 :     val find : (key * 'a table) -> 'a option
407 :     val insert: ((key * 'a) * 'a table) -> 'a table
408 :     val make_table : (key * 'a ) list -> 'a table
409 :     val make_list : 'a table -> (key * 'a) list
410 :     val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b
411 :     end
412 : monnier 139 *)
413 : monnier 2
414 :     functor Table (B : sig type key
415 :     val gt : (key * key) -> bool
416 :     end
417 :     ) : TABLE =
418 :     struct
419 :    
420 :     datatype Color = RED | BLACK
421 :     type key = B.key
422 :    
423 :     abstype 'a table = EMPTY
424 :     | TREE of ((B.key * 'a ) * Color * 'a table * 'a table)
425 :     with
426 :    
427 :     val empty = EMPTY
428 :    
429 :     fun insert(elem as (key,data),t) =
430 :     let val key_gt = fn (a,_) => B.gt(key,a)
431 :     val key_lt = fn (a,_) => B.gt(a,key)
432 :     fun f EMPTY = TREE(elem,RED,EMPTY,EMPTY)
433 :     | f (TREE(k,BLACK,l,r)) =
434 :     if key_gt k
435 :     then case f r
436 :     of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) =>
437 :     (case l
438 :     of TREE(lk,RED,ll,lr) =>
439 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
440 :     TREE(rk,BLACK,rl,rr))
441 :     | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll),
442 :     TREE(rk,RED,rlr,rr)))
443 :     | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) =>
444 :     (case l
445 :     of TREE(lk,RED,ll,lr) =>
446 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
447 :     TREE(rk,BLACK,rl,rr))
448 :     | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr))
449 :     | r => TREE(k,BLACK,l,r)
450 :     else if key_lt k
451 :     then case f l
452 :     of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) =>
453 :     (case r
454 :     of TREE(rk,RED,rl,rr) =>
455 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
456 :     TREE(rk,BLACK,rl,rr))
457 :     | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl),
458 :     TREE(k,RED,lrr,r)))
459 :     | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) =>
460 :     (case r
461 :     of TREE(rk,RED,rl,rr) =>
462 :     TREE(k,RED,TREE(lk,BLACK,ll,lr),
463 :     TREE(rk,BLACK,rl,rr))
464 :     | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r)))
465 :     | l => TREE(k,BLACK,l,r)
466 :     else TREE(elem,BLACK,l,r)
467 :     | f (TREE(k,RED,l,r)) =
468 :     if key_gt k then TREE(k,RED,l, f r)
469 :     else if key_lt k then TREE(k,RED, f l, r)
470 :     else TREE(elem,RED,l,r)
471 :     in case f t
472 :     of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r)
473 :     | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r)
474 :     | t => t
475 :     end
476 :    
477 :     fun exists(key,t) =
478 :     let fun look EMPTY = false
479 :     | look (TREE((k,_),_,l,r)) =
480 :     if B.gt(k,key) then look l
481 :     else if B.gt(key,k) then look r
482 :     else true
483 :     in look t
484 :     end
485 :    
486 :     fun find(key,t) =
487 :     let fun look EMPTY = NONE
488 :     | look (TREE((k,data),_,l,r)) =
489 :     if B.gt(k,key) then look l
490 :     else if B.gt(key,k) then look r
491 :     else SOME data
492 :     in look t
493 :     end
494 :    
495 :     fun fold f t start =
496 :     let fun scan(EMPTY,value) = value
497 :     | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value)))
498 :     in scan(t,start)
499 :     end
500 :    
501 :     fun make_table l = List.foldr insert empty l
502 :    
503 :     fun size S = fold (fn (_,count) => count+1) S 0
504 :    
505 :     fun make_list table = fold (op ::) table nil
506 :    
507 :     end
508 :     end;
509 :    
510 :     (* assumes that a functor Table with signature TABLE from table.sml is
511 :     in the environment *)
512 :    
513 : monnier 139 (* In utils.sig
514 : monnier 2 signature HASH =
515 :     sig
516 :     type table
517 :     type elem
518 :    
519 :     val size : table -> int
520 :     val add : elem * table -> table
521 :     val find : elem * table -> int option
522 :     val exists : elem * table -> bool
523 :     val empty : table
524 :     end
525 : monnier 139 *)
526 : monnier 2
527 :     (* hash: creates a hash table of size n which assigns each distinct member
528 :     a unique integer between 0 and n-1 *)
529 :    
530 :     functor Hash(B : sig type elem
531 :     val gt : elem * elem -> bool
532 :     end) : HASH =
533 :     struct
534 :     type elem=B.elem
535 :     structure HashTable = Table(type key=B.elem
536 :     val gt = B.gt)
537 :    
538 :     type table = {count : int, table : int HashTable.table}
539 :    
540 :     val empty = {count=0,table=HashTable.empty}
541 :     val size = fn {count,table} => count
542 :     val add = fn (e,{count,table}) =>
543 :     {count=count+1,table=HashTable.insert((e,count),table)}
544 :     val find = fn (e,{table,count}) => HashTable.find(e,table)
545 :     val exists = fn (e,{table,count}) => HashTable.exists(e,table)
546 :     end;

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