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

Annotation of /sml/branches/SMLNJ/src/ml-yacc/src/utils.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 139 - (view) (download)

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

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