(* This module contains general-purpose functions used in many modules. Typically a module will use the [open] keyword to bring these definitions up to top level, so their names are considered reserved words in other modules. All functions in this module are tail-recursive, unless otherwise noted. *) (* Replace all instances of x with x' in s *) let string_replace_all x x' s = if x = "" then s else let p = ref 0 and slen = String.length s and xlen = String.length x in let output = Buffer.create (slen * 2) in while !p < slen do try if String.sub s !p xlen = x then (Buffer.add_string output x'; p := !p + xlen) else (Buffer.add_char output s.[!p]; incr p) with _ -> Buffer.add_char output s.[!p]; incr p done; Buffer.contents output (* Print something and then flush standard output. *) let flprint s = print_string s; flush stdout (* Debug printing *) let dp_print = ref false let dpr s = if !dp_print then flprint s (* [xxx] is a tail-recursive version of [List.xxx]. See [List] module for details. *) let sort = List.sort let hd = List.hd let tl = List.tl let rev = List.rev let iter = List.iter let iter2 = List.iter2 let rec iter3 f a b c = match a, b, c with | [], [], [] -> () | ah::a', bh::b', ch::c' -> f ah bh ch; iter3 f a' b' c' | _ -> raise (Invalid_argument "iter3") let append a b = List.rev_append (rev a) b let ( @ ) = append let flatten lists = let rec flatten out = function | [] -> out | l::ls -> flatten (append l out) ls in flatten [] (rev lists) let rev_map = List.rev_map let map f l = rev (List.rev_map f l) let map2 f a b = rev (List.rev_map2 f a b) let split l = let rec split_inner (l1, l2) = function | [] -> rev l1, rev l2 | (a, b)::t -> split_inner (a::l1, b::l2) t in split_inner ([], []) l let split3 l = let rec split3_inner (l1, l2, l3) = function | [] -> rev l1, rev l2, rev l3 | (a, b, c)::t -> split3_inner (a::l1, b::l2, c::l3) t in split3_inner ([], [], []) l let split5 l = let rec split5_inner (l1, l2, l3, l4, l5) = function | [] -> rev l1, rev l2, rev l3, rev l4, rev l5 | (a, b, c, d, e)::t -> split5_inner (a::l1, b::l2, c::l3, d::l4, e::l5) t in split5_inner ([], [], [], [], []) l let split6 l = let rec split6_inner (l1, l2, l3, l4, l5, l6) = function | [] -> rev l1, rev l2, rev l3, rev l4, rev l5, rev l6 | (a, b, c, d, e, f)::t -> split6_inner (a::l1, b::l2, c::l3, d::l4, e::l5, f::l6) t in split6_inner ([], [], [], [], [], []) l let split8 l = let rec split8_inner (l1, l2, l3, l4, l5, l6, l7, l8) = function | [] -> rev l1, rev l2, rev l3, rev l4, rev l5, rev l6, rev l7, rev l8 | (a, b, c, d, e, f, g, h)::t -> split8_inner (a::l1, b::l2, c::l3, d::l4, e::l5, f::l6, g::l7, h::l8) t in split8_inner ([], [], [], [], [], [], [], []) l let combine a b = let pairs = ref [] in try List.iter2 (fun x y -> pairs := (x, y)::!pairs) a b; rev !pairs with Invalid_argument _ -> raise (Invalid_argument "Utility.combine") let combine3 a b c = let pairs = ref [] in try iter3 (fun x y z -> pairs := (x, y, z)::!pairs) a b c; rev !pairs with Invalid_argument _ -> raise (Invalid_argument "Utility.combine3") let fold_left f b l = List.fold_left f b l let fold_right f l e = List.fold_left (fun x y -> f y x) e (rev l) let length = List.length let rec rev_map3_inner f a b c outputs = match a, b, c with | [], [], [] -> outputs | ha::ta, hb::tb, hc::tc -> rev_map3_inner f ta tb tc (f ha hb hc::outputs) | _ -> raise (Invalid_argument "map3") let rev_map3 f a b c = rev_map3_inner f a b c [] let map3 f a b c = rev (rev_map3 f a b c) let rec rev_map4_inner f a b c d outputs = match a, b, c, d with | [], [], [], [] -> outputs | ha::ta, hb::tb, hc::tc, hd::td -> rev_map4_inner f ta tb tc td (f ha hb hc hd::outputs) | _ -> raise (Invalid_argument "map4") let rev_map4 f a b c d = rev_map4_inner f a b c d [] let map4 f a b c d = rev (rev_map4 f a b c d) let rec rev_map5_inner f a b c d e outputs = match a, b, c, d, e with | [], [], [], [], [] -> outputs | ha::ta, hb::tb, hc::tc, hd::td, he::te -> rev_map5_inner f ta tb tc td te (f ha hb hc hd he::outputs) | _ -> raise (Invalid_argument "map5") let rev_map5 f a b c d e = rev_map5_inner f a b c d e [] let map5 f a b c d e = rev (rev_map5 f a b c d e) (* Calculate the cumulative sum of a list given a base e.g [cumulative_sum 5 [1;2;3] = [6; 8; 11]] *) let cumulative_sum b l = let rec cumulative_sum prev bse = function | [] -> rev prev | h::t -> cumulative_sum ((bse + h)::prev) (bse + h) t in cumulative_sum [] b l (* Split a list into a list of lists at every point where [p] is true *) let rec split_around_inner p prev curr = function | [] -> if curr = [] then (rev prev) else (rev (rev curr::prev)) | h::t -> if p h then split_around_inner p (rev curr::prev) [] t else split_around_inner p prev (h::curr) t let split_around p l = split_around_inner p [] [] l (* Count the number of elements matching a predicate. *) let rec lcount_inner p c = function | [] -> c | h::t -> if p h then lcount_inner p (c + 1) t else lcount_inner p c t let lcount p l = lcount_inner p 0 l (* Find the position of the first element matching a predicate. The first element is number one. *) let rec index_inner n p = function | [] -> dpr "b"; raise Not_found | h::_ when p h -> n | _::t -> index_inner (n + 1) p t let index n p = index_inner 1 n p (* Functions on Strings *) let firstchar s = try Some s.[0] with Invalid_argument _ -> dpr "3R"; None let lastchar s = try Some s.[String.length s - 1] with Invalid_argument _ -> dpr "3S"; None (* Make a list of characters from a string, preserving order. *) let explode s = let l = ref [] in for p = String.length s downto 1 do l := String.unsafe_get s (p - 1)::!l done; !l (* Make a string from a list of characters, preserving order. *) let implode l = let s = String.create (length l) in let rec list_loop x = function [] -> () | i::t -> String.unsafe_set s x i; list_loop (x + 1) t in list_loop 0 l; s (* String of character. *) let string_of_char c = let s = String.create 1 in String.unsafe_set s 0 c; s (* Long-integer function abbreviations *) let i32ofi = Int32.of_int let i32toi = Int32.to_int let i32tof = Int32.to_float let i32add = Int32.add let i32sub = Int32.sub let i32mul = Int32.mul let i32div = Int32.div let lsr32 = Int32.shift_right_logical let lsl32 = Int32.shift_left let lor32 = Int32.logor let land32 = Int32.logand let lnot32 = Int32.lognot let lxor32 = Int32.logxor let i32succ = Int32.succ let i32pred = Int32.pred let i32max = Pervasives.max let i32min = Pervasives.min let i64ofi = Int64.of_int let i64toi = Int64.to_int let i64tof = Int64.to_float let i64add = Int64.add let i64sub = Int64.sub let i64mul = Int64.mul let i64div = Int64.div let lsr64 = Int64.shift_right_logical let lsl64 = Int64.shift_left let land64 = Int64.logand let lor64 = Int64.logor let lnot64 = Int64.lognot let lxor64 = Int64.logxor let i64succ = Int64.succ let i64pred = Int64.pred let i64max = Pervasives.max let i64min = Pervasives.min let i32ofi64 = Int64.to_int32 let i64ofi32 = Int64.of_int32 (* Sign extension for integer of number of bits l. *) let sign_extend l n = let shift = Nativeint.size - 1 - l in (n lsl shift) asr shift (* Set each element of array [a] to value [v]. *) let set_array a v = Array.fill a 0 (Array.length a) v (* Evaluate [v ()], evaluate and ignore [f ()], return [v ()], in that order. *) let do_return v f = let r = v () in ignore (f ()); r (* Call [f ()] some number of times. *) let rec do_many f = function | n when n < 0 -> raise (Invalid_argument "do_many") | 0 -> () | n -> f (); do_many f (n - 1) (* Interleave an element among a list, so that [interleave 0 [1; 2; 3]] yields [[1; 0; 2; 0; 3]]. An empty or singleton list is unchanged. *) let interleave e l = let rec interleave_inner result elt = function | [] -> rev result | [e] -> interleave_inner (e::result) elt [] | h::t -> interleave_inner (elt::h::result) elt t in interleave_inner [] e l (* Interleave two same-length lists together, taking from the first list first. *) let interleave_lists a b = let rec interleave_lists_inner r a b = match a, b with | [], [] -> rev r | h::t, h'::t' -> interleave_lists_inner (h'::h::r) t t' | _ -> raise (Invalid_argument "interleave_lists") in interleave_lists_inner [] a b (* Cons on list references *) let ( =| ) r e = r := e::!r (* Append on list references *) let ( =@ ) r l = r := l @ !r (* Functions on characters. *) let isdigit = function | x when x >= '0' && x <= '9' -> true | _ -> false (* Abbreviation. *) let toint x = int_of_float x (* Invert a predicate. *) let notpred f = function e -> not (f e) (* Prefix equality *) let eq = ( = ) let neq = ( <> ) (* Map on the individual (inner) elements of a list of lists *) let map_lol f = map (map f) (* Raise [x] to the power [i]. *) let rec pow i x = match i with | 0 -> 1 | 1 -> x | i -> pow (i / 2) (x * x) * (if i mod 2 = 0 then 1 else x) (* Dictionaries implemented as association lists *) (* Look something up in a dictionary. *) let rec lookup k' = function | [] -> None | (k, v)::t -> if k = k' then Some v else lookup k' t (* Same, but no [option] type. *) let rec lookup_failnull k' = function | [] -> dpr "e"; raise Not_found | (k, v)::t -> if k = k' then v else lookup_failnull k' t (* Add something to a dictionary, replacing it if it's already there. *) let add k' v d = let rec add_inner r k' v = function | [] -> (k', v)::r | (k, _)::t when k = k' -> r @ ((k', v)::t) | h::t -> add_inner (h::r) k' v t in add_inner [] k' v d (* Replace something in a dictionary, failing if it doesn't exist. *) let replace k' v l = let rec replace_inner r k' v = function | [] -> dpr "f"; raise Not_found | (k, _)::t when k = k' -> List.rev_append r ((k', v)::t) | h::t -> replace_inner (h::r) k' v t in replace_inner [] k' v l (* Remove something from a dictionary. *) let remove k' l = let rec remove_inner r k' = function | [] -> r | (k, _)::t when k = k' -> List.rev_append r t | h::t -> remove_inner (h::r) k' t in remove_inner [] k' l (* Merge two dictionaries, prefering elements in the second in the case of clashes. *) let rec mergedict d = function | [] -> d | (k, v)::es -> mergedict (add k v d) es (* An infix operator for the composition of functions. *) let ( <| ) a b = a b (* Opposite version of [@], the reverse append. *) let ( @@ ) a b = b @ a (* In order to return pairs of list from recursive functions without recourse to accumulating arguments. *) let conspair ((x, y), (xs, ys)) = x::xs, y::ys (* The same with options determining whether or not each element is included in the output list. *) let conspairopt ((xo, yo), (xs, ys)) = (match xo with None -> xs | Some x -> x::xs), (match yo with None -> ys | Some y -> y::ys) (* Make consecutive elements of an even-length list into a list of pairs. *) let pairs_of_list l = let rec pairs_of_list_inner r = function | [] -> rev r | [_] -> raise (Invalid_argument "pairs_of_list") | h::h'::t -> pairs_of_list_inner ((h, h')::r) t in pairs_of_list_inner [] l (* Return a list identical to the input but with any item true under predicate [p] replaced with [o]. *) let replaceinlist p o l = let rec replaceinlist_inner r p o = function | [] -> rev r | h::t -> if p h then replaceinlist_inner (o::r) p o t else replaceinlist_inner (h::r) p o t in replaceinlist_inner [] p o l (* Produce a list of overlapping pairs of elements in a list in order, producing the empty list if on singleton input. *) let pairs l = let rec pairs_inner r = function | [] | [_] -> rev r | a::b::rest -> pairs_inner ((a, b)::r) (b::rest) in pairs_inner [] l (* Predicate to test if [x] is a member of a list. *) let mem = List.mem (* The same, with reversed arguments. *) let mem' l x = mem x l (* Return the set of distinct elements in a list. Does not preserve order. *) let setify_simple l = let rec setify_inner r = function | [] -> r | h::t -> if mem h t then setify_inner r t else setify_inner (h::r) t in setify_inner [] l (* The same, preserving the order of the first occurance of each distinct element in the input list. FIXME: This is still n^2, of course. How to improve? *) let setify_preserving_order l = setify_simple (rev l) let rec sorted_setify prev = function [] -> rev prev | [x] -> rev (x::prev) | a::b::t when a = b -> sorted_setify prev (b::t) | h::t -> sorted_setify (h::prev) t let setify l = sorted_setify [] (List.sort compare l) (* Remove all elts of l' from l if l, l' sets. *) let setminus l l' = let rec setminus_inner r l l' = match l with | [] -> r | h::t -> if mem h l' then setminus_inner r t l' else setminus_inner (h::r) t l' in setminus_inner [] l l' let setminus_preserving_order l l' = rev (setminus l l') (* Return a list of the heads of a list of lists. *) let heads l = let rec heads_inner r = function | [] -> rev r | h::t -> heads_inner (hd h::r) t in heads_inner [] l (* Return a list of the tails of a list of lists, failing if any of them are the empty list. *) let tails l = let rec tails_inner r = function | [] -> rev r | h::t -> tails_inner (tl h::r) t in tails_inner [] l (* Take a list of lists of equal length, and turn into a list of lists, the first containing all the first elements of the original lists, the second the second, and so on. *) let zipn l = let rec zipn_inner r = function | [] | []::_ -> rev r | l -> zipn_inner (heads l::r) (tails l) in zipn_inner [] l (* Remove the second, fourth etc elements from a list, saving the last element (if of even length) e.g [drop_evens [1;2;3;4;5;6] is [1;3;5;6]]. *) let drop_evens l = let rec drop_evens_inner r = function | h::_::h''::t -> drop_evens_inner (h::r) (h''::t) | h::h'::[] -> rev (h'::h::r) | [x] -> rev (x::r) | _ -> rev r in drop_evens_inner [] l (* Same, but don't save the last even one. *) let really_drop_evens l = let rec really_drop_evens_inner r = function | [] -> rev r | [h] -> really_drop_evens_inner (h::r) [] | h::_::more -> really_drop_evens_inner (h::r) more in really_drop_evens_inner [] l (* Remove the first, third etc. The last odd element is not saved. e.g [drop_odds [1;2;3;4;5;6;7] is [2;4;6]]. *) let drop_odds l = let rec drop_odds_inner r = function | _::h'::t -> drop_odds_inner (h'::r) t | _ -> rev r in drop_odds_inner [] l (* tl but silent failure. *) let tail_no_fail = function | [] -> [] | _::t -> t (* Couple the elements of a list [l] using function [f]. For instance, [couple ( + ) [[1; 3; 5]]] $\Longrightarrow$ [[4; 8]]. The two elements are applied to [f] in the order in which they appear in the input list. *) let couple f l = let rec couple_inner r f = function | x::x'::xs -> couple_inner (f x x'::r) f (x'::xs) | _ -> rev r in couple_inner [] f l (* As above, but an extra function [g] is applied to any last (odd) element. *) let couple_ext f g l = let rec couple_ext_inner r f g = function | x::x'::xs -> couple_ext_inner (f x x'::r) f g (x'::xs) | x::[] -> couple_ext_inner (g x::r) f g [] | [] -> rev r in couple_ext_inner [] f g l (* Apply [couple] repeatedly until only one element remains. Return that element. *) let rec couple_reduce f = function | [] -> raise (Invalid_argument "Utility.couple_reduce") | [a] -> a | l -> couple_reduce f (couple f l) (* A similar function to [couple], but the coupling is non-overlapping. *) let pair f l = let rec pair_inner r f = function | [] -> rev r | [a] -> pair_inner (a::r) f [] | a::b::t -> pair_inner (f a b::r) f t in pair_inner [] f l (* A version of [pair] which adds a unary function for the singleton, much like [couple_ext]. *) let pair_ext f g l = let rec pair_ext_inner r f g = function | [] -> rev r | [a] -> pair_ext_inner (g a::r) f g [] | a::b::t -> pair_ext_inner (f a b::r) f g t in pair_ext_inner [] f g l (* As [couple_reduce] is to [couple], so this is to [pair]. *) let rec pair_reduce f = function | [] -> raise (Invalid_argument "Utility.pair_reduce") | [a] -> a | l -> pair_reduce f (pair f l) (* [List.filter] has a confusing name, so we define [keep] and [lose] to avoid error. *) let keep = List.filter let rec lose_inner prev p = function | [] -> rev prev | h::t -> if p h then lose_inner prev p t else lose_inner (h::prev) p t let lose p = lose_inner [] p (* Make a list of length [n] with each element equal to [x]. *) let many x n = Array.to_list (Array.make n x) (* A version where we need to apply unit each time, for instance when producing a list of random numbers. Result is ordered. *) let manyunique f n = let rec manyunique_inner r f n = if n = 0 then rev r else manyunique_inner (f ()::r) f (n - 1) in manyunique_inner [] f n (* Take [n] elements from the front of a list [l], returning them in order. *) let take l n = if n < 0 then raise (Invalid_argument "Utility.take") else let rec take_inner r l n = if n = 0 then rev r else match l with | [] -> raise (Invalid_argument "Utility.take") | h::t -> take_inner (h::r) t (n - 1) in take_inner [] l n let take' n l = take l n (* Same, but order is reversed *) let takewhile_reverse p l = let rec takewhile_reverse_inner r p = function | [] -> r | h::t -> if p h then takewhile_reverse_inner (h::r) p t else r in takewhile_reverse_inner [] p l (* Take from the list [l] while the predicate [p] is true. *) let takewhile p l = let rec takewhile_inner r p l = match l with | [] -> rev r | h::t -> if p h then takewhile_inner (h::r) p t else rev r in takewhile_inner [] p l (* Drop [n] elements from the front of a list, returning the remainder in order. *) let rec drop_inner n = function | [] -> raise (Invalid_argument "drop") | _::t -> if n = 1 then t else drop_inner (n - 1) t let drop l n = if n < 0 then raise (Invalid_argument "drop") else if n = 0 then l else drop_inner n l let drop' n l = drop l n let rec dropwhile p = function | [] -> [] | h::t -> if p h then dropwhile p t else (h::t) (* Split a list [l] into two parts, the first part containing [n] elements. *) let cleave l n = let rec cleave_inner l left n = if n = 0 then rev left, l else match l with | [] -> raise (Invalid_argument "cleave: not enough elements") | _ -> cleave_inner (tl l) (hd l::left) (n - 1) in if n < 0 then raise (Invalid_argument "cleave: negative argument") else cleave_inner l [] n (* Returns elements for which p is true, until one is not, paired with the remaining list. The same as [takewhile p l], [dropwhile p l], but requiring only one pass over the list. *) let cleavewhile p l = let rec cleavewhile_inner p l elts = match l with | [] -> rev elts, [] | e::es -> if p e then cleavewhile_inner p es (e::elts) else rev elts, l in cleavewhile_inner p l [] (* The same, faster, but output lists are unordered. *) let cleavewhile_unordered p l = let rec cleavewhile_unordered_inner p l elts = match l with | [] -> elts, [] | e::es -> if p e then cleavewhile_unordered_inner p es (e::elts) else elts, l in cleavewhile_unordered_inner p l [] (* Isolate a central section of a list, from the first element after the element for which predicate [p] is true, to the element before [p'] is first true. *) let isolate p p' l = let _, during_and_after = cleavewhile (notpred p) l in match during_and_after with | [] -> [] | _::t -> fst (cleavewhile (notpred p') t) (* Collate a list into a list of lists based upon a comparison function by which it has already been sorted. e.g [collate [1; 2; 2; 3; 3]] calculates [[[1]; [2;2]; [3;3]]]. *) let collate cmp l = let rec collate_inner prev = function | [] -> rev prev | h::t -> let x, y = cleavewhile (fun a -> cmp h a = 0) (h::t) in collate_inner (x::prev) y in collate_inner [] l (* Split a list into some lists of length [n] (and possibly a final one of length < [n]). *) let splitinto n l = let rec splitinto_inner a n l len = match l with [] -> rev a | _ -> if len < n then rev (l::a) else let h, t = cleave l n in splitinto_inner (h::a) n t (len - n) in splitinto_inner [] n l (length l) (* Non-tail recursive version, for use when [n] is small and fixed. *) let rec takeatmost n l = match l with | h::t when n > 0 -> h :: takeatmost (n - 1) t | _ -> [] let rec dropatmost n l = match l with | _::t when n > 0 -> dropatmost (n - 1) t | l -> l let rec splitinto_small n l = match l with | [] -> [] | _ -> let first = takeatmost n l in first :: splitinto_small n (dropatmost n l) (* Split a list [l] at the given points. Point 1 means after the first element. *) let rec splitat_inner prev l = function | [] -> begin match l with [] -> rev prev | _ -> rev (l::prev) end | h::t -> let this, rest = cleave l h in splitat_inner (this::prev) rest t let splitat points l = splitat_inner [] l (couple (fun a b -> b - a) (0::points)) (* Select the nth element in a list (first is element 1) *) let select n l = try hd (drop l (n - 1)) with Invalid_argument "drop" | Failure "hd" -> raise (Invalid_argument "select") (* Replace the nth element of a list (first is element 1) *) let rec replace_number_inner prev n e = function | [] -> rev prev | l::ls -> if n = 1 then replace_number_inner (e::prev) (n - 1) e ls else replace_number_inner (l::prev) (n - 1) e ls let replace_number n e l = replace_number_inner [] n e l (* Simple list utilities. *) let isnull = function [] -> true | _ -> false let notnull = function [] -> false | _ -> true (* Find the last element of a list. *) let rec last = function | [] -> raise (Invalid_argument "Utility.last") | x::[] -> x | _::xs -> last xs (* Produce a list containing all but the last element of a list *) let all_but_last = function | [] | [_] -> [] | l -> rev (tl (rev l)) (* Find the first and last element of a list. If the list has one element, that is returned twice. *) let extremes = function | [] -> raise (Invalid_argument "Utility.extremes") | x::[] -> x, x | x::xs -> x, last xs (* Return the first, middle and last elements of a list which has length at least two. *) let extremes_and_middle = function | [] | [_] -> raise (Invalid_argument "extremes_and_middle") | h::t -> let m, l = cleave t (length t - 1) in h, m, hd l (* Set a boolean reference. *) let set r = r := true (* Clear a boolean reference. *) let clear r = r := false (* Change the value of a boolean reference. *) let flip r = r := not !r (* Increment and decrement integer references [r] by an integer [n]. *) let ( += ) r n = r := !r + n let ( -= ) r n = r := !r - n let ( /= ) r n = r := !r / n let ( *= ) r n = r := !r * n (* Similar functions on floating-point references. *) let ( +.= ) r n = r := !r +. n let ( -.= ) r n = r := !r -. n let ( /.= ) r n = r := !r /. n let ( *.= ) r n = r := !r *. n (* Vectors in two dimensions. *) type vector = float * float (* Make a vector from a point [(x0, y0)] to a point [(x1, y1)]. *) let mkvector (x0, y0) (x1, y1) = x1 -. x0, y1 -. y0 (* Invert a vector. *) let invert (a, b) = -.a, -.b (* Offset a point [(px, py)] by a vector [(x, y)]. *) let offset_point (x, y) (px, py) = px +. x, py +. y (* Find the vector pi / 2 anticlockwise from the given one. *) let perpendicular (a, b) = -.b, a (* Square a number *) let sqr x = x *. x (* Find the length of a vector. *) let veclength (x, y) = sqrt (sqr x +. sqr y) (* Scale a vector to a length [l]. *) let scalevectolength l (a, b) = let currentlength = veclength (a, b) in if currentlength = 0. then (a, b) else let factor = l /. currentlength in a *. factor, b *. factor (* Make a unit vector from [s] to [e] *) let mkunitvector s e = scalevectolength 1. (mkvector s e) (* Find the point equidistant between two others. *) let between (x, y) (x', y') = (x +. x') /. 2., (y +. y') /. 2. (* The cartesian distance between two points. *) let distance_between (px, py) (px', py') = sqrt (sqr (px -. px') +. sqr (py' -. py)) (* The largest power of two by which [n] is exactly divisible. *) let largest_pow2_divisible n = let rec s test n = if n mod test = 0 then s (test * 2) n else test / 2 in s 1 n (* Find the largest power of two smaller or equal to an integer [t]. *) let pow2lt t = let rec pow2lt_i target current = if current * 2 > target then current else pow2lt_i target (current * 2) in pow2lt_i t 1 (* Find the largest power of two greater or equal to an integer [t]. *) let pow2gt t = let lt = pow2lt t in if lt = t then t else lt * 2 (* Find the integer base two logarithm of a number. *) let log2of t = let rec log2of_i target num = if num * 2 > target then 0 else let n = log2of_i target (num * 2) in n + 1 in log2of_i t 1 (* Integer compare function --- saves the cost of polymorphic comparisons. *) let compare_i (a : int) b = if a < b then -1 else if a > b then 1 else 0 (* Reverse comparison *) let rev_compare a b = -compare a b (* The integer range between $[s..e]$ inclusive. *) let ilist s e = if e < s then raise (Invalid_argument "Utility.ilist") else let nums = ref [] in let rec ilist s e = if s = e then nums =| e else (nums =| s; ilist (s + 1) e) in ilist s e; rev !nums (* Same, but return null list for ilist x x rather than [x] *) let ilist_null s e = if s = e then [] else ilist s e (* Same, but upon failure just return null. *) let ilist_fail_null s e = if s > e then [] else ilist_null s e (* A common case: Make indexes for a list *) let indx l = if l = [] then [] else ilist 1 (length l) (* Same zero-indexed. *) let indx0 l = if l = [] then [] else ilist 0 (length l - 1) (* Same, n-indexed. *) let indxn n l = if l = [] then [] else ilist n (n + length l - 1) (* Even/odd predicates. Zero is considered even, -1 odd, -2 even etc. *) let even x = x mod 2 = 0 let odd = notpred even (* Exclusive Or of [a] and [b]. *) let ( |&| ) a b = (a || b) && not (a && b) (* The identity function. *) let ident x = x (* An array analog of [List.iter2].*) let array_iter2 f a b = if Array.length a = Array.length b then if Array.length a = 0 then () else for x = 0 to (Array.length a) - 1 do f (Array.get a x) (Array.get b x) done else raise (Invalid_argument "Utility.array_iter2") let array_map2 f a b = if Array.length a = Array.length b then Array.init (Array.length a) (function i -> f a.(i) b.(i)) else raise (Invalid_argument "Utility.array_map2") (* Some simple functions for working with the [option] type. *) let some = function None -> false | _ -> true let none = function None -> true | _ -> false let unopt = function | Some x -> x | None -> failwith "unopt" let rec losenones prev = function | [] -> rev prev | None::t -> losenones prev t | Some h::t -> losenones (h::prev) t let losenones l = losenones [] l let option_map f l = losenones (map f l) let option_map2 f a b = losenones (map2 f a b) (* Integer-specialised minimum and maximum functions for speed, overriding \emph{Pervasives.min} and \emph{Pervasives.max}. *) let min (a : int) b = if a < b then a else b let max (a : int) b = if a > b then a else b (* Floating point ones. *) let fmin (a : float) b = if a < b then a else b let fmax (a : float) b = if a > b then a else b let fabs x = abs_float x (* The union of two rectangles, each defined by its minimum and maximum coordinates *) let box_union (xmin0, xmax0, ymin0, ymax0) (xmin1, xmax1, ymin1, ymax1) = min xmin0 xmin1, max xmax0 xmax1, min ymin0 ymin1, max ymax0 ymax1 (* The union of two rectangles, each defined by its minimum and maximum coordinates *) let box_union_float (xmin0, xmax0, ymin0, ymax0) (xmin1, xmax1, ymin1, ymax1) = fmin xmin0 xmin1, fmax xmax0 xmax1, fmin ymin0 ymin1, fmax ymax0 ymax1 (* The intersection rectangle of two rectangles defined by integers. [x0, y0] etc refer to the top left, [x1, y1] etc. to the bottom right. *) let box_overlap ax0 ay0 ax1 ay1 bx0 by0 bx1 by1 = if ax0 > bx1 || ay0 > by1 || ax1 < bx0 || ay1 < by0 then None else Some (max ax0 bx0, max ay0 by0, min ax1 bx1, min ay1 by1) (* The same for floating point coordinates. *) let box_overlap_float ax0 ay0 ax1 ay1 bx0 by0 bx1 by1 = if ax0 > bx1 || ay0 > by1 || ax1 < bx0 || ay1 < by0 then None else Some (fmax ax0 bx0, fmax ay0 by0, fmin ax1 bx1, fmin ay1 by1) (* Apply a function [f] [n] times to initial argument [arg]. *) let rec applyn f n arg = if n = 0 then arg else applyn f (n - 1) (f arg) (* The type of binary trees. *) type 'a tree = Lf | Br of 'a * 'a tree * 'a tree (* Define pi. *) let pi = 4. *. atan 1. (* Define sqrt 2. *) let root2 = sqrt 2. (* Radians of degrees. *) let rad_of_deg a = a *. pi /. 180. (* Degrees of radians. *) let deg_of_rad a = a *. 180. /. pi (* Constant boolean predicates *) let always _ = true let never _ = false (* A null hash table. *) let null_hash () = Hashtbl.create 0 let tryfind table k = try Some (Hashtbl.find table k) with Not_found -> None (* Extract all (key, value) pairs from a hash table. *) let list_of_hashtbl t = let contents = ref [] in Hashtbl.iter (fun k v -> contents =| (k, v)) t; !contents (* Build a hashtable from a dictionary *) let hashtable_of_dictionary pairs = let table = Hashtbl.create (length pairs * 2) in iter (fun (k, v) -> Hashtbl.add table k v) pairs; table (* Round a number. *) let round x = let c = ceil x in let f = floor x in if c -. x <= x -. f then c else f let iround x = int_of_float (round x) (* Render a float normal by replacing anything abnormal by 0. *) let safe_float f = match classify_float f with | FP_nan | FP_infinite | FP_zero | FP_subnormal -> 0. | _ -> f (* Build a tuple *) let tuple x y = x, y (* Make a unit function. *) let mkunit f x = fun () -> f x (* Swap two elements of an array. *) let swap a i j = let t = a.(i) in a.(i) <- a.(j); a.(j) <- t (* Print floats, integers or int32 values with spaces between them. *) let print_floats fs = iter (fun x -> print_float x; print_string " ") fs; print_newline () let print_ints is = iter (fun x -> print_int x; print_string " ") is; print_newline () let print_int32s is = iter (fun x -> Printf.printf "%li " x) is; print_newline () let leafnames_of_dir d = Array.to_list (Sys.readdir d) (* Roman numerals. *) let roman_vals = [(900, "CM"); (500, "D"); (400, "CD"); (100, "C"); (100, "C"); (100, "C"); (90, "XC"); (50, "L"); (40, "XL"); (10, "X"); (10, "X"); (10, "X"); (9, "IX"); (5, "V"); (4, "IV"); (1, "I"); (1, "I"); (1, "I")] let rec roman n = if n < 1 then "" else if n >= 1000 then implode (many 'M' (n / 1000)) ^ roman (n mod 1000) else let rec roman_recurse n = function | [] -> "" | (n', s)::t -> if n >= n' then s ^ roman_recurse (n - n') t else roman_recurse n t in assert (n > 0 && n < 1000); roman_recurse n roman_vals let roman_upper = roman let roman_lower n = String.lowercase (roman n) let memoize f = let result = ref None in fun () -> match !result with | Some thing -> thing | None -> result := Some (f ()); unopt !result