lib.ml

   1 (* ========================================================================= *)
   2 (* Convenient library functions.                                             *)
   3 (*                                                                           *)
   4 (*       John Harrison, University of Cambridge Computer Laboratory          *)
   5 (*                                                                           *)
   6 (*            (c) Copyright, University of Cambridge 1998                    *)
   7 (*              (c) Copyright, John Harrison 1998-2007                       *)
   8 (* ========================================================================= *)
   9
  10 let fail() = failwith "";;
  11
  12 (* ------------------------------------------------------------------------- *)
  13 (* Combinators.                                                              *)
  14 (* ------------------------------------------------------------------------- *)
  15
  16 let curry f x y = f(x,y);;
  17
  18 let uncurry f(x,y) = f x y;;
  19
  20 let I x = x;;
  21
  22 let K x y = x;;
  23
  24 let C f x y = f y x;;
  25
  26 let W f x = f x x;;
  27
  28 let (o) = fun f g x -> f(g x);;
  29
  30 let (F_F) = fun f g (x,y) -> (f x,g y);;
  31
  32 (* ------------------------------------------------------------------------- *)
  33 (* List basics.                                                              *)
  34 (* ------------------------------------------------------------------------- *)
  35
  36 let hd l =
  37   match l with
  38    h::t -> h
  39   | _ -> failwith "hd";;
  40
  41 let tl l =
  42   match l with
  43    h::t -> t
  44   | _ -> failwith "tl";;
  45
  46 let map f =
  47   let rec mapf l =
  48     match l with
  49       [] -> []
  50     | (x::t) -> let y = f x in y::(mapf t) in
  51   mapf;;
  52
  53 let rec last l =
  54   match l with
  55     [x] -> x
  56   | (h::t) -> last t
  57   | [] -> failwith "last";;
  58
  59 let rec butlast l =
  60   match l with
  61     [_] -> []
  62   | (h::t) -> h::(butlast t)
  63   | [] -> failwith "butlast";;
  64
  65 let rec el n l =
  66   if n = 0 then hd l else el (n - 1) (tl l);;
  67
  68 let rev =
  69   let rec rev_append acc l =
  70     match l with
  71       [] -> acc
  72     | h::t -> rev_append (h::acc) t in
  73   fun l -> rev_append [] l;;
  74
  75 let rec map2 f l1 l2 =
  76   match (l1,l2) with
  77     [],[] -> []
  78   | (h1::t1),(h2::t2) -> let h = f h1 h2 in h::(map2 f t1 t2)
  79   | _ -> failwith "map2: length mismatch";;
  80
  81 (* ------------------------------------------------------------------------- *)
  82 (* Attempting function or predicate applications.                            *)
  83 (* ------------------------------------------------------------------------- *)
  84
  85 let can f x = try (f x; true) with Failure _ -> false;;
  86
  87 let check p x = if p x then x else failwith "check";;
  88
  89 (* ------------------------------------------------------------------------- *)
  90 (* Repetition of a function.                                                 *)
  91 (* ------------------------------------------------------------------------- *)
  92
  93 let rec funpow n f x =
  94   if n < 1 then x else funpow (n-1) f (f x);;
  95
  96 let rec repeat f x =
  97   try let y = f x in repeat f y with Failure _ -> x;;
  98
  99 (* ------------------------------------------------------------------------- *)
 100 (* To avoid consing in various situations, we propagate this exception.      *)
 101 (* I should probably eliminate this and use pointer EQ tests instead.        *)
 102 (* ------------------------------------------------------------------------- *)
 103
 104 exception Unchanged;;
 105
 106 (* ------------------------------------------------------------------------- *)
 107 (* Various versions of list iteration.                                       *)
 108 (* ------------------------------------------------------------------------- *)
 109
 110 let rec itlist f l b =
 111   match l with
 112     [] -> b
 113   | (h::t) -> f h (itlist f t b);;
 114
 115 let rec rev_itlist f l b =
 116   match l with
 117     [] -> b
 118   | (h::t) -> rev_itlist f t (f h b);;
 119
 120 let rec end_itlist f l =
 121   match l with
 122         []     -> failwith "end_itlist"
 123       | [x]    -> x
 124       | (h::t) -> f h (end_itlist f t);;
 125
 126 let rec itlist2 f l1 l2 b =
 127   match (l1,l2) with
 128     ([],[]) -> b
 129   | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
 130   | _ -> failwith "itlist2";;
 131
 132 let rec rev_itlist2 f l1 l2 b =
 133    match (l1,l2) with
 134      ([],[]) -> b
 135    | (h1::t1,h2::t2) -> rev_itlist2 f t1 t2 (f h1 h2 b)
 136       | _ -> failwith "rev_itlist2";;
 137
 138 (* ------------------------------------------------------------------------- *)
 139 (* Iterative splitting (list) and stripping (tree) via destructor.           *)
 140 (* ------------------------------------------------------------------------- *)
 141
 142 let rec splitlist dest x =
 143   try let l,r = dest x in
 144       let ls,res = splitlist dest r in
 145       (l::ls,res)
 146   with Failure _ -> ([],x);;
 147
 148 let rev_splitlist dest =
 149   let rec rsplist ls x =
 150     try let l,r = dest x in
 151         rsplist (r::ls) l
 152     with Failure _ -> (x,ls) in
 153   fun x -> rsplist [] x;;
 154
 155 let striplist dest =
 156   let rec strip x acc =
 157     try let l,r = dest x in
 158         strip l (strip r acc)
 159     with Failure _ -> x::acc in
 160   fun x -> strip x [];;
 161
 162 (* ------------------------------------------------------------------------- *)
 163 (* Apply a destructor as many times as elements in list.                     *)
 164 (* ------------------------------------------------------------------------- *)
 165
 166 let rec nsplit dest clist x =
 167   if clist = [] then [],x else
 168   let l,r = dest x in
 169   let ll,y = nsplit dest (tl clist) r in
 170   l::ll,y;;
 171
 172 (* ------------------------------------------------------------------------- *)
 173 (* Replication and sequences.                                                *)
 174 (* ------------------------------------------------------------------------- *)
 175
 176 let rec replicate x n =
 177     if n < 1 then []
 178     else x::(replicate x (n - 1));;
 179
 180 let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
 181
 182 (* ------------------------------------------------------------------------- *)
 183 (* Various useful list operations.                                           *)
 184 (* ------------------------------------------------------------------------- *)
 185
 186 let rec forall p l =
 187   match l with
 188     [] -> true
 189   | h::t -> p(h) & forall p t;;
 190
 191 let rec forall2 p l1 l2 =
 192   match (l1,l2) with
 193     [],[] -> true
 194   | (h1::t1,h2::t2) -> p h1 h2 & forall2 p t1 t2
 195   | _ -> false;;
 196
 197 let rec exists p l =
 198   match l with
 199     [] -> false
 200   | h::t -> p(h) or exists p t;;
 201
 202 let length =
 203   let rec len k l =
 204     if l = [] then k else len (k + 1) (tl l) in
 205   fun l -> len 0 l;;
 206
 207 let rec filter p l =
 208   match l with
 209     [] -> l
 210   | h::t -> let t' = filter p t in
 211             if p(h) then if t'==t then l else h::t'
 212             else t';;
 213
 214 let rec partition p l =
 215   match l with
 216     [] -> [],l
 217   | h::t -> let yes,no = partition p t in
 218             if p(h) then (if yes == t then l,[] else h::yes,no)
 219             else (if no == t then [],l else yes,h::no);;
 220
 221 let rec mapfilter f l =
 222   match l with
 223     [] -> []
 224   | (h::t) -> let rest = mapfilter f t in
 225               try (f h)::rest with Failure _ -> rest;;
 226
 227 let rec find p l =
 228   match l with
 229       [] -> failwith "find"
 230     | (h::t) -> if p(h) then h else find p t;;
 231
 232 let rec tryfind f l =
 233   match l with
 234       [] -> failwith "tryfind"
 235     | (h::t) -> try f h with Failure _ -> tryfind f t;;
 236
 237 let flat l = itlist (@) l [];;
 238
 239 let rec remove p l =
 240   match l with
 241     [] -> failwith "remove"
 242   | (h::t) -> if p(h) then h,t else
 243               let y,n = remove p t in y,h::n;;
 244
 245 let rec chop_list n l =
 246   if n = 0 then [],l else
 247   try let m,l' = chop_list (n-1) (tl l) in (hd l)::m,l'
 248   with Failure _ -> failwith "chop_list";;
 249
 250 let index x =
 251   let rec ind n l =
 252     match l with
 253       [] -> failwith "index"
 254     | (h::t) -> if Pervasives.compare x h = 0 then n else ind (n + 1) t in
 255   ind 0;;
 256
 257 (* ------------------------------------------------------------------------- *)
 258 (* "Set" operations on lists.                                                *)
 259 (* ------------------------------------------------------------------------- *)
 260
 261 let rec mem x lis =
 262   match lis with
 263     [] -> false
 264   | (h::t) -> Pervasives.compare x h = 0 or mem x t;;
 265
 266 let insert x l =
 267   if mem x l then l else x::l;;
 268
 269 let union l1 l2 = itlist insert l1 l2;;
 270
 271 let unions l = itlist union l [];;
 272
 273 let intersect l1 l2 = filter (fun x -> mem x l2) l1;;
 274
 275 let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
 276
 277 let subset l1 l2 = forall (fun t -> mem t l2) l1;;
 278
 279 let set_eq l1 l2 = subset l1 l2 & subset l2 l1;;
 280
 281 (* ------------------------------------------------------------------------- *)
 282 (* Association lists.                                                        *)
 283 (* ------------------------------------------------------------------------- *)
 284
 285 let rec assoc a l =
 286   match l with
 287     (x,y)::t -> if Pervasives.compare x a = 0 then y else assoc a t
 288   | [] -> failwith "find";;
 289
 290 let rec rev_assoc a l =
 291   match l with
 292     (x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assoc a t
 293   | [] -> failwith "find";;
 294
 295 (* ------------------------------------------------------------------------- *)
 296 (* Zipping, unzipping etc.                                                   *)
 297 (* ------------------------------------------------------------------------- *)
 298
 299 let rec zip l1 l2 =
 300   match (l1,l2) with
 301         ([],[]) -> []
 302       | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
 303       | _ -> failwith "zip";;
 304
 305 let rec unzip =
 306   function [] -> [],[]
 307          | ((a,b)::rest) -> let alist,blist = unzip rest in
 308                             (a::alist,b::blist);;
 309
 310 (* ------------------------------------------------------------------------- *)
 311 (* Sharing out a list according to pattern in list-of-lists.                 *)
 312 (* ------------------------------------------------------------------------- *)
 313
 314 let rec shareout pat all =
 315   if pat = [] then [] else
 316   let l,r = chop_list (length (hd pat)) all in
 317   l::(shareout (tl pat) r);;
 318
 319 (* ------------------------------------------------------------------------- *)
 320 (* Iterating functions over lists.                                           *)
 321 (* ------------------------------------------------------------------------- *)
 322
 323 let rec do_list f l =
 324   match l with
 325     [] -> ()
 326   | (h::t) -> (f h; do_list f t);;
 327
 328 (* ------------------------------------------------------------------------- *)
 329 (* Sorting.                                                                  *)
 330 (* ------------------------------------------------------------------------- *)
 331
 332 let rec sort cmp lis =
 333   match lis with
 334     [] -> []
 335   | piv::rest ->
 336       let r,l = partition (cmp piv) rest in
 337       (sort cmp l) @ (piv::(sort cmp r));;
 338
 339 (* ------------------------------------------------------------------------- *)
 340 (* Removing adjacent (NB!) equal elements from list.                         *)
 341 (* ------------------------------------------------------------------------- *)
 342
 343 let rec uniq l =
 344   match l with
 345     x::(y::_ as t) -> let t' = uniq t in
 346                       if Pervasives.compare x y = 0 then t' else
 347                       if t'==t then l else x::t'
 348  | _ -> l;;
 349
 350 (* ------------------------------------------------------------------------- *)
 351 (* Convert list into set by eliminating duplicates.                          *)
 352 (* ------------------------------------------------------------------------- *)
 353
 354 let setify s = uniq (sort (fun x y -> Pervasives.compare x y <= 0) s);;
 355
 356 (* ------------------------------------------------------------------------- *)
 357 (* String operations (surely there is a better way...)                       *)
 358 (* ------------------------------------------------------------------------- *)
 359
 360 let implode l = itlist (^) l "";;
 361
 362 let explode s =
 363   let rec exap n l =
 364       if n < 0 then l else
 365       exap (n - 1) ((String.sub s n 1)::l) in
 366   exap (String.length s - 1) [];;
 367
 368 (* ------------------------------------------------------------------------- *)
 369 (* Greatest common divisor.                                                  *)
 370 (* ------------------------------------------------------------------------- *)
 371
 372 let gcd =
 373   let rec gxd x y =
 374     if y = 0 then x else gxd y (x mod y) in
 375   fun x y -> let x' = abs x and y' = abs y in
 376               if x' < y' then gxd y' x' else gxd x' y';;
 377
 378 (* ------------------------------------------------------------------------- *)
 379 (* Some useful functions on "num" type.                                      *)
 380 (* ------------------------------------------------------------------------- *)
 381
 382 let num_0 = Int 0
 383 and num_1 = Int 1
 384 and num_2 = Int 2
 385 and num_10 = Int 10;;
 386
 387 let pow2 n = power_num num_2 (Int n);;
 388 let pow10 n = power_num num_10 (Int n);;
 389
 390 let numdom r =
 391   let r' = Ratio.normalize_ratio (ratio_of_num r) in
 392   num_of_big_int(Ratio.numerator_ratio r'),
 393   num_of_big_int(Ratio.denominator_ratio r');;
 394
 395 let numerator = fst o numdom
 396 and denominator = snd o numdom;;
 397
 398 let gcd_num n1 n2 =
 399   num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
 400
 401 let lcm_num x y =
 402   if x =/ num_0 & y =/ num_0 then num_0
 403   else abs_num((x */ y) // gcd_num x y);;
 404
 405 (* ------------------------------------------------------------------------- *)
 406 (* All pairs arising from applying a function over two lists.                *)
 407 (* ------------------------------------------------------------------------- *)
 408
 409 let rec allpairs f l1 l2 =
 410   match l1 with
 411    h1::t1 ->  itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
 412   | [] -> [];;
 413
 414 (* ------------------------------------------------------------------------- *)
 415 (* Issue a report with a newline.                                            *)
 416 (* ------------------------------------------------------------------------- *)
 417
 418 let report s =
 419   Format.print_string s; Format.print_newline();;
 420
 421 (* ------------------------------------------------------------------------- *)
 422 (* Convenient function for issuing a warning.                                *)
 423 (* ------------------------------------------------------------------------- *)
 424
 425 let warn cond s =
 426   if cond then report ("Warning: "^s) else ();;
 427
 428 (* ------------------------------------------------------------------------- *)
 429 (* Flags to switch on verbose mode.                                          *)
 430 (* ------------------------------------------------------------------------- *)
 431
 432 let verbose = ref true;;
 433 let report_timing = ref true;;
 434
 435 (* ------------------------------------------------------------------------- *)
 436 (* Switchable version of "report".                                           *)
 437 (* ------------------------------------------------------------------------- *)
 438
 439 let remark s =
 440   if !verbose then report s else ();;
 441
 442 (* ------------------------------------------------------------------------- *)
 443 (* Time a function.                                                          *)
 444 (* ------------------------------------------------------------------------- *)
 445
 446 let time f x =
 447   if not (!report_timing) then f x else
 448   let start_time = Sys.time() in
 449   try let result = f x in
 450       let finish_time = Sys.time() in
 451       report("CPU time (user): "^(string_of_float(finish_time -. start_time)));
 452       result
 453   with e ->
 454       let finish_time = Sys.time() in
 455       Format.print_string("Failed after (user) CPU time of "^
 456                           (string_of_float(finish_time -. start_time))^": ");
 457       raise e;;
 458
 459 (* ------------------------------------------------------------------------- *)
 460 (* Versions of assoc and rev_assoc with default rather than failure.         *)
 461 (* ------------------------------------------------------------------------- *)
 462
 463 let rec assocd a l d =
 464   match l with
 465     [] -> d
 466   | (x,y)::t -> if Pervasives.compare x a = 0 then y else assocd a t d;;
 467
 468 let rec rev_assocd a l d =
 469   match l with
 470     [] -> d
 471   | (x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assocd a t d;;
 472
 473 (* ------------------------------------------------------------------------- *)
 474 (* Version of map that avoids rebuilding unchanged subterms.                 *)
 475 (* ------------------------------------------------------------------------- *)
 476
 477 let rec qmap f l =
 478   match l with
 479     h::t -> let h' = f h and t' = qmap f t in
 480             if h' == h & t' == t then l else h'::t'
 481   | _ -> l;;
 482
 483 (* ------------------------------------------------------------------------- *)
 484 (* Merging and bottom-up mergesort.                                          *)
 485 (* ------------------------------------------------------------------------- *)
 486
 487 let rec merge ord l1 l2 =
 488   match l1 with
 489     [] -> l2
 490   | h1::t1 -> match l2 with
 491                 [] -> l1
 492               | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
 493                           else h2::(merge ord l1 t2);;
 494
 495 let mergesort ord =
 496   let rec mergepairs l1 l2 =
 497     match (l1,l2) with
 498         ([s],[]) -> s
 499       | (l,[]) -> mergepairs [] l
 500       | (l,[s1]) -> mergepairs (s1::l) []
 501       | (l,(s1::s2::ss)) -> mergepairs ((merge ord s1 s2)::l) ss in
 502   fun l -> if l = [] then [] else mergepairs [] (map (fun x -> [x]) l);;
 503
 504 (* ------------------------------------------------------------------------- *)
 505 (* Common measure predicates to use with "sort".                             *)
 506 (* ------------------------------------------------------------------------- *)
 507
 508 let increasing f x y = Pervasives.compare (f x) (f y) < 0;;
 509
 510 let decreasing f x y = Pervasives.compare (f x) (f y) > 0;;
 511
 512 (* ------------------------------------------------------------------------- *)
 513 (* Polymorphic finite partial functions via Patricia trees.                  *)
 514 (*                                                                           *)
 515 (* The point of this strange representation is that it is canonical (equal   *)
 516 (* functions have the same encoding) yet reasonably efficient on average.    *)
 517 (*                                                                           *)
 518 (* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10).        *)
 519 (* ------------------------------------------------------------------------- *)
 520
 521 type ('a,'b)func =
 522    Empty
 523  | Leaf of int * ('a*'b)list
 524  | Branch of int * int * ('a,'b)func * ('a,'b)func;;
 525
 526 (* ------------------------------------------------------------------------- *)
 527 (* Undefined function.                                                       *)
 528 (* ------------------------------------------------------------------------- *)
 529
 530 let undefined = Empty;;
 531
 532 (* ------------------------------------------------------------------------- *)
 533 (* In case of equality comparison worries, better use this.                  *)
 534 (* ------------------------------------------------------------------------- *)
 535
 536 let is_undefined f =
 537   match f with
 538     Empty -> true
 539   | _ -> false;;
 540
 541 (* ------------------------------------------------------------------------- *)
 542 (* Operation analagous to "map" for lists.                                   *)
 543 (* ------------------------------------------------------------------------- *)
 544
 545 let mapf =
 546   let rec map_list f l =
 547     match l with
 548       [] -> []
 549     | (x,y)::t -> (x,f(y))::(map_list f t) in
 550   let rec mapf f t =
 551     match t with
 552       Empty -> Empty
 553     | Leaf(h,l) -> Leaf(h,map_list f l)
 554     | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
 555   mapf;;
 556
 557 (* ------------------------------------------------------------------------- *)
 558 (* Operations analogous to "fold" for lists.                                 *)
 559 (* ------------------------------------------------------------------------- *)
 560
 561 let foldl =
 562   let rec foldl_list f a l =
 563     match l with
 564       [] -> a
 565     | (x,y)::t -> foldl_list f (f a x y) t in
 566   let rec foldl f a t =
 567     match t with
 568       Empty -> a
 569     | Leaf(h,l) -> foldl_list f a l
 570     | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
 571   foldl;;
 572
 573 let foldr =
 574   let rec foldr_list f l a =
 575     match l with
 576       [] -> a
 577     | (x,y)::t -> f x y (foldr_list f t a) in
 578   let rec foldr f t a =
 579     match t with
 580       Empty -> a
 581     | Leaf(h,l) -> foldr_list f l a
 582     | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
 583   foldr;;
 584
 585 (* ------------------------------------------------------------------------- *)
 586 (* Mapping to sorted-list representation of the graph, domain and range.     *)
 587 (* ------------------------------------------------------------------------- *)
 588
 589 let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
 590
 591 let dom f = setify(foldl (fun a x y -> x::a) [] f);;
 592
 593 let ran f = setify(foldl (fun a x y -> y::a) [] f);;
 594
 595 (* ------------------------------------------------------------------------- *)
 596 (* Application.                                                              *)
 597 (* ------------------------------------------------------------------------- *)
 598
 599 let applyd =
 600   let rec apply_listd l d x =
 601     match l with
 602       (a,b)::t -> let c = Pervasives.compare x a in
 603                   if c = 0 then b else if c > 0 then apply_listd t d x else d x
 604     | [] -> d x in
 605   fun f d x ->
 606     let k = Hashtbl.hash x in
 607     let rec look t =
 608       match t with
 609         Leaf(h,l) when h = k -> apply_listd l d x
 610       | Branch(p,b,l,r) when (k lxor p) land (b - 1) = 0
 611                 -> look (if k land b = 0 then l else r)
 612       | _ -> d x in
 613     look f;;
 614
 615 let apply f = applyd f (fun x -> failwith "apply");;
 616
 617 let tryapplyd f a d = applyd f (fun x -> d) a;;
 618
 619 let defined f x = try apply f x; true with Failure _ -> false;;
 620
 621 (* ------------------------------------------------------------------------- *)
 622 (* Undefinition.                                                             *)
 623 (* ------------------------------------------------------------------------- *)
 624
 625 let undefine =
 626   let rec undefine_list x l =
 627     match l with
 628       (a,b as ab)::t ->
 629           let c = Pervasives.compare x a in
 630           if c = 0 then t
 631           else if c < 0 then l else
 632           let t' = undefine_list x t in
 633           if t' == t then l else ab::t'
 634     | [] -> [] in
 635   fun x ->
 636     let k = Hashtbl.hash x in
 637     let rec und t =
 638       match t with
 639         Leaf(h,l) when h = k ->
 640           let l' = undefine_list x l in
 641           if l' == l then t
 642           else if l' = [] then Empty
 643           else Leaf(h,l')
 644       | Branch(p,b,l,r) when k land (b - 1) = p ->
 645           if k land b = 0 then
 646             let l' = und l in
 647             if l' == l then t
 648             else (match l' with Empty -> r | _ -> Branch(p,b,l',r))
 649           else
 650             let r' = und r in
 651             if r' == r then t
 652             else (match r' with Empty -> l | _ -> Branch(p,b,l,r'))
 653       | _ -> t in
 654     und;;
 655
 656 (* ------------------------------------------------------------------------- *)
 657 (* Redefinition and combination.                                             *)
 658 (* ------------------------------------------------------------------------- *)
 659
 660 let (|->),combine =
 661   let newbranch p1 t1 p2 t2 =
 662     let zp = p1 lxor p2 in
 663     let b = zp land (-zp) in
 664     let p = p1 land (b - 1) in
 665     if p1 land b = 0 then Branch(p,b,t1,t2)
 666     else Branch(p,b,t2,t1) in
 667   let rec define_list (x,y as xy) l =
 668     match l with
 669       (a,b as ab)::t ->
 670           let c = Pervasives.compare x a in
 671           if c = 0 then xy::t
 672           else if c < 0 then xy::l
 673           else ab::(define_list xy t)
 674     | [] -> [xy]
 675   and combine_list op z l1 l2 =
 676     match (l1,l2) with
 677       [],_ -> l2
 678     | _,[] -> l1
 679     | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
 680           let c = Pervasives.compare x1 x2 in
 681           if c < 0 then xy1::(combine_list op z t1 l2)
 682           else if c > 0 then xy2::(combine_list op z l1 t2) else
 683           let y = op y1 y2 and l = combine_list op z t1 t2 in
 684           if z(y) then l else (x1,y)::l in
 685   let (|->) x y =
 686     let k = Hashtbl.hash x in
 687     let rec upd t =
 688       match t with
 689         Empty -> Leaf (k,[x,y])
 690       | Leaf(h,l) ->
 691            if h = k then Leaf(h,define_list (x,y) l)
 692            else newbranch h t k (Leaf(k,[x,y]))
 693       | Branch(p,b,l,r) ->
 694           if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
 695           else if k land b = 0 then Branch(p,b,upd l,r)
 696           else Branch(p,b,l,upd r) in
 697     upd in
 698   let rec combine op z t1 t2 =
 699     match (t1,t2) with
 700       Empty,_ -> t2
 701     | _,Empty -> t1
 702     | Leaf(h1,l1),Leaf(h2,l2) ->
 703           if h1 = h2 then
 704             let l = combine_list op z l1 l2 in
 705             if l = [] then Empty else Leaf(h1,l)
 706           else newbranch h1 t1 h2 t2
 707     | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) ->
 708           if k land (b - 1) = p then
 709             if k land b = 0 then
 710               (match combine op z lf l with
 711                  Empty -> r | l' -> Branch(p,b,l',r))
 712             else
 713               (match combine op z lf r with
 714                  Empty -> l | r' -> Branch(p,b,l,r'))
 715           else
 716             newbranch k lf p br
 717     | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
 718           if k land (b - 1) = p then
 719             if k land b = 0 then
 720               (match combine op z l lf with
 721                 Empty -> r | l' -> Branch(p,b,l',r))
 722             else
 723               (match combine op z r lf with
 724                  Empty -> l | r' -> Branch(p,b,l,r'))
 725           else
 726             newbranch p br k lf
 727     | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
 728           if b1 < b2 then
 729             if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
 730             else if p2 land b1 = 0 then
 731               (match combine op z l1 t2 with
 732                  Empty -> r1 | l -> Branch(p1,b1,l,r1))
 733             else
 734               (match combine op z r1 t2 with
 735                  Empty -> l1 | r -> Branch(p1,b1,l1,r))
 736           else if b2 < b1 then
 737             if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
 738             else if p1 land b2 = 0 then
 739               (match combine op z t1 l2 with
 740                  Empty -> r2 | l -> Branch(p2,b2,l,r2))
 741             else
 742               (match combine op z t1 r2 with
 743                  Empty -> l2 | r -> Branch(p2,b2,l2,r))
 744           else if p1 = p2 then
 745            (match (combine op z l1 l2,combine op z r1 r2) with
 746               (Empty,r) -> r | (l,Empty) -> l | (l,r) -> Branch(p1,b1,l,r))
 747           else
 748             newbranch p1 t1 p2 t2 in
 749   (|->),combine;;
 750
 751 (* ------------------------------------------------------------------------- *)
 752 (* Special case of point function.                                           *)
 753 (* ------------------------------------------------------------------------- *)
 754
 755 let (|=>) = fun x y -> (x |-> y) undefined;;
 756
 757 (* ------------------------------------------------------------------------- *)
 758 (* Grab an arbitrary element.                                                *)
 759 (* ------------------------------------------------------------------------- *)
 760
 761 let rec choose t =
 762   match t with
 763     Empty -> failwith "choose: completely undefined function"
 764   | Leaf(h,l) -> hd l
 765   | Branch(b,p,t1,t2) -> choose t1;;
 766
 767 (* ------------------------------------------------------------------------- *)
 768 (* Install a trivial printer for the general polymorphic case.               *)
 769 (* ------------------------------------------------------------------------- *)
 770
 771 let print_fpf (f:('a,'b)func) = Format.print_string "<func>";;
 772
 773 #install_printer print_fpf;;
 774
 775 (* ------------------------------------------------------------------------- *)
 776 (* Set operations parametrized by equality (from Steven Obua).               *)
 777 (* ------------------------------------------------------------------------- *)
 778
 779 let rec mem' eq =
 780   let rec mem x lis =
 781     match lis with
 782       [] -> false
 783     | (h::t) -> eq x h or mem x t
 784   in mem;;
 785
 786 let insert' eq x l =
 787   if mem' eq x l then l else x::l;;
 788
 789 let union' eq l1 l2 = itlist (insert' eq) l1 l2;;
 790
 791 let unions' eq l = itlist (union' eq) l [];;
 792
 793 let subtract' eq l1 l2 = filter (fun x -> not (mem' eq x l2)) l1;;
 794
 795 (* ------------------------------------------------------------------------- *)
 796 (* Accepts decimal, hex or binary numeral, using C notation 0x... for hex    *)
 797 (* and analogous 0b... for binary.                                           *)
 798 (* ------------------------------------------------------------------------- *)
 799
 800 let num_of_string =
 801   let values =
 802    ["0",0; "1",1; "2",2; "3",3; "4",4;
 803     "5",5; "6",6; "7",7; "8",8; "9",9;
 804     "a",10; "A",10; "b",11; "B",11;
 805     "c",12; "C",12; "d",13; "D",13;
 806     "e",14; "E",14; "f",15; "F",15] in
 807   let valof b s =
 808     let v = Int(assoc s values) in
 809     if v </ b then v else failwith "num_of_string: invalid digit for base"
 810   and two = num_2 and ten = num_10 and sixteen = Int 16 in
 811   let rec num_of_stringlist b l =
 812     match l with
 813       [] -> failwith "num_of_string: no digits after base indicator"
 814     | [h] -> valof b h
 815     | h::t -> valof b h +/ b */ num_of_stringlist b t in
 816   fun s ->
 817     match explode(s) with
 818         [] -> failwith "num_of_string: no digits"
 819       | "0"::"x"::hexdigits -> num_of_stringlist sixteen (rev hexdigits)
 820       | "0"::"b"::bindigits -> num_of_stringlist two (rev bindigits)
 821       | decdigits -> num_of_stringlist ten (rev decdigits);;
 822
 823 (* ------------------------------------------------------------------------- *)
 824 (* Convenient conversion between files and (lists of) strings.               *)
 825 (* ------------------------------------------------------------------------- *)
 826
 827 let strings_of_file filename =
 828   let fd = try Pervasives.open_in filename
 829            with Sys_error _ ->
 830              failwith("strings_of_file: can't open "^filename) in
 831   let rec suck_lines acc =
 832     try let l = Pervasives.input_line fd in
 833         suck_lines (l::acc)
 834     with End_of_file -> rev acc in
 835   let data = suck_lines [] in
 836   (Pervasives.close_in fd; data);;
 837
 838 let string_of_file filename =
 839   end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);;
 840
 841 let file_of_string filename s =
 842   let fd = Pervasives.open_out filename in
 843   output_string fd s; close_out fd;;