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

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

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