Created
March 7, 2014 14:02
-
-
Save owainlewis/9412040 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(* ========================================================================= *) | |
(* Misc library functions to set up a nice environment. *) | |
(* ========================================================================= *) | |
let identity x = x;; | |
let ( ** ) = fun f g x -> f(g x);; | |
(* ------------------------------------------------------------------------- *) | |
(* GCD and LCM on arbitrary-precision numbers. *) | |
(* ------------------------------------------------------------------------- *) | |
let gcd_num n1 n2 = | |
abs_num(num_of_big_int | |
(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2)));; | |
let lcm_num n1 n2 = abs_num(n1 */ n2) // gcd_num n1 n2;; | |
(* ------------------------------------------------------------------------- *) | |
(* A useful idiom for "non contradictory" etc. *) | |
(* ------------------------------------------------------------------------- *) | |
let non p x = not(p x);; | |
(* ------------------------------------------------------------------------- *) | |
(* Kind of assertion checking. *) | |
(* ------------------------------------------------------------------------- *) | |
let check p x = if p(x) then x else failwith "check";; | |
(* ------------------------------------------------------------------------- *) | |
(* Repetition of a function. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec funpow n f x = | |
if n < 1 then x else funpow (n-1) f (f x);; | |
let can f x = try f x; true with Failure _ -> false;; | |
let rec repeat f x = try repeat f (f x) with Failure _ -> x;; | |
(* ------------------------------------------------------------------------- *) | |
(* Handy list operations. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);; | |
let rec (---) = fun m n -> if m >/ n then [] else m::((m +/ Int 1) --- n);; | |
let rec map2 f l1 l2 = | |
match (l1,l2) with | |
[],[] -> [] | |
| (h1::t1),(h2::t2) -> let h = f h1 h2 in h::(map2 f t1 t2) | |
| _ -> failwith "map2: length mismatch";; | |
let rev = | |
let rec rev_append acc l = | |
match l with | |
[] -> acc | |
| h::t -> rev_append (h::acc) t in | |
fun l -> rev_append [] l;; | |
let hd l = | |
match l with | |
h::t -> h | |
| _ -> failwith "hd";; | |
let tl l = | |
match l with | |
h::t -> t | |
| _ -> failwith "tl";; | |
let rec itlist f l b = | |
match l with | |
[] -> b | |
| (h::t) -> f h (itlist f t b);; | |
let rec end_itlist f l = | |
match l with | |
[] -> failwith "end_itlist" | |
| [x] -> x | |
| (h::t) -> f h (end_itlist f t);; | |
let rec itlist2 f l1 l2 b = | |
match (l1,l2) with | |
([],[]) -> b | |
| (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b) | |
| _ -> failwith "itlist2";; | |
let rec zip l1 l2 = | |
match (l1,l2) with | |
([],[]) -> [] | |
| (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) | |
| _ -> failwith "zip";; | |
let rec forall p l = | |
match l with | |
[] -> true | |
| h::t -> p(h) & forall p t;; | |
let rec exists p l = | |
match l with | |
[] -> false | |
| h::t -> p(h) or exists p t;; | |
let partition p l = | |
itlist (fun a (yes,no) -> if p a then a::yes,no else yes,a::no) l ([],[]);; | |
let filter p l = fst(partition p l);; | |
let length = | |
let rec len k l = | |
if l = [] then k else len (k + 1) (tl l) in | |
fun l -> len 0 l;; | |
let rec last l = | |
match l with | |
[x] -> x | |
| (h::t) -> last t | |
| [] -> failwith "last";; | |
let rec butlast l = | |
match l with | |
[_] -> [] | |
| (h::t) -> h::(butlast t) | |
| [] -> failwith "butlast";; | |
let rec find p l = | |
match l with | |
[] -> failwith "find" | |
| (h::t) -> if p(h) then h else find p t;; | |
let rec el n l = | |
if n = 0 then hd l else el (n - 1) (tl l);; | |
let map f = | |
let rec mapf l = | |
match l with | |
[] -> [] | |
| (x::t) -> let y = f x in y::(mapf t) in | |
mapf;; | |
let rec allpairs f l1 l2 = | |
match l1 with | |
h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2) | |
| [] -> [];; | |
let rec distinctpairs l = | |
match l with | |
x::t -> itlist (fun y a -> (x,y) :: a) t (distinctpairs t) | |
| [] -> [];; | |
let rec chop_list n l = | |
if n = 0 then [],l else | |
try let m,l' = chop_list (n-1) (tl l) in (hd l)::m,l' | |
with Failure _ -> failwith "chop_list";; | |
let replicate n a = map (fun x -> a) (1--n);; | |
let rec insertat i x l = | |
if i = 0 then x::l else | |
match l with | |
[] -> failwith "insertat: list too short for position to exist" | |
| h::t -> h::(insertat (i-1) x t);; | |
let rec forall2 p l1 l2 = | |
match (l1,l2) with | |
[],[] -> true | |
| (h1::t1,h2::t2) -> p h1 h2 & forall2 p t1 t2 | |
| _ -> false;; | |
let index x = | |
let rec ind n l = | |
match l with | |
[] -> failwith "index" | |
| (h::t) -> if Pervasives.compare x h = 0 then n else ind (n + 1) t in | |
ind 0;; | |
let rec unzip l = | |
match l with | |
[] -> [],[] | |
| (x,y)::t -> | |
let xs,ys = unzip t in x::xs,y::ys;; | |
(* ------------------------------------------------------------------------- *) | |
(* Whether the first of two items comes earlier in the list. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec earlier l x y = | |
match l with | |
h::t -> (Pervasives.compare h y <> 0) & | |
(Pervasives.compare h x = 0 or earlier t x y) | |
| [] -> false;; | |
(* ------------------------------------------------------------------------- *) | |
(* Application of (presumably imperative) function over a list. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec do_list f l = | |
match l with | |
[] -> () | |
| h::t -> f(h); do_list f t;; | |
(* ------------------------------------------------------------------------- *) | |
(* Association lists. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec assoc a l = | |
match l with | |
(x,y)::t -> if Pervasives.compare x a = 0 then y else assoc a t | |
| [] -> failwith "find";; | |
let rec rev_assoc a l = | |
match l with | |
(x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assoc a t | |
| [] -> failwith "find";; | |
(* ------------------------------------------------------------------------- *) | |
(* Merging of sorted lists (maintaining repetitions). *) | |
(* ------------------------------------------------------------------------- *) | |
let rec merge ord l1 l2 = | |
match l1 with | |
[] -> l2 | |
| h1::t1 -> match l2 with | |
[] -> l1 | |
| h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2) | |
else h2::(merge ord l1 t2);; | |
(* ------------------------------------------------------------------------- *) | |
(* Bottom-up mergesort. *) | |
(* ------------------------------------------------------------------------- *) | |
let sort ord = | |
let rec mergepairs l1 l2 = | |
match (l1,l2) with | |
([s],[]) -> s | |
| (l,[]) -> mergepairs [] l | |
| (l,[s1]) -> mergepairs (s1::l) [] | |
| (l,(s1::s2::ss)) -> mergepairs ((merge ord s1 s2)::l) ss in | |
fun l -> if l = [] then [] else mergepairs [] (map (fun x -> [x]) l);; | |
(* ------------------------------------------------------------------------- *) | |
(* Common measure predicates to use with "sort". *) | |
(* ------------------------------------------------------------------------- *) | |
let increasing f x y = Pervasives.compare (f x) (f y) < 0;; | |
let decreasing f x y = Pervasives.compare (f x) (f y) > 0;; | |
(* ------------------------------------------------------------------------- *) | |
(* Eliminate repetitions of adjacent elements, with and without counting. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec uniq l = | |
match l with | |
x::(y::_ as t) -> let t' = uniq t in | |
if Pervasives.compare x y = 0 then t' else | |
if t'==t then l else x::t' | |
| _ -> l;; | |
let repetitions = | |
let rec repcount n l = | |
match l with | |
x::(y::_ as ys) -> if Pervasives.compare y x = 0 then repcount (n + 1) ys | |
else (x,n)::(repcount 1 ys) | |
| [x] -> [x,n] | |
| [] -> failwith "repcount" in | |
fun l -> if l = [] then [] else repcount 1 l;; | |
let rec tryfind f l = | |
match l with | |
[] -> failwith "tryfind" | |
| (h::t) -> try f h with Failure _ -> tryfind f t;; | |
let rec mapfilter f l = | |
match l with | |
[] -> [] | |
| (h::t) -> let rest = mapfilter f t in | |
try (f h)::rest with Failure _ -> rest;; | |
(* ------------------------------------------------------------------------- *) | |
(* Find list member that maximizes or minimizes a function. *) | |
(* ------------------------------------------------------------------------- *) | |
let optimize ord f l = | |
fst(end_itlist (fun (x,y as p) (x',y' as p') -> if ord y y' then p else p') | |
(map (fun x -> x,f x) l));; | |
let maximize f l = optimize (>) f l and minimize f l = optimize (<) f l;; | |
(* ------------------------------------------------------------------------- *) | |
(* Set operations on ordered lists. *) | |
(* ------------------------------------------------------------------------- *) | |
let setify = | |
let rec canonical lis = | |
match lis with | |
x::(y::_ as rest) -> Pervasives.compare x y < 0 & canonical rest | |
| _ -> true in | |
fun l -> if canonical l then l | |
else uniq (sort (fun x y -> Pervasives.compare x y <= 0) l);; | |
let union = | |
let rec union l1 l2 = | |
match (l1,l2) with | |
([],l2) -> l2 | |
| (l1,[]) -> l1 | |
| ((h1::t1 as l1),(h2::t2 as l2)) -> | |
if h1 = h2 then h1::(union t1 t2) | |
else if h1 < h2 then h1::(union t1 l2) | |
else h2::(union l1 t2) in | |
fun s1 s2 -> union (setify s1) (setify s2);; | |
let intersect = | |
let rec intersect l1 l2 = | |
match (l1,l2) with | |
([],l2) -> [] | |
| (l1,[]) -> [] | |
| ((h1::t1 as l1),(h2::t2 as l2)) -> | |
if h1 = h2 then h1::(intersect t1 t2) | |
else if h1 < h2 then intersect t1 l2 | |
else intersect l1 t2 in | |
fun s1 s2 -> intersect (setify s1) (setify s2);; | |
let subtract = | |
let rec subtract l1 l2 = | |
match (l1,l2) with | |
([],l2) -> [] | |
| (l1,[]) -> l1 | |
| ((h1::t1 as l1),(h2::t2 as l2)) -> | |
if h1 = h2 then subtract t1 t2 | |
else if h1 < h2 then h1::(subtract t1 l2) | |
else subtract l1 t2 in | |
fun s1 s2 -> subtract (setify s1) (setify s2);; | |
let subset,psubset = | |
let rec subset l1 l2 = | |
match (l1,l2) with | |
([],l2) -> true | |
| (l1,[]) -> false | |
| (h1::t1,h2::t2) -> | |
if h1 = h2 then subset t1 t2 | |
else if h1 < h2 then false | |
else subset l1 t2 | |
and psubset l1 l2 = | |
match (l1,l2) with | |
(l1,[]) -> false | |
| ([],l2) -> true | |
| (h1::t1,h2::t2) -> | |
if h1 = h2 then psubset t1 t2 | |
else if h1 < h2 then false | |
else subset l1 t2 in | |
(fun s1 s2 -> subset (setify s1) (setify s2)), | |
(fun s1 s2 -> psubset (setify s1) (setify s2));; | |
let rec set_eq s1 s2 = (setify s1 = setify s2);; | |
let insert x s = union [x] s;; | |
let image f s = setify (map f s);; | |
(* ------------------------------------------------------------------------- *) | |
(* Union of a family of sets. *) | |
(* ------------------------------------------------------------------------- *) | |
let unions s = setify(itlist (@) s []);; | |
(* ------------------------------------------------------------------------- *) | |
(* List membership. This does *not* assume the list is a set. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec mem x lis = | |
match lis with | |
[] -> false | |
| (h::t) -> Pervasives.compare x h = 0 or mem x t;; | |
(* ------------------------------------------------------------------------- *) | |
(* Finding all subsets or all subsets of a given size. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec allsets m l = | |
if m = 0 then [[]] else | |
match l with | |
[] -> [] | |
| h::t -> union (image (fun g -> h::g) (allsets (m - 1) t)) (allsets m t);; | |
let rec allsubsets s = | |
match s with | |
[] -> [[]] | |
| (a::t) -> let res = allsubsets t in | |
union (image (fun b -> a::b) res) res;; | |
let allnonemptysubsets s = subtract (allsubsets s) [[]];; | |
(* ------------------------------------------------------------------------- *) | |
(* Explosion and implosion of strings. *) | |
(* ------------------------------------------------------------------------- *) | |
let explode s = | |
let rec exap n l = | |
if n < 0 then l else | |
exap (n - 1) ((String.sub s n 1)::l) in | |
exap (String.length s - 1) [];; | |
let implode l = itlist (^) l "";; | |
(* ------------------------------------------------------------------------- *) | |
(* Timing; useful for documentation but not logically necessary. *) | |
(* ------------------------------------------------------------------------- *) | |
let time f x = | |
let start_time = Sys.time() in | |
let result = f x in | |
let finish_time = Sys.time() in | |
print_string | |
("CPU time (user): "^(string_of_float(finish_time -. start_time))); | |
print_newline(); | |
result;; | |
(* ------------------------------------------------------------------------- *) | |
(* Polymorphic finite partial functions via Patricia trees. *) | |
(* *) | |
(* The point of this strange representation is that it is canonical (equal *) | |
(* functions have the same encoding) yet reasonably efficient on average. *) | |
(* *) | |
(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) | |
(* ------------------------------------------------------------------------- *) | |
type ('a,'b)func = | |
Empty | |
| Leaf of int * ('a*'b)list | |
| Branch of int * int * ('a,'b)func * ('a,'b)func;; | |
(* ------------------------------------------------------------------------- *) | |
(* Undefined function. *) | |
(* ------------------------------------------------------------------------- *) | |
let undefined = Empty;; | |
(* ------------------------------------------------------------------------- *) | |
(* In case of equality comparison worries, better use this. *) | |
(* ------------------------------------------------------------------------- *) | |
let is_undefined f = | |
match f with | |
Empty -> true | |
| _ -> false;; | |
(* ------------------------------------------------------------------------- *) | |
(* Operation analogous to "map" for lists. *) | |
(* ------------------------------------------------------------------------- *) | |
let mapf = | |
let rec map_list f l = | |
match l with | |
[] -> [] | |
| (x,y)::t -> (x,f(y))::(map_list f t) in | |
let rec mapf f t = | |
match t with | |
Empty -> Empty | |
| Leaf(h,l) -> Leaf(h,map_list f l) | |
| Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in | |
mapf;; | |
(* ------------------------------------------------------------------------- *) | |
(* Operations analogous to "fold" for lists. *) | |
(* ------------------------------------------------------------------------- *) | |
let foldl = | |
let rec foldl_list f a l = | |
match l with | |
[] -> a | |
| (x,y)::t -> foldl_list f (f a x y) t in | |
let rec foldl f a t = | |
match t with | |
Empty -> a | |
| Leaf(h,l) -> foldl_list f a l | |
| Branch(p,b,l,r) -> foldl f (foldl f a l) r in | |
foldl;; | |
let foldr = | |
let rec foldr_list f l a = | |
match l with | |
[] -> a | |
| (x,y)::t -> f x y (foldr_list f t a) in | |
let rec foldr f t a = | |
match t with | |
Empty -> a | |
| Leaf(h,l) -> foldr_list f l a | |
| Branch(p,b,l,r) -> foldr f l (foldr f r a) in | |
foldr;; | |
(* ------------------------------------------------------------------------- *) | |
(* Mapping to sorted-list representation of the graph, domain and range. *) | |
(* ------------------------------------------------------------------------- *) | |
let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; | |
let dom f = setify(foldl (fun a x y -> x::a) [] f);; | |
let ran f = setify(foldl (fun a x y -> y::a) [] f);; | |
(* ------------------------------------------------------------------------- *) | |
(* Application. *) | |
(* ------------------------------------------------------------------------- *) | |
let applyd = | |
let rec apply_listd l d x = | |
match l with | |
(a,b)::t -> let c = Pervasives.compare x a in | |
if c = 0 then b else if c > 0 then apply_listd t d x else d x | |
| [] -> d x in | |
fun f d x -> | |
let k = Hashtbl.hash x in | |
let rec look t = | |
match t with | |
Leaf(h,l) when h = k -> apply_listd l d x | |
| Branch(p,b,l,r) when (k lxor p) land (b - 1) = 0 | |
-> look (if k land b = 0 then l else r) | |
| _ -> d x in | |
look f;; | |
let apply f = applyd f (fun x -> failwith "apply");; | |
let tryapplyd f a d = applyd f (fun x -> d) a;; | |
let tryapplyl f x = tryapplyd f x [];; | |
let defined f x = try apply f x; true with Failure _ -> false;; | |
(* ------------------------------------------------------------------------- *) | |
(* Undefinition. *) | |
(* ------------------------------------------------------------------------- *) | |
let undefine = | |
let rec undefine_list x l = | |
match l with | |
(a,b as ab)::t -> | |
let c = Pervasives.compare x a in | |
if c = 0 then t | |
else if c < 0 then l else | |
let t' = undefine_list x t in | |
if t' == t then l else ab::t' | |
| [] -> [] in | |
fun x -> | |
let k = Hashtbl.hash x in | |
let rec und t = | |
match t with | |
Leaf(h,l) when h = k -> | |
let l' = undefine_list x l in | |
if l' == l then t | |
else if l' = [] then Empty | |
else Leaf(h,l') | |
| Branch(p,b,l,r) when k land (b - 1) = p -> | |
if k land b = 0 then | |
let l' = und l in | |
if l' == l then t | |
else (match l' with Empty -> r | _ -> Branch(p,b,l',r)) | |
else | |
let r' = und r in | |
if r' == r then t | |
else (match r' with Empty -> l | _ -> Branch(p,b,l,r')) | |
| _ -> t in | |
und;; | |
(* ------------------------------------------------------------------------- *) | |
(* Redefinition and combination. *) | |
(* ------------------------------------------------------------------------- *) | |
let (|->),combine = | |
let newbranch p1 t1 p2 t2 = | |
let zp = p1 lxor p2 in | |
let b = zp land (-zp) in | |
let p = p1 land (b - 1) in | |
if p1 land b = 0 then Branch(p,b,t1,t2) | |
else Branch(p,b,t2,t1) in | |
let rec define_list (x,y as xy) l = | |
match l with | |
(a,b as ab)::t -> | |
let c = Pervasives.compare x a in | |
if c = 0 then xy::t | |
else if c < 0 then xy::l | |
else ab::(define_list xy t) | |
| [] -> [xy] | |
and combine_list op z l1 l2 = | |
match (l1,l2) with | |
[],_ -> l2 | |
| _,[] -> l1 | |
| ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> | |
let c = Pervasives.compare x1 x2 in | |
if c < 0 then xy1::(combine_list op z t1 l2) | |
else if c > 0 then xy2::(combine_list op z l1 t2) else | |
let y = op y1 y2 and l = combine_list op z t1 t2 in | |
if z(y) then l else (x1,y)::l in | |
let (|->) x y = | |
let k = Hashtbl.hash x in | |
let rec upd t = | |
match t with | |
Empty -> Leaf (k,[x,y]) | |
| Leaf(h,l) -> | |
if h = k then Leaf(h,define_list (x,y) l) | |
else newbranch h t k (Leaf(k,[x,y])) | |
| Branch(p,b,l,r) -> | |
if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) | |
else if k land b = 0 then Branch(p,b,upd l,r) | |
else Branch(p,b,l,upd r) in | |
upd in | |
let rec combine op z t1 t2 = | |
match (t1,t2) with | |
Empty,_ -> t2 | |
| _,Empty -> t1 | |
| Leaf(h1,l1),Leaf(h2,l2) -> | |
if h1 = h2 then | |
let l = combine_list op z l1 l2 in | |
if l = [] then Empty else Leaf(h1,l) | |
else newbranch h1 t1 h2 t2 | |
| (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) -> | |
if k land (b - 1) = p then | |
if k land b = 0 then | |
(match combine op z lf l with | |
Empty -> r | l' -> Branch(p,b,l',r)) | |
else | |
(match combine op z lf r with | |
Empty -> l | r' -> Branch(p,b,l,r')) | |
else | |
newbranch k lf p br | |
| (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> | |
if k land (b - 1) = p then | |
if k land b = 0 then | |
(match combine op z l lf with | |
Empty -> r | l' -> Branch(p,b,l',r)) | |
else | |
(match combine op z r lf with | |
Empty -> l | r' -> Branch(p,b,l,r')) | |
else | |
newbranch p br k lf | |
| Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> | |
if b1 < b2 then | |
if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 | |
else if p2 land b1 = 0 then | |
(match combine op z l1 t2 with | |
Empty -> r1 | l -> Branch(p1,b1,l,r1)) | |
else | |
(match combine op z r1 t2 with | |
Empty -> l1 | r -> Branch(p1,b1,l1,r)) | |
else if b2 < b1 then | |
if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 | |
else if p1 land b2 = 0 then | |
(match combine op z t1 l2 with | |
Empty -> r2 | l -> Branch(p2,b2,l,r2)) | |
else | |
(match combine op z t1 r2 with | |
Empty -> l2 | r -> Branch(p2,b2,l2,r)) | |
else if p1 = p2 then | |
(match (combine op z l1 l2,combine op z r1 r2) with | |
(Empty,r) -> r | (l,Empty) -> l | (l,r) -> Branch(p1,b1,l,r)) | |
else | |
newbranch p1 t1 p2 t2 in | |
(|->),combine;; | |
(* ------------------------------------------------------------------------- *) | |
(* Special case of point function. *) | |
(* ------------------------------------------------------------------------- *) | |
let (|=>) = fun x y -> (x |-> y) undefined;; | |
(* ------------------------------------------------------------------------- *) | |
(* Idiom for a mapping zipping domain and range lists. *) | |
(* ------------------------------------------------------------------------- *) | |
let fpf xs ys = itlist2 (|->) xs ys undefined;; | |
(* ------------------------------------------------------------------------- *) | |
(* Grab an arbitrary element. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec choose t = | |
match t with | |
Empty -> failwith "choose: completely undefined function" | |
| Leaf(h,l) -> hd l | |
| Branch(b,p,t1,t2) -> choose t1;; | |
(* ------------------------------------------------------------------------- *) | |
(* Install a (trivial) printer for finite partial functions. *) | |
(* ------------------------------------------------------------------------- *) | |
let print_fpf (f:('a,'b)func) = print_string "<func>";; | |
#install_printer print_fpf;; | |
(* ------------------------------------------------------------------------- *) | |
(* Related stuff for standard functions. *) | |
(* ------------------------------------------------------------------------- *) | |
let valmod a y f x = if x = a then y else f(x);; | |
let undef x = failwith "undefined function";; | |
(* ------------------------------------------------------------------------- *) | |
(* Union-find algorithm. *) | |
(* ------------------------------------------------------------------------- *) | |
type ('a)pnode = Nonterminal of 'a | Terminal of 'a * int;; | |
type ('a)partition = Partition of ('a,('a)pnode)func;; | |
let rec terminus (Partition f as ptn) a = | |
match (apply f a) with | |
Nonterminal(b) -> terminus ptn b | |
| Terminal(p,q) -> (p,q);; | |
let tryterminus ptn a = | |
try terminus ptn a with Failure _ -> (a,1);; | |
let canonize ptn a = fst(tryterminus ptn a);; | |
let equivalent eqv a b = canonize eqv a = canonize eqv b;; | |
let equate (a,b) (Partition f as ptn) = | |
let (a',na) = tryterminus ptn a | |
and (b',nb) = tryterminus ptn b in | |
Partition | |
(if a' = b' then f else | |
if na <= nb then | |
itlist identity [a' |-> Nonterminal b'; b' |-> Terminal(b',na+nb)] f | |
else | |
itlist identity [b' |-> Nonterminal a'; a' |-> Terminal(a',na+nb)] f);; | |
let unequal = Partition undefined;; | |
let equated (Partition f) = dom f;; | |
(* ------------------------------------------------------------------------- *) | |
(* First number starting at n for which p succeeds. *) | |
(* ------------------------------------------------------------------------- *) | |
let rec first n p = if p(n) then n else first (n +/ Int 1) p;; |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment