let ( $$ ) x f = f x
let unSome = function
None -> assert false
| Some x -> x
let o2s o f =
match o with
| None ->
""
| Some x ->
f x
let single = function
| [ x ] ->
x
| _ ->
assert false
let rec mapd f = function
| [] ->
[]
| x :: xs ->
let y1, y2 = f x in
y1 :: y2 :: mapd f xs
let tabulate n f =
let a = Array.init n f in
Array.get a
let tabulateb n f =
let a = Array.init n f in
Array.get a,
Array.fold_left (fun count element ->
if element then count + 1 else count
) 0 a
let tabulatef number fold n dummy f =
let a = Array.make n dummy in
let () = fold (fun () element ->
a.(number element) <- f element
) () in
let get element =
a.(number element)
in
get
let tabulateo number fold n f =
let c = ref 0 in
let get =
tabulatef number fold n None (fun element ->
let image = f element in
begin match image with
| Some _ ->
incr c
| None ->
()
end;
image
)
in
get, !c
let rec truncate k xs =
match k, xs with
| 0, _ ->
[]
| _, [] ->
assert false
| _, x :: xs ->
x :: truncate (k-1) xs
let truncate k xs =
if List.length xs <= k then xs else truncate k xs
let repeat k x =
let rec loop k x accu =
if k = 0 then accu else loop (k - 1) x (x :: accu)
in
loop k x []
module IntSet = Set.Make (struct
type t = int
let compare = ( - )
end)
let separated_list_to_string printer separator list =
let rec loop x = function
| [] ->
printer x
| y :: xs ->
printer x
^ separator
^ loop y xs
in
match list with
| [] ->
""
| x :: xs ->
loop x xs
let index_map string_map =
let n = StringMap.cardinal string_map in
let a = Array.make n None in
let conv, _ = StringMap.fold
(fun k v (conv, idx) ->
a.(idx) <- Some (k, v);
StringMap.add k idx conv, idx + 1)
string_map (StringMap.empty, 0)
in
((fun n -> snd (unSome a.(n))),
(fun k -> StringMap.find k conv),
(fun n -> fst (unSome a.(n))))
let support_assoc l x =
try
List.assoc x l
with Not_found -> x
let index (strings : string list) : int * string array * int StringMap.t =
let name = Array.of_list strings
and n, map = List.fold_left (fun (n, map) s ->
n+1, StringMap.add s n map
) (0, StringMap.empty) strings in
n, name, map
(* Turning an implicit list, stored using pointers through a hash
table, into an explicit list. The head of the implicit list is
not included in the explicit list. *)
let materialize (table : ('a, 'a option) Hashtbl.t) (x : 'a) : 'a list =
let rec loop x =
match Hashtbl.find table x with
| None ->
[]
| Some x ->
x :: loop x
in
loop x
(* [iteri] implements a [for] loop over integers, from 0 to
[n-1]. *)
let iteri n f =
for i = 0 to n - 1 do
f i
done
(* [foldi] implements a [for] loop over integers, from 0 to [n-1],
with an accumulator. [foldij] implements a [for] loop over
integers, from [start] to [n-1], with an accumulator. *)
let foldij start n f accu =
let rec loop i accu =
if i = n then
accu
else
loop (i+1) (f i accu)
in
loop start accu
let foldi n f accu =
foldij 0 n f accu
(* [mapi n f] produces the list [ f 0; ... f (n-1) ]. *)
let mapi n f =
List.rev (
foldi n (fun i accu ->
f i :: accu
) []
)
(* [qfold f accu q] repeatedly takes an element [x] off the queue [q]
and applies [f] to the accumulator and to [x], until [q] becomes
empty. Of course, [f] can add elements to [q] as a side-effect.
We allocate an option to ensure that [qfold] is tail-recursive. *)
let rec qfold f accu q =
match
try
Some (Queue.take q)
with Queue.Empty ->
None
with
| Some x ->
qfold f (f accu x) q
| None ->
accu
(* [qiter f q] repeatedly takes an element [x] off the queue [q] and
applies [f] to [x], until [q] becomes empty. Of course, [f] can add
elements to [q] as a side-effect. *)
let qiter f q =
try
while true do
f (Queue.take q)
done
with Queue.Empty ->
()
let rec smap f = function
| [] ->
[]
| (x :: xs) as l ->
let x' = f x
and xs' = smap f xs in
if x == x' && xs == xs' then
l
else
x' :: xs'
let rec smapa f accu = function
| [] ->
accu, []
| (x :: xs) as l ->
let accu, x' = f accu x in
let accu, xs' = smapa f accu xs in
accu,
if x == x' && xs == xs' then
l
else
x' :: xs'
let normalize s =
let s = String.copy s in
let n = String.length s in
for i = 0 to n - 1 do
match s.[i] with
| '('
| ')'
| ',' ->
s.[i] <- '_'
| _ ->
()
done;
s
(* [postincrement r] increments [r] and returns its original value. *)
let postincrement r =
let x = !r in
r := x + 1;
x
(* [gcp] returns the greatest common prefix of two strings. *)
let gcp s1 s2 =
let n1 = String.length s1
and n2 = String.length s2 in
let rec loop i =
if (i < n1) && (i < n2) && (s1.[i] = s2.[i]) then
loop (i+1)
else
String.sub s1 0 i
in
loop 0
(* [gcps] returns the greatest common prefix of a nonempty list of strings. *)
let gcps = function
| [] ->
assert false
| s :: ss ->
let rec loop accu = function
| [] ->
accu
| s :: ss ->
loop (gcp s accu) ss
in
loop s ss
(* [array_forall p a] computes the conjunction of the predicate [p] over all
elements of the array [a]. *)
exception ArrayForall
let _ArrayForall =
ArrayForall
let array_forall (p : 'a -> bool) (a : 'a array) : bool =
try
for i = 0 to Array.length a - 1 do
let x = Array.get a i in
if not (p x) then
raise _ArrayForall
done;
true
with ArrayForall ->
false