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