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
 [smlnj] / sml / trunk / src / ml-yacc / src / utils.sml

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

Original Path: sml/branches/SMLNJ/src/ml-yacc/src/utils.sml

 1 : monnier 2 (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi 2 : * 3 : * \$Log\$ 4 : monnier 93 * Revision 1.1.1.3 1998/05/12 21:56:22 monnier 5 : monnier 8 * *** empty log message *** 6 : monnier 2 * 7 : monnier 93 * 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 : signature TABLE = 399 : sig 400 : type 'a table 401 : type key 402 : val size : 'a table -> int 403 : val empty: 'a table 404 : val exists: (key * 'a table) -> bool 405 : val find : (key * 'a table) -> 'a option 406 : val insert: ((key * 'a) * 'a table) -> 'a table 407 : val make_table : (key * 'a ) list -> 'a table 408 : val make_list : 'a table -> (key * 'a) list 409 : val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b 410 : end 411 : 412 : functor Table (B : sig type key 413 : val gt : (key * key) -> bool 414 : end 415 : ) : TABLE = 416 : struct 417 : 418 : datatype Color = RED | BLACK 419 : type key = B.key 420 : 421 : abstype 'a table = EMPTY 422 : | TREE of ((B.key * 'a ) * Color * 'a table * 'a table) 423 : with 424 : 425 : val empty = EMPTY 426 : 427 : fun insert(elem as (key,data),t) = 428 : let val key_gt = fn (a,_) => B.gt(key,a) 429 : val key_lt = fn (a,_) => B.gt(a,key) 430 : fun f EMPTY = TREE(elem,RED,EMPTY,EMPTY) 431 : | f (TREE(k,BLACK,l,r)) = 432 : if key_gt k 433 : then case f r 434 : of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) => 435 : (case l 436 : of TREE(lk,RED,ll,lr) => 437 : TREE(k,RED,TREE(lk,BLACK,ll,lr), 438 : TREE(rk,BLACK,rl,rr)) 439 : | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll), 440 : TREE(rk,RED,rlr,rr))) 441 : | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) => 442 : (case l 443 : of TREE(lk,RED,ll,lr) => 444 : TREE(k,RED,TREE(lk,BLACK,ll,lr), 445 : TREE(rk,BLACK,rl,rr)) 446 : | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr)) 447 : | r => TREE(k,BLACK,l,r) 448 : else if key_lt k 449 : then case f l 450 : of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) => 451 : (case r 452 : of TREE(rk,RED,rl,rr) => 453 : TREE(k,RED,TREE(lk,BLACK,ll,lr), 454 : TREE(rk,BLACK,rl,rr)) 455 : | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl), 456 : TREE(k,RED,lrr,r))) 457 : | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) => 458 : (case r 459 : of TREE(rk,RED,rl,rr) => 460 : TREE(k,RED,TREE(lk,BLACK,ll,lr), 461 : TREE(rk,BLACK,rl,rr)) 462 : | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r))) 463 : | l => TREE(k,BLACK,l,r) 464 : else TREE(elem,BLACK,l,r) 465 : | f (TREE(k,RED,l,r)) = 466 : if key_gt k then TREE(k,RED,l, f r) 467 : else if key_lt k then TREE(k,RED, f l, r) 468 : else TREE(elem,RED,l,r) 469 : in case f t 470 : of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r) 471 : | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r) 472 : | t => t 473 : end 474 : 475 : fun exists(key,t) = 476 : let fun look EMPTY = false 477 : | look (TREE((k,_),_,l,r)) = 478 : if B.gt(k,key) then look l 479 : else if B.gt(key,k) then look r 480 : else true 481 : in look t 482 : end 483 : 484 : fun find(key,t) = 485 : let fun look EMPTY = NONE 486 : | look (TREE((k,data),_,l,r)) = 487 : if B.gt(k,key) then look l 488 : else if B.gt(key,k) then look r 489 : else SOME data 490 : in look t 491 : end 492 : 493 : fun fold f t start = 494 : let fun scan(EMPTY,value) = value 495 : | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value))) 496 : in scan(t,start) 497 : end 498 : 499 : fun make_table l = List.foldr insert empty l 500 : 501 : fun size S = fold (fn (_,count) => count+1) S 0 502 : 503 : fun make_list table = fold (op ::) table nil 504 : 505 : end 506 : end; 507 : 508 : (* assumes that a functor Table with signature TABLE from table.sml is 509 : in the environment *) 510 : 511 : signature HASH = 512 : sig 513 : type table 514 : type elem 515 : 516 : val size : table -> int 517 : val add : elem * table -> table 518 : val find : elem * table -> int option 519 : val exists : elem * table -> bool 520 : val empty : table 521 : end 522 : 523 : (* hash: creates a hash table of size n which assigns each distinct member 524 : a unique integer between 0 and n-1 *) 525 : 526 : functor Hash(B : sig type elem 527 : val gt : elem * elem -> bool 528 : end) : HASH = 529 : struct 530 : type elem=B.elem 531 : structure HashTable = Table(type key=B.elem 532 : val gt = B.gt) 533 : 534 : type table = {count : int, table : int HashTable.table} 535 : 536 : val empty = {count=0,table=HashTable.empty} 537 : val size = fn {count,table} => count 538 : val add = fn (e,{count,table}) => 539 : {count=count+1,table=HashTable.insert((e,count),table)} 540 : val find = fn (e,{table,count}) => HashTable.find(e,table) 541 : val exists = fn (e,{table,count}) => HashTable.exists(e,table) 542 : end;