Source file common2.ml

(*s: common.ml *)
(* Yoann Padioleau
 *
 * Copyright (C) 1998-2009 Yoann Padioleau
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * version 2.1 as published by the Free Software Foundation, with the
 * special exception on linking described in file license.txt.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
 * license.txt for more details.
 *)
(*x: common.ml *)
(*###########################################################################*)
(* Prelude *)
(*###########################################################################*)

(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)

(* The following functions should be in their respective sections but
 * because some functions in some sections use functions in other
 * sections, and because I don't want to take care of the order of
 * those sections, of those dependencies, I put the functions causing
 * dependency problem here. C is better than caml on this with the
 * ability to declare prototype, enabling some form of forward
 * reference.
 *)

exception Timeout
exception UnixExit of int

let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
  if i = 0 then () else (f (); do_n (i-1) f)
let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i ->
  if i = 0 then acc else foldn f (f acc i) (i-1)

let sum_int   = List.fold_left (+) 0

(* could really call it 'for' :) *)
let fold_left_with_index f acc =
  let rec fold_lwi_aux acc n = function
    | [] -> acc
    | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs
  in fold_lwi_aux acc 0


let rec drop n xs =
  match (n,xs) with
  | (0,_) -> xs
  | (_,[]) -> failwith "drop: not enough"
  | (n,x::xs) -> drop (n-1) xs

let rec enum_orig x n = if x = n then [n] else x::enum_orig (x+1)  n

let enum x n =
  if not(x <= n)
  then failwith (Printf.sprintf "bad values in enum, expect %d <= %d" x n);
  let rec enum_aux acc x n =
    if x = n then n::acc else enum_aux (x::acc) (x+1) n
  in
  List.rev (enum_aux [] x n)
let enum_safe x n =
  if x > n
  then []
  else enum x n

let rec take n xs =
  match (n,xs) with
  | (0,_) -> []
  | (_,[]) -> failwith "Common.take: not enough"
  | (n,x::xs) -> x::take (n-1) xs


let exclude p xs =
  List.filter (fun x -> not (p x)) xs

let last_n n l = List.rev (take n (List.rev l))
(*let last l = List.hd (last_n 1 l) *)
let rec list_last = function
  | [] -> raise Not_found
  | [x] -> x
  | x::y::xs -> list_last (y::xs)


let (list_of_string: string -> char list) = function
    "" -> []
  | s -> (enum 0 ((String.length s) - 1) |> List.map (String.get s))

let (lines: string -> string list) = fun s ->
  let rec lines_aux = function
    | [] -> []
    | [x] -> if x = "" then [] else [x]
    | x::xs ->
        x::lines_aux xs
  in
  Str.split_delim (Str.regexp "\n") s |> lines_aux


let push v l =
  l := v :: !l

let null xs = match xs with [] -> true | _ -> false


let command2 s = ignore(Sys.command s)


let (matched: int -> string -> string) = fun i s ->
  Str.matched_group i s

let matched1 = fun s -> matched 1 s
let matched2 = fun s -> (matched 1 s, matched 2 s)
let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s)
let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s)
let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s)
let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s)
let matched7 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s, matched 7 s)

let (with_open_stringbuf: (((string -> unit) * Buffer.t) -> unit) -> string) =
 fun f ->
  let buf = Buffer.create 1000 in
  let pr s = Buffer.add_string buf (s ^ "\n") in
  f (pr, buf);
  Buffer.contents buf


let foldl1 p xs = 
  match xs with
  | x::xs -> List.fold_left p x xs 
  | [] -> failwith "foldl1: empty list"

let rec repeat e n =
    let rec repeat_aux acc = function
      | 0 -> acc
      | n when n < 0 -> failwith "repeat"
      | n -> repeat_aux (e::acc) (n-1) in
    repeat_aux [] n

(*###########################################################################*)
(* Basic features *)
(*###########################################################################*)

(*****************************************************************************)
(* Debugging/logging *)
(*****************************************************************************)

(* I used this in coccinelle where the huge logging of stuff ask for
 * a more organized solution that use more visual indentation hints.
 *
 * todo? could maybe use log4j instead ? or use Format module more
 * consistently ?
 *)

let _tab_level_print = ref 0
let _tab_indent = 5


let _prefix_pr = ref ""

let indent_do f =
  _tab_level_print := !_tab_level_print + _tab_indent;
  Common.finalize f
   (fun () -> _tab_level_print := !_tab_level_print - _tab_indent;)


let pr s =
  print_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> print_string " ");
  print_string s;
  print_string "\n";
  flush stdout

let pr_no_nl s =
  print_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> print_string " ");
  print_string s;
  flush stdout






let _chan_pr2 = ref (None: out_channel option)

let out_chan_pr2 ?(newline=true) s =
  match !_chan_pr2 with
  | None -> ()
  | Some chan ->
      output_string chan (s ^ (if newline then "\n" else ""));
      flush chan


let pr2 s =
  prerr_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> prerr_string " ");
  prerr_string s;
  prerr_string "\n";
  flush stderr;
  out_chan_pr2 s;
  ()

let pr2_no_nl s =
  prerr_string !_prefix_pr;
  do_n !_tab_level_print (fun () -> prerr_string " ");
  prerr_string s;
  flush stderr;
  out_chan_pr2 ~newline:false s;
  ()


let pr_xxxxxxxxxxxxxxxxx () =
  pr "-----------------------------------------------------------------------"

let pr2_xxxxxxxxxxxxxxxxx () =
  pr2 "-----------------------------------------------------------------------"


let reset_pr_indent () =
  _tab_level_print := 0

(* old:
 * let pr s = (print_string s; print_string "\n"; flush stdout)
 * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr)
 *)

(* ---------------------------------------------------------------------- *)

(* I can not use the _xxx ref tech that I use for common_extra.ml here because
 * ocaml don't like the polymorphism of Dumper mixed with refs.
 *
 * let (_dump_func : ('a -> string) ref) = ref
 * (fun x -> failwith "no dump yet, have you included common_extra.cmo?")
 * let (dump : 'a -> string) = fun x ->
 * !_dump_func x
 *
 * So I have included directly dumper.ml in common.ml. It's more practical
 * when want to give script that use my common.ml, I just have to give
 * this file.
 *)

(* start of dumper.ml *)

(* Dump an OCaml value into a printable string.
 * By Richard W.M. Jones (rich@annexia.org).
 * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp
 *)
open Printf
open Obj

let rec dump2 r =
  if is_int r then
    string_of_int (magic r : int)
  else (				(* Block. *)
    let rec get_fields acc = function
      | 0 -> acc
      | n -> let n = n-1 in get_fields (field r n :: acc) n
    in
    let rec is_list r =
      if is_int r then (
        if (magic r : int) = 0 then true (* [] *)
        else false
      ) else (
        let s = size r and t = tag r in
        if t = 0 && s = 2 then is_list (field r 1) (* h :: t *)
        else false
      )
    in
    let rec get_list r =
      if is_int r then []
      else let h = field r 0 and t = get_list (field r 1) in h :: t
    in
    let opaque name =
      (* XXX In future, print the address of value 'r'.  Not possible in
       * pure OCaml at the moment.
       *)
      "<" ^ name ^ ">"
    in

    let s = size r and t = tag r in

    (* From the tag, determine the type of block. *)
    if is_list r then ( (* List. *)
      let fields = get_list r in
      "[" ^ String.concat "; " (List.map dump2 fields) ^ "]"
    )
    else if t = 0 then (		(* Tuple, array, record. *)
      let fields = get_fields [] s in
      "(" ^ String.concat ", " (List.map dump2 fields) ^ ")"
    )

    (* Note that [lazy_tag .. forward_tag] are < no_scan_tag.  Not
     * clear if very large constructed values could have the same
     * tag. XXX *)
    else if t = lazy_tag then opaque "lazy"
    else if t = closure_tag then opaque "closure"
    else if t = object_tag then (	(* Object. *)
      let fields = get_fields [] s in
      let clasz, id, slots =
        match fields with h::h'::t -> h, h', t | _ -> assert false in
      (* No information on decoding the class (first field).  So just print
       * out the ID and the slots.
       *)
      "Object #" ^ dump2 id ^
        " (" ^ String.concat ", " (List.map dump2 slots) ^ ")"
    )
    else if t = infix_tag then opaque "infix"
    else if t = forward_tag then opaque "forward"

    else if t < no_scan_tag then (	(* Constructed value. *)
      let fields = get_fields [] s in
      "Tag" ^ string_of_int t ^
        " (" ^ String.concat ", " (List.map dump2 fields) ^ ")"
    )
    else if t = string_tag then (
      "\"" ^ String.escaped (magic r : string) ^ "\""
    )
    else if t = double_tag then (
      string_of_float (magic r : float)
    )
    else if t = abstract_tag then opaque "abstract"
    else if t = custom_tag then opaque "custom"
    else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")")
  )

let dump v = dump2 (repr v)

(* end of dumper.ml *)

(*
let (dump : 'a -> string) = fun x ->
  Dumper.dump x
*)

(* ---------------------------------------------------------------------- *)
let pr2_gen x = pr2 (dump x)

(* ---------------------------------------------------------------------- *)
let xxx_once f s =
  if !Common.disable_pr2_once then pr2 s
  else
    if not (Hashtbl.mem Common._already_printed s)
    then begin
      Hashtbl.add Common._already_printed s true;
      f ("(ONCE) " ^ s);
    end

let pr2_once s = xxx_once pr2 s

(* ---------------------------------------------------------------------- *)
let mk_pr2_wrappers aref =
  let fpr2 s =
    if !aref
    then pr2 s
    else
      (* just to the log file *)
      out_chan_pr2 s
  in
  let fpr2_once s =
    if !aref
    then pr2_once s
    else
      xxx_once out_chan_pr2 s
  in
    fpr2, fpr2_once

(* ---------------------------------------------------------------------- *)
(* could also be in File section *)

let redirect_stdout file f =
  begin
    let chan = open_out file in
    let descr = Unix.descr_of_out_channel chan in

    let saveout = Unix.dup Unix.stdout in
    Unix.dup2 descr Unix.stdout;
    flush stdout;
    let res = f () in
    flush stdout;
    Unix.dup2 saveout Unix.stdout;
    close_out chan;
    res
  end

let redirect_stdout_opt optfile f =
  match optfile with
    | None -> f ()
    | Some outfile -> redirect_stdout outfile f

let redirect_stdout_stderr file f =
  begin
    let chan = open_out file in
    let descr = Unix.descr_of_out_channel chan in

    let saveout = Unix.dup Unix.stdout in
    let saveerr = Unix.dup Unix.stderr in
    Unix.dup2 descr Unix.stdout;
    Unix.dup2 descr Unix.stderr;
    flush stdout; flush stderr;
    f ();
    flush stdout; flush stderr;
    Unix.dup2 saveout Unix.stdout;
    Unix.dup2 saveerr Unix.stderr;
    close_out chan;
  end

let redirect_stdin file f =
  begin
    let chan = open_in file in
    let descr = Unix.descr_of_in_channel chan in

    let savein = Unix.dup Unix.stdin in
    Unix.dup2 descr Unix.stdin;
    f ();
    Unix.dup2 savein Unix.stdin;
    close_in chan;
  end

let redirect_stdin_opt optfile f =
  match optfile with
  | None -> f ()
  | Some infile -> redirect_stdin infile f


(* cf end
let with_pr2_to_string f =
*)


(* ---------------------------------------------------------------------- *)

(* old: include Printf, include are evil and graph_code_cmt does not like them*)
(* cf common.mli, fprintf, printf, eprintf, sprintf.
 * also what is this ?
 *  val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a
 *  val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
 *)

(* ex of printf:
 *  printf "%02d" i
 * for padding
 *)

let spf = Printf.sprintf

(* ---------------------------------------------------------------------- *)

let _chan = ref stderr
let start_log_file () =
  let filename = (spf "/tmp/debugml%d:%d" (Unix.getuid()) (Unix.getpid())) in
  pr2 (spf "now using %s for logging" filename);
  _chan := open_out filename


let dolog s = output_string !_chan (s ^ "\n"); flush !_chan

let verbose_level = ref 1
let log s =  if !verbose_level >= 1 then dolog s
let log2 s = if !verbose_level >= 2 then dolog s
let log3 s = if !verbose_level >= 3 then dolog s
let log4 s = if !verbose_level >= 4 then dolog s

let if_log f = if !verbose_level >= 1 then f ()
let if_log2 f = if !verbose_level >= 2 then f ()
let if_log3 f = if !verbose_level >= 3 then f ()
let if_log4 f = if !verbose_level >= 4 then f ()

(* ---------------------------------------------------------------------- *)

let pause () = (pr2 "pause: type return"; ignore(read_line ()))

(* src: from getopt from frish *)
let bip ()  = Printf.printf "\007"; flush stdout
let wait () = Unix.sleep 1

(* was used by fix_caml *)
let _trace_var = ref 0
let add_var() = incr _trace_var
let dec_var() = decr _trace_var
let get_var() = !_trace_var

let (print_n: int -> string -> unit) = fun i s ->
  do_n i (fun () -> print_string s)
let (printerr_n: int -> string -> unit) = fun i s ->
  do_n i (fun () -> prerr_string s)

let _debug = ref true
let debugon  () = _debug := true
let debugoff () = _debug := false
let debug f = if !_debug then f () else ()

(*****************************************************************************)
(* Profiling *)
(*****************************************************************************)

(* now near cmd_to_list: let get_mem() = *)


let memory_stat () =
  let stat = Gc.stat() in
  let conv_mo x = x * 4 / 1000000 in
  Printf.sprintf "maximal = %d Mo\n" (conv_mo stat.Gc.top_heap_words) ^
  Printf.sprintf "current = %d Mo\n" (conv_mo stat.Gc.heap_words) ^
  Printf.sprintf "lives   = %d Mo\n" (conv_mo stat.Gc.live_words)
  (* Printf.printf "fragments = %d Mo\n" (conv_mo stat.Gc.fragments); *)

let timenow () =
  "sys:" ^ (string_of_float (Sys.time ())) ^ " seconds" ^
  ":real:" ^
    (let tm = Unix.time () |> Unix.gmtime in
     (tm.Unix.tm_min |> string_of_int) ^ " min:" ^
     (tm.Unix.tm_sec |> string_of_int) ^ ".00 seconds")

let _count1 = ref 0
let _count2 = ref 0
let _count3 = ref 0
let _count4 = ref 0
let _count5 = ref 0

let count1 () = incr _count1
let count2 () = incr _count2
let count3 () = incr _count3
let count4 () = incr _count4
let count5 () = incr _count5

let profile_diagnostic_basic () =
  Printf.sprintf
    "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n"
    !_count1 !_count2 !_count3 !_count4 !_count5

let time_func f =
  (*   let _ = Timing () in *)
  let x = f () in
  (*   let _ = Timing () in *)
  x

(*****************************************************************************)
(* Test *)
(*****************************************************************************)

(* See also OUnit *)

(* commented because does not play well with js_of_ocaml
*)
let example b =
  if b
  then ()
  else failwith ("ASSERT FAILURE: " ^ (Printexc.get_backtrace ()))
let _ex1 = assert (enum 1 4 = [1;2;3;4])

let assert_equal a b =
  if not (a = b)
  then failwith ("assert_equal: those 2 values are not equal:\n\t" ^
                 (dump a) ^ "\n\t" ^ (dump b) ^ "\n")

let (example2: string -> bool -> unit) = fun s b ->
  try assert b with x -> failwith s

(*-------------------------------------------------------------------*)
let _list_bool = ref []

let (example3: string -> bool -> unit) = fun s b ->
 _list_bool := (s,b)::(!_list_bool)

(* could introduce a fun () otherwise the calculus is made at compile time
 * and this can be long. This would require to redefine test_all.
 *   let (example3: string -> (unit -> bool) -> unit) = fun s func ->
 *   _list_bool := (s,func):: (!_list_bool)
 *
 * I would like to do as a func that take 2 terms, and make an = over it
 * avoid to add this ugly fun (), but pb of type, cant do that :(
 *)


let (test_all: unit -> unit) = fun () ->
  List.iter (fun (s, b) ->
    Printf.printf "%s: %s\n" s (if b then "passed" else "failed")
  ) !_list_bool

let (test: string -> unit) = fun s ->
  Printf.printf "%s: %s\n" s
    (if (List.assoc s (!_list_bool)) then "passed" else "failed")


let (++) a b =
  Common.profile_code "++" (fun () -> a @ b)

let _ex = example3 "++" ([1;2]@[3;4;5] = [1;2;3;4;5])

(*-------------------------------------------------------------------*)
(* Regression testing *)
(*-------------------------------------------------------------------*)

(* cf end of file. It uses too many other common functions so I
 * have put the code at the end of this file.
 *)



(* todo? take code from julien signoles in calendar-2.0.2/tests *)
(*

(* Generic functions used in the tests. *)

val reset : unit -> unit
val nb_ok : unit -> int
val nb_bug : unit -> int
val test : bool -> string -> unit
val test_exn : 'a Lazy.t -> string -> unit


let ok_ref = ref 0
let ok () = incr ok_ref
let nb_ok () = !ok_ref

let bug_ref = ref 0
let bug () = incr bug_ref
let nb_bug () = !bug_ref

let reset () =
  ok_ref := 0;
  bug_ref := 0

let test x s =
  if x then ok () else begin Printf.printf "%s\n" s; bug () end;;

let test_exn x s =
  try
    ignore (Lazy.force x);
    Printf.printf "%s\n" s;
    bug ()
  with _ ->
    ok ();;
*)


(*****************************************************************************)
(* Quickcheck like (sfl) *)
(*****************************************************************************)

(* related work:
 *  - http://cedeela.fr/quickcheck-for-ocaml.html
 *)

(*---------------------------------------------------------------------------*)
(* generators *)
(*---------------------------------------------------------------------------*)
type 'a gen = unit -> 'a

let (ig: int gen) = fun () ->
  Random.int 10
let (lg: ('a gen) -> ('a list) gen) = fun gen () ->
  foldn (fun acc i -> (gen ())::acc) [] (Random.int 10)
let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () ->
  (gen1 (), gen2 ())
let polyg = ig
let (ng: (string gen)) = fun () ->
  "a" ^ (string_of_int (ig ()))

let (oneofl: ('a list) -> 'a gen) = fun xs () ->
  List.nth xs (Random.int (List.length xs))
(* let oneofl l = oneof (List.map always l) *)

let (oneof: (('a gen) list) -> 'a gen) = fun xs ->
  List.nth xs (Random.int (List.length xs))

let (always: 'a -> 'a gen) = fun e () -> e

let (frequency: ((int * ('a gen)) list) -> 'a gen) = fun xs ->
  let sums = sum_int (List.map fst xs) in
  let i = Random.int sums in
  let rec freq_aux acc = function
    | (x,g)::xs -> if i < acc+x then g else freq_aux (acc+x) xs
    | _ -> failwith "frequency"
  in
  freq_aux 0 xs
let frequencyl l = frequency (List.map (fun (i,e) -> (i,always e)) l)

(*
let b = oneof [always true; always false] ()
let b = frequency [3, always true; 2, always false] ()
*)

(* cant do this:
 *    let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneofl [[]; lg gen ()]
 * nor
 *    let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneof [always []; lg gen]
 *
 * because caml is not as lazy as haskell :( fix the pb by introducing a size
 * limit. take the bounds/size as parameter. morover this is needed for
 * more complex type.
 *
 * how make a bintreeg ?? we need recursion
 *
 * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () ->
 * let rec aux n =
 * if n = 0 then (Leaf (gen ()))
 * else frequencyl [1, Leaf (gen ()); 4, Branch ((aux (n / 2)), aux (n / 2))]
 * ()
 * in aux 20
 *
 *)


(*---------------------------------------------------------------------------*)
(* property *)
(*---------------------------------------------------------------------------*)

(* todo: a test_all_laws, better syntax (done already a little with ig in
 * place of intg. En cas d'erreur, print the arg that not respect
 *
 * todo: with monitoring, as in haskell, laws = laws2, no need for 2 func,
 * but hard i found
 *
 * todo classify, collect, forall
 *)


(* return None when good, and Just the_problematic_case when bad *)
let (laws: string -> ('a -> bool) -> ('a gen) -> 'a option) = fun s func gen ->
  let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in
  let res = List.filter (fun (x,b) -> not b) res in
  if res = [] then None else Some (fst (List.hd res))

let rec (statistic_number: ('a list) -> (int * 'a) list) = function
  | []    -> []
  | x::xs -> let (splitg, splitd) = List.partition (fun y -> y = x) xs in
    (1+(List.length splitg), x)::(statistic_number splitd)

(* in pourcentage *)
let (statistic: ('a list) -> (int * 'a) list) = fun xs ->
  let stat_num = statistic_number xs in
  let totals = sum_int (List.map fst stat_num) in
  List.map (fun (i, v) -> ((i * 100) / totals), v) stat_num

let (laws2:
        string -> ('a -> (bool * 'b)) -> ('a gen) ->
        ('a option * ((int * 'b) list ))) =
  fun s func gen ->
  let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in
  let stat = statistic (List.map (fun (x,(b,v)) -> v) res) in
  let res = List.filter (fun (x,(b,v)) -> not b) res in
  if res = [] then (None, stat) else (Some (fst (List.hd res)), stat)



(* todo, do with coarbitrary ?? idea is that given a 'a, generate a 'b
 * depending of 'a and gen 'b, that is modify gen 'b, what is important is
 * that each time given the same 'a, we must get the same 'b !!!
 *)

(*
let (fg: ('a gen) -> ('b gen) -> ('a -> 'b) gen) = fun gen1 gen2 () ->
let b = laws "funs" (fun (f,g,h) -> x <= y ==> (max x y  = y)       )(pg ig ig)
 *)

(*
let one_of xs = List.nth xs (Random.int (List.length xs))
let take_one xs =
  if empty xs then failwith "Take_one: empty list"
  else
    let i = Random.int (List.length xs) in
    List.nth xs i, filter_index (fun j _ -> i <> j) xs
*)

(*****************************************************************************)
(* Persistence *)
(*****************************************************************************)

let get_value filename =
  let chan = open_in filename in
  let x = input_value chan in (* <=> Marshal.from_channel  *)
  (close_in chan; x)

let write_value valu filename =
  let chan = open_out filename in
  (output_value chan valu;  (* <=> Marshal.to_channel *)
   (* Marshal.to_channel chan valu [Marshal.Closures]; *)
   close_out chan)

let write_back func filename =
  write_value (func (get_value filename)) filename


let read_value f = get_value f


let marshal__to_string2 v flags =
  Marshal.to_string v flags
let marshal__to_string a b =
  Common.profile_code "Marshalling" (fun () -> marshal__to_string2 a b)

let marshal__from_string2 v flags =
  Marshal.from_string v flags
let marshal__from_string a b =
  Common.profile_code "Marshalling" (fun () -> marshal__from_string2 a b)



(*****************************************************************************)
(* Counter *)
(*****************************************************************************)
let _counter = ref 0
let counter () = (_counter := !_counter +1; !_counter)

let _counter2 = ref 0
let counter2 () = (_counter2 := !_counter2 +1; !_counter2)

let _counter3 = ref 0
let counter3 () = (_counter3 := !_counter3 +1; !_counter3)

type timestamp = int

(*****************************************************************************)
(* String_of *)
(*****************************************************************************)
(* To work with the macro system autogenerated string_of and print_ function
   (kind of deriving a la haskell) *)

(* int, bool, char, float, ref ?, string *)

let string_of_string s = "\"" ^ s "\""

let string_of_list f xs =
  "[" ^ (xs |> List.map f |> String.concat ";" ) ^ "]"

let string_of_unit () = "()"

let string_of_array f xs =
  "[|" ^ (xs |> Array.to_list |> List.map f |> String.concat ";") ^ "|]"

let string_of_option f = function
  | None   -> "None "
  | Some x -> "Some " ^ (f x)




let print_bool x = print_string (if x then  "True" else "False")

let print_option pr = function
  | None   -> print_string "None"
  | Some x -> print_string "Some ("; pr x; print_string ")"

let print_list pr xs =
  begin
    print_string "[";
    List.iter (fun x -> pr x; print_string ",") xs;
    print_string "]";
  end

(* specialised
let (string_of_list: char list -> string) =
  List.fold_left (fun acc x -> acc^(Char.escaped x)) ""
*)


let rec print_between between fn = function
  | [] -> ()
  | [x] -> fn x
  | x::xs -> fn x; between(); print_between between fn xs




let adjust_pp_with_indent f =
  Format.open_box !_tab_level_print;
  (*Format.force_newline();*)
  f ();
  Format.close_box ();
  Format.print_newline()

let adjust_pp_with_indent_and_header s f =
  Format.open_box (!_tab_level_print + String.length s);
  do_n !_tab_level_print (fun () -> Format.print_string " ");
  Format.print_string s;
  f ();
  Format.close_box ();
  Format.print_newline()



let pp_do_in_box f      = Format.open_box 1; f (); Format.close_box ()
let pp_do_in_zero_box f = Format.open_box 0; f (); Format.close_box ()

let pp_f_in_box f      =
  Format.open_box 1;
  let res = f () in
  Format.close_box ();
  res

let pp s = Format.print_string s

(*
 * use as
 * let category__str_conv = [
 *   BackGround, "background";
 *   ForeGround, "ForeGround";
 *   ...
 * ]
 *
 * let (category_of_string, str_of_category) =
 * Common.mk_str_func_of_assoc_conv category__str_conv
 *
 *)
let mk_str_func_of_assoc_conv xs =
  let swap (x,y) = (y,x) in

  (fun s ->
    let xs' = List.map swap xs in
    List.assoc s xs'
  ),
  (fun a ->
    List.assoc a xs
  )



(* julia: convert something printed using format to print into a string *)
(* now at bottom of file
let format_to_string f =
 ...
*)



(*****************************************************************************)
(* Macro *)
(*****************************************************************************)

(* put your macro in macro.ml4, and you can test it interactivly as in lisp *)
let macro_expand s =
  let c = open_out "/tmp/ttttt.ml" in
  begin
    output_string c s; close_out c;
    command2 ("ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' " ^
             "-I +camlp4 -impl macro.ml4");
    command2 "camlp4o ./macro.cmo pr_o.cmo /tmp/ttttt.ml";
    command2 "rm -f /tmp/ttttt.ml";
  end

(*
let t = macro_expand "{ x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x>2 and y<3}"
let x = { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3}
let t = macro_expand "{1 .. 10}"
let x = {1 .. 10} +> List.map (fun i -> i)
let t = macro_expand "[1;2] to append to [2;4]"
let t = macro_expand "{x = 2; x = 3}"

let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)"
*)



(*****************************************************************************)
(* Composition/Control *)
(*****************************************************************************)

(* now in prelude:
 * let (+>) o f = f o
 *)
let (+!>) refo f = refo := f !refo
(* alternatives:
 *  let ((@): 'a -> ('a -> 'b) -> 'b) = fun a b -> b a
 *  let o f g x = f (g x)
 *)

let ($)     f g x = g (f x)
let compose f g x = f (g x)
(* dont work :( let ( rond_utf_symbol ) f g x = f(g(x)) *)

(* trick to have something similar to the   1 `max` 4   haskell infix notation.
   by Keisuke Nakano on the caml mailing list.
>    let ( /* ) x y = y x
>    and ( */ ) x y = x y
or
  let ( <| ) x y = y x
  and ( |> ) x y = x y

> Then we can make an infix operator <| f |> for a binary function f.
*)

let flip f = fun a b -> f b a

let curry f x y = f (x,y)
let uncurry f (a,b) = f a b

let id = fun x -> x

let const x = (fun y -> x)

let do_nothing () = ()

let rec applyn n f o = if n = 0 then o else applyn (n-1) f (f o)

let forever f =
  while true do
    f ();
  done


class ['a] shared_variable_hook (x:'a) =
  object(self)
    val mutable data = x
    val mutable registered = []
    method set x =
      begin
        data <- x;
        pr "refresh registered";
        registered |> List.iter (fun f -> f ());
      end
    method get = data
    method modify f = self#set (f self#get)
    method register f =
      registered <- f :: registered
  end

(* src: from aop project. was called ptFix *)
let rec fixpoint trans elem =
  let image = trans elem in
  if (image = elem)
  then elem (* point fixe *)
  else fixpoint trans image

(* le point fixe  pour les objets. was called ptFixForObjetct *)
let rec fixpoint_for_object trans elem =
  let image = trans elem in
  if (image#equal elem) then elem (* point fixe *)
  else fixpoint_for_object trans image

let (add_hook: ('a -> ('a -> 'b) -> 'b) ref  -> ('a -> ('a -> 'b) -> 'b) -> unit) =
 fun var f ->
  let oldvar = !var in
  var := fun arg k -> f arg (fun x -> oldvar x k)

let (add_hook_action: ('a -> unit) ->   ('a -> unit) list ref -> unit) =
 fun f hooks ->
  push f hooks

let (run_hooks_action: 'a -> ('a -> unit) list ref -> unit) =
 fun obj hooks ->
  !hooks |> List.iter (fun f -> try f obj with _ -> ())


type 'a mylazy = (unit -> 'a)

(* a la emacs.
 * bugfix: add finalize, otherwise exns can mess up the reference
 *)
let save_excursion reference newv f =
  let old = !reference in
  reference := newv;
  Common.finalize f (fun _ -> reference := old;)

let save_excursion_and_disable reference f =
  save_excursion reference false (fun () ->
    f ()
  )

let save_excursion_and_enable reference f =
  save_excursion reference true (fun () ->
    f ()
  )


let memoized ?(use_cache=true) h k f =
  if not use_cache
  then f ()
  else
    try Hashtbl.find h k
    with Not_found ->
      let v = f () in
      begin
        Hashtbl.add h k v;
        v
      end

let cache_in_ref myref f =
  match !myref with
  | Some e -> e
  | None ->
      let e = f () in
      myref := Some e;
      e

let oncef f =
  let already = ref false in
  (fun x ->
    if not !already
    then begin already := true; f x end
  )

let once aref f =
  if !aref then ()
  else begin
    aref := true;
    f ()
  end

(* cache_file, cf below *)

let before_leaving f x =
  f x;
  x

(* finalize, cf prelude *)


(* cheat *)
let rec y f = fun x -> f (y f) x

(*****************************************************************************)
(* Concurrency *)
(*****************************************************************************)

(* from http://en.wikipedia.org/wiki/File_locking
 *
 * "When using file locks, care must be taken to ensure that operations
 * are atomic. When creating the lock, the process must verify that it
 * does not exist and then create it, but without allowing another
 * process the opportunity to create it in the meantime. Various
 * schemes are used to implement this, such as taking advantage of
 * system calls designed for this purpose (but such system calls are
 * not usually available to shell scripts) or by creating the lock file
 * under a temporary name and then attempting to move it into place."
 *
 * => can't use 'if(not (file_exist xxx)) then create_file xxx' because
 * file_exist/create_file are not in atomic section (classic problem).
 *
 * from man open:
 *
 * "O_EXCL When used with O_CREAT, if the file already exists it
 * is an error and the open() will fail. In this context, a
 * symbolic link exists, regardless of where it points to.
 * O_EXCL is broken on NFS file systems; programs which
 * rely on it for performing locking tasks will contain a
 * race condition. The solution for performing atomic file
 * locking using a lockfile is to create a unique file on
 * the same file system (e.g., incorporating host- name and
 * pid), use link(2) to make a link to the lockfile. If
 * link(2) returns 0, the lock is successful. Otherwise,
 * use stat(2) on the unique file to check if its link
 * count has increased to 2, in which case the lock is also
 * successful."

 *)

exception FileAlreadyLocked

(* Racy if lock file on NFS!!! But still racy with recent Linux ? *)
let acquire_file_lock filename =
  pr2 ("Locking file: " ^ filename);
  try
    let _fd = Unix.openfile filename [Unix.O_CREAT;Unix.O_EXCL] 0o777 in
    ()
  with Unix.Unix_error (e, fm, argm) ->
    pr2 (spf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm);
    raise FileAlreadyLocked


let release_file_lock filename =
  pr2 ("Releasing file: " ^ filename);
  Unix.unlink filename;
  ()



(*****************************************************************************)
(* Error managment *)
(*****************************************************************************)

exception Here
exception ReturnExn

exception WrongFormat of string

(* old: let _TODO () = failwith "TODO",  now via fix_caml with raise Todo *)

let internal_error s = failwith ("internal error: "^s)
let error_cant_have x = internal_error ("cant have this case" ^(dump x))
let myassert cond = if cond then () else failwith "assert error"



(* before warning I was forced to do stuff like this:
 *
 * let (fixed_int_to_posmap: fixed_int -> posmap) = fun fixed ->
 * let v = ((fix_to_i fixed) / (power 2 16)) in
 * let _ = Printf.printf "coord xy = %d\n" v in
 * v
 *
 * The need for printf make me force to name stuff :(
 * How avoid ? use 'it' special keyword ?
 * In fact dont have to name it, use +> (fun v -> ...)  so when want
 * erase debug just have to erase one line.
 *)
let warning s v = (pr2 ("Warning: " ^ s ^ "; value = " ^ (dump v)); v)




let exn_to_s exn =
  Printexc.to_string exn

let exn_to_s_with_backtrace exn =
  Printexc.to_string exn ^ "\n" ^ Printexc.get_backtrace ()

(* alias *)
let string_of_exn exn = exn_to_s exn


(* want or of merd, but cant cos cant put die ... in b (strict call) *)
let (|||) a b = try a with _ -> b

(* emacs/lisp inspiration, (vouillon does that too in unison I think) *)

(* now in Prelude:
 * let unwind_protect f cleanup = ...
 * let finalize f cleanup =  ...
 *)

type error = Error of string

(* sometimes to get help from ocaml compiler to tell me places where
 * I should update, we sometimes need to change some type from pair
 * to triple, hence this kind of fake type.
 *)
type evotype = unit
let evoval = ()

(*****************************************************************************)
(* Environment *)
(*****************************************************************************)

let _check_stack = ref true
let check_stack_size limit =
  if !_check_stack then begin
    pr2 "checking stack size (do ulimit -s 40000 if problem)";
    let rec aux i =
      if i = limit
      then 0
      else 1 + aux (i + 1)
    in
    assert(aux 0 = limit);
    ()
  end

let test_check_stack_size limit =
  (* bytecode: 100000000 *)
  (* native:   10000000 *)
  check_stack_size (int_of_string limit)


(* only relevant in bytecode, in native the stacklimit is the os stacklimit
 * (adjustable by ulimit -s)
 *)
let _init_gc_stack =
  ()
(* commented because cause pbs with js_of_ocaml
  Gc.set {(Gc.get ()) with Gc.stack_limit = 100 * 1024 * 1024}
*)

(* if process a big set of files then dont want get overflow in the middle
 * so for this we are ready to spend some extra time at the beginning that
 * could save far more later.
 *
 * On Centos 5.2 with ulimit -s 40000 I can only go up to 2000000 in
 * native mode (and it crash with ulimit -s 10000, which is what we want).
 *)
let check_stack_nbfiles nbfiles =
  if nbfiles > 200
  then check_stack_size 2000000

(*****************************************************************************)
(* Equality *)
(*****************************************************************************)


(* src: caml mailing list ? *)
let (=|=) : int    -> int    -> bool = (=)
let (=<=) : char   -> char   -> bool = (=)
let (=$=) : string -> string -> bool = (=)
let (=:=) : bool   -> bool   -> bool = (=)

let (=*=) = (=)

(* if really want to forbid to use '='
let (=) = (=|=)
*)
let (=) () () = false

(*x: common.ml *)
(*###########################################################################*)
(* Basic types *)
(*###########################################################################*)


(*****************************************************************************)
(* Bool *)
(*****************************************************************************)
let (==>) b1 b2 = if b1 then b2 else true (* could use too => *)

(* superseded by another <=> below
let (<=>) a b = if a =*= b then 0 else if a < b then -1 else 1
*)

let xor a b = not (a =*= b)


(*****************************************************************************)
(* Char *)
(*****************************************************************************)

let string_of_char c = String.make 1 c

let is_single  = String.contains ",;()[]{}_`"
let is_symbol  = String.contains "!@#$%&*+./<=>?\\^|:-~"
let is_space   = String.contains "\n\t "
let cbetween min max c =
  (int_of_char c) <= (int_of_char max) &&
  (int_of_char c) >= (int_of_char min)
let is_upper = cbetween 'A' 'Z'
let is_lower = cbetween 'a' 'z'
let is_alpha c = is_upper c || is_lower c
let is_digit = cbetween '0' '9'

let string_of_chars cs = cs |> List.map (String.make 1) |> String.concat ""



(*****************************************************************************)
(* Num *)
(*****************************************************************************)

(* since 3.08, div by 0 raise Div_by_rezo, and not anymore a hardware trap :)*)
let (/!) x y = if y =|= 0 then (log "common.ml: div by 0"; 0) else x / y

(* now in prelude
 * let rec (do_n: int -> (unit -> unit) -> unit) = fun i f ->
 * if i = 0 then () else (f (); do_n (i-1) f)
 *)

let times f n = do_n n f

(* now in prelude
 * let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i ->
 * if i = 0 then acc else foldn f (f acc i) (i-1)
 *)

let sum_float = List.fold_left (+.) 0.0
(* in prelude: let sum_int   = List.fold_left (+) 0 *)

let pi  = 3.14159265358979323846
let pi2 = pi /. 2.0
let pi4 = pi /. 4.0

(* 180 = pi *)
let (deg_to_rad: float -> float) = fun deg ->
  (deg *. pi) /. 180.0

let clampf = function
  | n when n < 0.0 -> 0.0
  | n when n > 1.0 -> 1.0
  | n -> n

let square x = x *. x

let rec power x n = if n =|= 0 then 1 else x * power x (n-1)

let between i min max = i > min && i < max

let (between_strict: int -> int -> int -> bool) = fun a b c ->
  a < b && b < c


let borne ~min ~max x =
  if x > max then max
  else if x < min then min
  else x


let bitrange x p = let v = power 2 p in between x (-v) v

(* descendant *)
let (prime1: int -> int option)  = fun x ->
  let rec prime1_aux n =
    if n =|= 1 then None
    else
      if (x / n) * n =|= x then Some n else prime1_aux (n-1)
  in if x =|= 1 then None else if x < 0 then failwith "negative" else prime1_aux (x-1)

(* montant, better *)
let (prime: int -> int option)  = fun x ->
  let rec prime_aux n =
    if n =|= x then None
    else
      if (x / n) * n =|= x then Some n else prime_aux (n+1)
  in if x =|= 1 then None else if x < 0 then failwith "negative" else prime_aux 2

let sum xs = List.fold_left (+) 0 xs
let product = List.fold_left ( * ) 1


let decompose x =
  let rec decompose x =
  if x =|= 1 then []
  else
    (match prime x with
    | None -> [x]
    | Some n -> n::decompose (x / n)
    )
  in assert (product (decompose x) =|= x); decompose x

let mysquare x = x * x
let sqr a = a *. a


type compare = Equal | Inf | Sup
let (<=>) a b = if a =*= b then Equal else if a < b then Inf else Sup
let (<==>) a b = if a =*= b then 0 else if a < b then -1 else 1

type uint = int


let int_of_stringchar s =
  fold_left_with_index (fun acc e i -> acc + (Char.code e*(power 8 i))) 0 (List.rev (list_of_string s))

let int_of_base s base =
  fold_left_with_index (fun acc e i ->
    let j = Char.code e - Char.code '0' in
    if j >= base then failwith "not in good base"
    else acc + (j*(power base i))
         )
    0  (List.rev (list_of_string s))

let int_of_stringbits s = int_of_base s 2
let _ = assert (int_of_stringbits "1011" =|= 1*8 + 1*2 + 1*1)

let int_of_octal s = int_of_base s 8
let _ = assert (int_of_octal "017" =|= 15)

(* let int_of_hex s = int_of_base s 16, NONONONO cos 'A' - '0' does not give 10 !! *)

let int_of_all s =
  if String.length s >= 2 && (String.get s 0 =<= '0') && is_digit (String.get s 1)
  then int_of_octal s else int_of_string s


let (+=) ref v = ref := !ref + v
let (-=) ref v = ref := !ref - v

let pourcent x total =
  (x * 100) / total
let pourcent_float x total =
  ((float_of_int x) *. 100.0) /. (float_of_int total)

let pourcent_float_of_floats x total =
  (x *. 100.0) /. total


let pourcent_good_bad good bad =
  (good * 100) / (good + bad)

let pourcent_good_bad_float good bad =
  (float_of_int good *. 100.0) /. (float_of_int good +. float_of_int bad)

type 'a max_with_elem = int ref * 'a ref
let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) =
  if is_better newv aref
  then begin
    aref := newv;
    aelem := newelem;
  end

(*****************************************************************************)
(* Numeric/overloading *)
(*****************************************************************************)

type 'a numdict =
    NumDict of (('a-> 'a -> 'a) *
  ('a-> 'a -> 'a) *
  ('a-> 'a -> 'a) *
  ('a -> 'a));;

let add (NumDict(a, m, d, n)) = a;;
let mul (NumDict(a, m, d, n)) = m;;
let div (NumDict(a, m, d, n)) = d;;
let neg (NumDict(a, m, d, n)) = n;;

let numd_int   = NumDict(( + ),( * ),( / ),( ~- ));;
let numd_float = NumDict(( +. ),( *. ), ( /. ),( ~-. ));;
let testd dict n =
  let ( * ) x y = mul dict x y in
  let ( / ) x y = div dict x y in
  let ( + ) x y = add dict x y in
  (* Now you can define all sorts of things in terms of *, /, + *)
  let f num = (num * num) / (num + num) in
  f n;;



module ArithFloatInfix = struct
    let (+..) = (+)
    let (-..) = (-)
    let (/..) = (/)
    let ( *.. ) = ( * )


    let (+) = (+.)
    let (-) = (-.)
    let (/) = (/.)
    let ( * ) = ( *. )

    let (+=) ref v = ref := !ref + v
    let (-=) ref v = ref := !ref - v

end



(*****************************************************************************)
(* Tuples *)
(*****************************************************************************)

type 'a pair = 'a * 'a
type 'a triple = 'a * 'a * 'a

let fst3 (x,_,_) = x
let snd3 (_,y,_) = y
let thd3 (_,_,z) = z

let sndthd (a,b,c) = (b,c)

let map_fst f (x, y) = f x, y
let map_snd f (x, y) = x, f y

let pair  f (x,y) = (f x, f y)
let triple  f (x,y,z) = (f x, f y, f z)

(* for my ocamlbeautify script *)
(*
let snd = snd
let fst = fst
*)

let double a = a,a
let swap (x,y) = (y,x)


let tuple_of_list1 = function [a] -> a | _ -> failwith "tuple_of_list1"
let tuple_of_list2 = function [a;b] -> a,b | _ -> failwith "tuple_of_list2"
let tuple_of_list3 = function [a;b;c] -> a,b,c | _ -> failwith "tuple_of_list3"
let tuple_of_list4 = function [a;b;c;d] -> a,b,c,d | _ -> failwith "tuple_of_list4"
let tuple_of_list5 = function [a;b;c;d;e] -> a,b,c,d,e | _ -> failwith "tuple_of_list5"
let tuple_of_list6 = function [a;b;c;d;e;f] -> a,b,c,d,e,f | _ -> failwith "tuple_of_list6"


(*****************************************************************************)
(* Maybe *)
(*****************************************************************************)

(* type 'a maybe  = Just of 'a | None *)

type ('a,'b) either = Left of 'a | Right of 'b
  (* with sexp *)
type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c
  (* with sexp *)

let just = function
  | (Some x) -> x
  | _ -> failwith "just: pb"

let some = just


let fmap f = function
  | None -> None
  | Some x -> Some (f x)
let map_option = fmap

let do_option f = function
  | None -> ()
  | Some x -> f x
let opt = do_option

let optionise f =
  try Some (f ()) with Not_found -> None



(* pixel *)
let some_or = function
  | None -> id
  | Some e -> fun _ -> e

let option_to_list = function
  | None -> []
  | Some x -> [x]


let partition_either f l =
  let rec part_either left right = function
  | [] -> (List.rev left, List.rev right)
  | x :: l ->
      (match f x with
      | Left  e -> part_either (e :: left) right l
      | Right e -> part_either left (e :: right) l) in
  part_either [] [] l

let partition_either3 f l =
  let rec part_either left middle right = function
  | [] -> (List.rev left, List.rev middle, List.rev right)
  | x :: l ->
      (match f x with
      | Left3  e -> part_either (e :: left) middle right l
      | Middle3  e -> part_either left (e :: middle) right l
      | Right3 e -> part_either left middle (e :: right) l) in
  part_either [] [] [] l


(* pixel *)
let rec filter_some = function
  | [] -> []
  | None :: l -> filter_some l
  | Some e :: l -> e :: filter_some l

let map_filter f xs = xs |> List.map f |> filter_some

let rec find_some p = function
  | [] -> raise Not_found
  | x :: l ->
      match p x with
      |	Some v -> v
      |	None -> find_some p l

let rec find_some_opt p = function
  | [] -> None
  | x :: l ->
      match p x with
      |	Some v -> Some v
      |	None -> find_some_opt p l

(* same
let map_find f xs =
  xs +> List.map f +> List.find (function Some x -> true | None -> false)
    +> (function Some x -> x | None -> raise Impossible)
*)


let list_to_single_or_exn xs =
  match xs with
  | [] -> raise Not_found
  | x::y::zs -> raise Common.Multi_found
  | [x] -> x


let rec (while_some: gen:(unit-> 'a option) -> f:('a -> 'b) -> unit -> 'b list)
 = fun ~gen ~f () ->
  match gen () with
  | None -> []
  | Some x ->
      let e = f x in
      let rest = while_some gen f () in
      e::rest

(* perl idiom *)
let (||=) aref vf =
  match !aref with
  | None -> aref := Some (vf ())
  | Some _ -> ()

let (>>=) m1 m2 =
  match m1 with
  | None -> None
  | Some x -> m2 x

(* http://roscidus.com/blog/blog/2013/10/13/ocaml-tips/#handling-option-types*)
let (|?) maybe default =
  match maybe with
  | Some v -> v
  | None -> Lazy.force default

(*****************************************************************************)
(* TriBool *)
(*****************************************************************************)

type bool3 = True3 | False3 | TrueFalsePb3 of string



(*****************************************************************************)
(* Regexp, can also use PCRE *)
(*****************************************************************************)


(* put before String section because String section use some =~ *)

(* let gsubst = global_replace *)


let (==~) s re =
  Common.profile_code "Common.==~" (fun () ->
    Str.string_match re s 0
  )

let _memo_compiled_regexp = Hashtbl.create 101
let candidate_match_func s re =
  (* old: Str.string_match (Str.regexp re) s 0 *)
  let compile_re =
    memoized _memo_compiled_regexp re (fun () -> Str.regexp re)
  in
  Str.string_match compile_re s 0

let match_func s re =
  Common.profile_code "Common.=~" (fun () -> candidate_match_func s re)

let (=~) s re =
  match_func s re





let string_match_substring re s =
  try let _i = Str.search_forward re s 0 in true
  with Not_found -> false

(*
let _ =
  example(string_match_substring (Str.regexp "foo") "a foo b")
let _ =
  example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b")
let _ =
  example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b")
let _ =
  example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b")
*)
(* does not work :(
let _ =
  example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b")
*)



let (regexp_match: string -> string -> string) = fun s re ->
  assert(s =~ re);
  Str.matched_group 1 s

(* beurk, side effect code, but hey, it is convenient *)
(* now in prelude
 * let (matched: int -> string -> string) = fun i s ->
 *    Str.matched_group i s
 *
 * let matched1 = fun s -> matched 1 s
 * let matched2 = fun s -> (matched 1 s, matched 2 s)
 * let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s)
 * let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s)
 * let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s)
 * let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s)
 *)



let split sep s = Str.split (Str.regexp sep) s
(*
let _ = example (split "/" "" =*= [])
let _ = example (split ":" ":a:b" =*= ["a";"b"])
*)
let join  sep xs = String.concat sep xs
(*
let _ = example (join "/" ["toto"; "titi"; "tata"] =$= "toto/titi/tata")
*)

(*
let rec join str = function
  | [] -> ""
  | [x] -> x
  | x::xs -> x ^ str ^ (join str xs)
*)

let split_list_regexp_noheading = "__noheading__"

let (split_list_regexp: string -> string list -> (string * string list) list) =
 fun re xs ->
  let rec split_lr_aux (heading, accu) = function
    | [] -> [(heading, List.rev accu)]
    | x::xs ->
        if x =~ re
        then (heading, List.rev accu)::split_lr_aux (x, []) xs
        else split_lr_aux (heading, x::accu) xs
  in
  split_lr_aux ("__noheading__", []) xs
  |> (fun xs -> if (List.hd xs) =*= ("__noheading__",[]) then List.tl xs else xs)



let regexp_alpha =  Str.regexp
  "^[a-zA-Z_][A-Za-z_0-9]*$"


let all_match re s =
  let regexp = Str.regexp re in
  let res = ref [] in
  let _ = Str.global_substitute regexp (fun _s ->
    let substr = Str.matched_string s in
    assert(substr ==~ regexp); (* @Effect: also use it's side effect *)
    let paren_matched = matched1 substr in
    push paren_matched res;
    "" (* @Dummy *)
  ) s in
  List.rev !res

(*
let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment"
                  =*= ["@Et";"@Comment"])
*)

let global_replace_regexp re f_on_substr s =
  let regexp = Str.regexp re in
  Str.global_substitute regexp (fun _wholestr ->

    let substr = Str.matched_string s in
    f_on_substr substr
  ) s


let regexp_word_str =
  "\\([a-zA-Z_][A-Za-z_0-9]*\\)"
let regexp_word = Str.regexp regexp_word_str

let regular_words s =
  all_match regexp_word_str s

let contain_regular_word s =
  let xs = regular_words s in
  List.length xs >= 1


(* This type allows to combine a serie of "regexps" to form a big
 * one representing its union which should then be optimized by the Str
 * module.
 *)
type regexp =
  | Contain of string
  | Start of string
  | End of string
  | Exact of string

let regexp_string_of_regexp x =
  match x with
  | Contain s -> ".*" ^ s ^ ".*"
  | Start s -> "^" ^ s
  | End s -> ".*" ^  s ^ "$"
  | Exact s -> s

let str_regexp_of_regexp x =
  Str.regexp (regexp_string_of_regexp x)

let compile_regexp_union xs =
  xs |> List.map (fun x ->
    regexp_string_of_regexp x
  ) |> join "\\|" |> Str.regexp


(*****************************************************************************)
(* Strings *)
(*****************************************************************************)

let slength = String.length
let concat = String.concat

(* ruby *)
let i_to_s = string_of_int
let s_to_i = int_of_string


(* strings take space in memory. Better when can share the space used by
   similar strings *)
let _shareds = Hashtbl.create 100
let (shared_string: string -> string) = fun s ->
  try Hashtbl.find _shareds s
  with Not_found -> (Hashtbl.add _shareds s s; s)

let chop = function
  | "" -> ""
  | s -> String.sub s 0 (String.length s - 1)


(* remove trailing / *)
let chop_dirsymbol = function
  | s when s =~ "\\(.*\\)/$" -> matched1 s
  | s -> s


let (<!!>) s (i,j) =
  String.sub s i (if j < 0 then String.length s - i + j + 1 else j - i)
(* let _ = example  ( "tototati"<!!>(3,-2) = "otat" ) *)

let (<!>) s i = String.get s i

(* pixel *)
let rec split_on_char c s =
  try
    let sp = String.index s c in
    String.sub s 0 sp ::
    split_on_char c (String.sub s (sp+1) (String.length s - sp - 1))
  with Not_found -> [s]


let quote s = "\"" ^ s ^ "\""
let unquote s =
  if s =~ "\"\\(.*\\)\""
  then matched1 s
  else failwith ("unquote: the string has no quote: " ^ s)

(* easier to have this to be passed as hof, because ocaml dont have
 * haskell "section" operators
 *)
let null_string s =
  s =$= ""

let is_blank_string s =
  s =~ "^\\([ \t]\\)*$"

(* src: lablgtk2/examples/entrycompletion.ml *)
let is_string_prefix s1 s2 =
  (String.length s1 <= String.length s2) &&
  (String.sub s2 0 (String.length s1) =$= s1)

let plural i s =
  if i =|= 1
  then Printf.sprintf "%d %s" i s
  else Printf.sprintf "%d %ss" i s

let showCodeHex xs = List.iter (fun i -> Printf.printf "%02x" i) xs

let take_string n s =
  String.sub s 0 (n-1)

let take_string_safe n s =
  if n > String.length s
  then s
  else take_string n s



(* used by LFS *)
let size_mo_ko i =
  let ko = (i / 1024) mod 1024 in
  let mo = (i / 1024) / 1024 in
  (if mo > 0
  then Printf.sprintf "%dMo%dKo" mo ko
  else Printf.sprintf "%dKo" ko
  )

let size_ko i =
  let ko = i / 1024 in
  Printf.sprintf "%dKo" ko






(* done in summer 2007 for julia
 * Reference: P216 of gusfeld book
 * For two strings S1 and S2, D(i,j) is defined to be the edit distance of S1[1..i] to S2[1..j]
 * So edit distance of S1 (of length n) and S2 (of length m) is D(n,m)
 *
 * Dynamic programming technique
 * base:
 * D(i,0) = i  for all i (cos to go from S1[1..i] to 0 characteres of S2 you have to delete all characters from S1[1..i]
 * D(0,j) = j  for all j (cos j characters must be inserted)
 * recurrence:
 * D(i,j) = min([D(i-1, j)+1, D(i, j - 1 + 1), D(i-1, j-1) + t(i,j)])
 * where t(i,j) is equal to 1 if S1(i) != S2(j) and  0 if equal
 * intuition = there is 4 possible action =  deletion, insertion, substitution, or match
 * so Lemma =
 *
 * D(i,j) must be one of the three
 *  D(i, j-1) + 1
 *  D(i-1, j)+1
 *  D(i-1, j-1) +
 *  t(i,j)
 *
 *
 *)
let matrix_distance s1 s2 =
  let n = (String.length s1) in
  let m = (String.length s2) in
  let mat = Array.make_matrix (n+1) (m+1) 0 in
  let t i j =
    if String.get s1 (i-1) =<= String.get s2 (j-1)
    then 0
    else 1
  in
  let min3 a b c = min (min a b) c in

  begin
    for i = 0 to n do
      mat.(i).(0) <- i
    done;
    for j = 0 to m do
      mat.(0).(j) <- j;
    done;
    for i = 1 to n do
      for j = 1 to m do
        mat.(i).(j) <-
          min3 (mat.(i).(j-1) + 1) (mat.(i-1).(j) + 1) (mat.(i-1).(j-1) + t i j)
      done
    done;
    mat
  end
let edit_distance s1 s2 =
  (matrix_distance s1 s2).(String.length s1).(String.length s2)


let test_edit = edit_distance "vintner" "writers"
let _ = assert (edit_distance "winter" "winter" =|= 0)
let _ = assert (edit_distance "vintner" "writers" =|= 5)


(* src: http://pleac.sourceforge.net/pleac_ocaml/strings.html *)
(* We can emulate the Perl wrap function with the following function *)
let wrap ?(width=80) s =
  let l = Str.split (Str.regexp " ") s in
  Format.pp_set_margin Format.str_formatter width;
  Format.pp_open_box Format.str_formatter 0;
  List.iter
    (fun x ->
      Format.pp_print_string Format.str_formatter x;
      Format.pp_print_break Format.str_formatter 1 0;) l;
  Format.flush_str_formatter ();;

(*****************************************************************************)
(* Filenames *)
(*****************************************************************************)

let dirname = Filename.dirname
let basename = Filename.basename

type filename = string (* TODO could check that exist :) type sux *)
  (* with sexp *)
type dirname = string (* TODO could check that exist :) type sux *)
  (* with sexp *)

(* file or dir *)
type path = string

module BasicType = struct
  type filename = string
end


(* updated: added '-' in filesuffix because of file like foo.c-- *)
let (filesuffix: filename -> string) = fun s ->
  (try regexp_match s ".+\\.\\([a-zA-Z0-9_-]+\\)$" with _ ->  "NOEXT")
let (fileprefix: filename -> string) = fun s ->
  (try regexp_match s "\\(.+\\)\\.\\([a-zA-Z0-9_]+\\)?$" with _ ->  s)

(*
let _ = example (filesuffix "toto.c" =$= "c")
let _ = example (fileprefix "toto.c" =$= "toto")
*)


(*
assert (s = fileprefix s ^ filesuffix s)

let withoutExtension s = global_replace (regexp "\\..*$") "" s
let () = example "without"
    (withoutExtension "toto.s.toto" = "toto")
*)

let adjust_ext_if_needed filename ext =
  if String.get ext 0 <> '.'
  then failwith "I need an extension such as .c not just c";

  if not (filename =~ (".*\\" ^ ext))
  then filename ^ ext
  else filename



let db_of_filename file =
  dirname file, basename file

let filename_of_db (basedir, file) =
  Filename.concat basedir file



let dbe_of_filename file =
  (* raise Invalid_argument if no ext, so safe to use later the unsafe
   * fileprefix and filesuffix functions (well filesuffix is safe by default)
   *)
  ignore(Filename.chop_extension file);
  Filename.dirname file,
  Filename.basename file |> fileprefix,
  Filename.basename file |> filesuffix

let filename_of_dbe (dir, base, ext) =
  if ext =$= ""
  then Filename.concat dir base
  else Filename.concat dir (base ^ "." ^ ext)


let dbe_of_filename_safe file =
  try Left (dbe_of_filename file)
  with Invalid_argument _ ->
    Right (Filename.dirname file, Filename.basename file)


let dbe_of_filename_nodot file =
  let (d,b,e) = dbe_of_filename file in
  let d = if d =$= "." then "" else d in
  d,b,e




(* old:
 * let re_be = Str.regexp "\\([^.]*\\)\\.\\(.*\\)"
 * let dbe_of_filename_noext_ok file =
 *   ...
 *   if Str.string_match re_be base 0
 *   then 
 *     let (b, e) = matched2 base in
 *     (dir, b, e)
 * 
 *  That way files like foo.md5sum.c would not be considered .c
 *  but .md5sum.c, but then it has too many disadvantages because
 *  then regular files like qemu.root.c would not be considered
 *  .c files, so it's better instead to fix syncweb to not generate
 *  .md5sum.c but .md5sum_c files!
 *)

let dbe_of_filename_noext_ok file =
  let dir = Filename.dirname file in
  let base = Filename.basename file in
  dir, fileprefix base, filesuffix base


let replace_ext file oldext newext =
  let (d,b,e) = dbe_of_filename file in
  assert(e =$= oldext);
  filename_of_dbe (d,b,newext)


(* Given a file name, normalize it by removing "." and "..".  This works
 * exclusively by processing the string, not relying on any file system
 * state.
 *
 * This is intended to work on both absolute and relative paths, but I
 * have not tested the latter. 
 *
 * Compared to a previous version of normalize_path,
 * this function normalizes "a/." to "a" and does not drop the leading "/" 
 * on absolute paths. It also does not crash on "/..".
 *
 * author: Scott McPeak.
 *)
let normalize_path (file: string) : string =
  let is_rel = Filename.is_relative file in
  let xs = split "/" file in
  let rec aux acc = function
    | [] -> List.rev acc
    | x::xs ->
        (match x with
        | "." -> aux acc xs
        | ".." ->
            (match acc with
            | [] ->
                if is_rel then
                  (* Keep leading ".." on relative paths. *)
                  aux (x::acc) xs
                else
                  (* Strip leading ".." on absolute paths.  The ".."
                   * directory entry on "/" points to "/". *)
                  aux acc xs
            | [".."] ->
                (* If we kept "..", this must be a relative path that
                 * effectively starts with "..", so keep accumulating
                 * them.  ("../.." does not become "".) *)
                assert is_rel;
                aux (x::acc) xs
            | _ -> aux (List.tl acc) xs
            )
        | x -> aux (x::acc) xs
        )
  in
  let xs' = aux [] xs in
  (if is_rel then "" else "/") ^ (join "/" xs')



(*
let relative_to_absolute s =
  if Filename.is_relative s
  then
    begin
      let old = Sys.getcwd () in
      Sys.chdir s;
      let current = Sys.getcwd () in
      Sys.chdir old;
      s
    end
  else s
*)

let relative_to_absolute s =
  if s =$= "."
  then Sys.getcwd ()
  else
    if Filename.is_relative s
    then Sys.getcwd () ^ "/" ^ s
    else s

let is_relative s = Filename.is_relative s
let is_absolute s = not (is_relative s)


(* pre: prj_path must not contain regexp symbol *)
let filename_without_leading_path prj_path s =
  let prj_path = chop_dirsymbol prj_path in
  if s =$= prj_path
  then "."
  else
    if s =~ ("^" ^ prj_path ^ "/\\(.*\\)$")
    then matched1 s
    else
    failwith
      (spf "cant find filename_without_project_path: %s  %s" prj_path s)


(* realpath: see end of file *)

(* basic file position *)
type filepos = {
  l: int;
  c: int;
}

(*****************************************************************************)
(* i18n *)
(*****************************************************************************)
type langage =
  | English
  | Francais
  | Deutsch

(* gettext ? *)


(*****************************************************************************)
(* Dates *)
(*****************************************************************************)

(* maybe I should use ocamlcalendar, but I don't like all those functors ... *)

type month =
  | Jan  | Feb  | Mar  | Apr  | May  | Jun
  | Jul  | Aug  | Sep  | Oct  | Nov  | Dec
type year = Year of int
type day = Day of int
type wday = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday

type date_dmy = DMY of day * month * year

type hour = Hour of int
type minute = Min of int
type second = Sec of int

type time_hms = HMS of hour * minute * second

type full_date = date_dmy * time_hms


(* intervalle *)
type days = Days of int

type time_dmy = TimeDMY of day * month * year


type float_time = float



let check_date_dmy (DMY (day, month, year)) =
  raise Common.Todo

let check_time_dmy (TimeDMY (day, month, year)) =
  raise Common.Todo

let check_time_hms (HMS (x,y,a)) =
  raise Common.Todo



(* ---------------------------------------------------------------------- *)

(* older code *)
let int_to_month i =
  assert (i <= 12 && i >= 1);
  match i with

  | 1 -> "Jan"
  | 2 -> "Feb"
  | 3 -> "Mar"
  | 4 -> "Apr"
  | 5 -> "May"
  | 6 -> "Jun"
  | 7 -> "Jul"
  | 8 -> "Aug"
  | 9 -> "Sep"
  | 10 -> "Oct"
  | 11 -> "Nov"
  | 12 -> "Dec"
(*
  | 1 -> "January"
  | 2 -> "February"
  | 3 -> "March"
  | 4 -> "April"
  | 5 -> "May"
  | 6 -> "June"
  | 7 -> "July"
  | 8 -> "August"
  | 9 -> "September"
  | 10 -> "October"
  | 11 -> "November"
  | 12 -> "December"
*)
  | _ -> raise Common.Impossible


let month_info = [
  1, Jan, "Jan", "January", 31;
  2, Feb, "Feb", "February", 28;
  3, Mar, "Mar", "March", 31;
  4, Apr, "Apr", "April", 30;
  5, May, "May", "May", 31;
  6, Jun, "Jun", "June", 30;
  7, Jul, "Jul", "July", 31;
  8, Aug, "Aug", "August", 31;
  9, Sep, "Sep", "September", 30;
  10, Oct, "Oct", "October", 31;
  11, Nov, "Nov", "November", 30;
  12, Dec, "Dec", "December", 31;
]

let week_day_info = [
  0, Sunday, "Sun", "Dim", "Sunday";
  1, Monday, "Mon", "Lun", "Monday";
  2, Tuesday, "Tue", "Mar", "Tuesday";
  3, Wednesday, "Wed", "Mer", "Wednesday";
  4, Thursday, "Thu","Jeu","Thursday";
  5, Friday, "Fri", "Ven", "Friday";
  6, Saturday, "Sat","Sam", "Saturday";
]

let i_to_month_h =
  month_info |> List.map (fun (i,month,monthstr,mlong,days) -> i, month)
let s_to_month_h =
  month_info |> List.map (fun (i,month,monthstr,mlong,days) -> monthstr, month)
let slong_to_month_h =
  month_info |> List.map (fun (i,month,monthstr,mlong,days) -> mlong, month)
let month_to_s_h =
  month_info |> List.map (fun (i,month,monthstr,mlong,days) -> month, monthstr)
let month_to_i_h =
  month_info |> List.map (fun (i,month,monthstr,mlong,days) -> month, i)

let i_to_wday_h =
  week_day_info |> List.map (fun (i,day,dayen,dayfr,daylong) -> i, day)
let wday_to_en_h =
  week_day_info |> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayen)
let wday_to_fr_h =
  week_day_info |> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayfr)

let month_of_string s =
  List.assoc s s_to_month_h

let month_of_string_long s =
  List.assoc s slong_to_month_h

let string_of_month s =
  List.assoc s month_to_s_h

let month_of_int i =
  List.assoc i i_to_month_h

let int_of_month m =
  List.assoc m month_to_i_h


let wday_of_int i =
  List.assoc i i_to_wday_h

let string_en_of_wday wday =
  List.assoc wday wday_to_en_h
let string_fr_of_wday wday =
  List.assoc wday wday_to_fr_h

(* ---------------------------------------------------------------------- *)

let wday_str_of_int ~langage i =
  let wday = wday_of_int i in
  match langage with
  | English -> string_en_of_wday wday
  | Francais -> string_fr_of_wday wday
  | Deutsch -> raise Common.Todo



let string_of_date_dmy (DMY (Day n, month, Year y)) =
  (spf "%02d-%s-%d" n (string_of_month month) y)

let date_dmy_of_string s =
  if s =~ "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)"
  then
    let (day, month, year) = matched3 s in
    DMY (Day (int_of_string day),
        month_of_string month,
        Year (int_of_string year))
  else
    failwith ("wrong dmy string: " ^ s)

let string_of_unix_time ?(langage=English) tm =
  let y = tm.Unix.tm_year + 1900 in
  let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in
  let d = tm.Unix.tm_mday in
  let h = tm.Unix.tm_hour in
  let min = tm.Unix.tm_min in
  let s = tm.Unix.tm_sec in

  let wday = wday_str_of_int ~langage tm.Unix.tm_wday in

  spf "%02d/%3s/%04d (%s) %02d:%02d:%02d" d mon y wday h min s

(* ex: 21/Jul/2008 (Lun) 21:25:12 *)
let unix_time_of_string s =
  if s =~
    ("\\([0-9][0-9]\\)/\\(...\\)/\\([0-9][0-9][0-9][0-9]\\) " ^
     "\\(.*\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)")
  then
    let (sday, smonth, syear, _sday, shour, smin, ssec) = matched7 s in

    let y = s_to_i syear - 1900 in
    let mon =
      smonth |> month_of_string |> int_of_month |> (fun i -> i -1)
    in

    let tm = Unix.localtime (Unix.time ()) in
    { tm with
      Unix.tm_year = y;
      Unix.tm_mon = mon;
      Unix.tm_mday = s_to_i sday;
      Unix.tm_hour = s_to_i shour;
      Unix.tm_min = s_to_i smin;
      Unix.tm_sec = s_to_i ssec;
    }
  else failwith ("unix_time_of_string: " ^ s)



let short_string_of_unix_time ?(langage=English) tm =
  let y = tm.Unix.tm_year + 1900 in
  let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in
  let d = tm.Unix.tm_mday in
  let _h = tm.Unix.tm_hour in
  let _min = tm.Unix.tm_min in
  let _s = tm.Unix.tm_sec in

  let wday = wday_str_of_int ~langage tm.Unix.tm_wday in

  spf "%02d/%3s/%04d (%s)" d mon y wday


let string_of_unix_time_lfs time =
  spf "%02d--%s--%d"
    time.Unix.tm_mday
    (int_to_month (time.Unix.tm_mon + 1))
    (time.Unix.tm_year + 1900)


(* ---------------------------------------------------------------------- *)
let string_of_floattime ?langage i =
  let tm = Unix.localtime i in
  string_of_unix_time ?langage tm

let short_string_of_floattime ?langage i =
  let tm = Unix.localtime i in
  short_string_of_unix_time ?langage tm

let floattime_of_string s =
  let tm = unix_time_of_string s in
  let (sec,_tm) = Unix.mktime tm in
  sec


(* ---------------------------------------------------------------------- *)
let days_in_week_of_day day =
  let tm = Unix.localtime day in

  let wday = tm.Unix.tm_wday in
  let wday = if wday =|= 0 then 6 else wday -1 in

  let mday = tm.Unix.tm_mday in

  let start_d = mday - wday in
  let end_d = mday + (6 - wday) in

  enum start_d end_d |> List.map (fun mday ->
    Unix.mktime {tm with Unix.tm_mday = mday} |> fst
  )

let first_day_in_week_of_day day =
  List.hd (days_in_week_of_day day)

let last_day_in_week_of_day day =
  list_last (days_in_week_of_day day)


(* ---------------------------------------------------------------------- *)

(* (modified) copy paste from ocamlcalendar/src/date.ml *)
let days_month =
  [| 0;    31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334(*; 365*) |]


let rough_days_since_jesus (DMY (Day nday, month, Year year)) =
  let n =
    nday +
      (days_month.(int_of_month month -1)) +
      year * 365
  in
  Days n



let is_more_recent d1 d2 =
  let (Days n1) = rough_days_since_jesus d1 in
  let (Days n2) = rough_days_since_jesus d2 in
  (n1 > n2)


let max_dmy d1 d2 =
  if is_more_recent d1 d2
  then d1
  else d2

let min_dmy d1 d2 =
  if is_more_recent d1 d2
  then d2
  else d1


let maximum_dmy ds =
  foldl1 max_dmy ds

let minimum_dmy ds =
  foldl1 min_dmy ds



let rough_days_between_dates d1 d2 =
  let (Days n1) = rough_days_since_jesus d1 in
  let (Days n2) = rough_days_since_jesus d2 in
  Days (n2 - n1)

let _ = assert
  (rough_days_between_dates
      (DMY (Day 7, Jan, Year 1977))
      (DMY (Day 13, Jan, Year 1977)) =*= Days 6)

(* because of rough days, it is a bit buggy, here it should return 1 *)
(*
let _ = assert_equal
  (rough_days_between_dates
      (DMY (Day 29, Feb, Year 1977))
      (DMY (Day 1, Mar , Year 1977)))
  (Days 1)
*)


(* from julia, in gitsort.ml *)

(*
let antimonths =
  [(1,31);(2,28);(3,31);(4,30);(5,31); (6,6);(7,7);(8,31);(9,30);(10,31);
    (11,30);(12,31);(0,31)]

let normalize (year,month,day,hour,minute,second) =
  if hour < 0
  then
    let (day,hour) = (day - 1,hour + 24) in
    if day = 0
    then
      let month = month - 1 in
      let day = List.assoc month antimonths in
      let day =
  if month = 2 && year / 4 * 4 = year && not (year / 100 * 100 = year)
  then 29
  else day in
      if month = 0
      then (year-1,12,day,hour,minute,second)
      else (year,month,day,hour,minute,second)
    else (year,month,day,hour,minute,second)
  else (year,month,day,hour,minute,second)

*)


let mk_date_dmy day month year =
  let date = DMY (Day day, month_of_int month, Year year) in
  (* check_date_dmy date *)
  date


(* ---------------------------------------------------------------------- *)
(* conversion to unix.tm *)

let dmy_to_unixtime (DMY (Day n, month, Year year)) =
  let tm = {
    Unix.tm_sec = 0;      (** Seconds 0..60 *)
    tm_min = 0;           (** Minutes 0..59 *)
    tm_hour = 12;           (** Hours 0..23 *)
    tm_mday = n;              (** Day of month 1..31 *)
    tm_mon = (int_of_month month -1);               (** Month of year 0..11 *)
    tm_year = year - 1900;              (** Year - 1900 *)
    tm_wday = 0;              (** Day of week (Sunday is 0) *)
    tm_yday = 0;              (** Day of year 0..365 *)
    tm_isdst = false;            (** Daylight time savings in effect *)
  } in
  Unix.mktime tm

let unixtime_to_dmy tm =
  let n = tm.Unix.tm_mday  in
  let month = month_of_int (tm.Unix.tm_mon + 1) in
  let year = tm.Unix.tm_year + 1900 in

  DMY (Day n, month, Year year)


let unixtime_to_floattime tm =
  Unix.mktime tm |> fst

let floattime_to_unixtime sec =
  Unix.localtime sec

let floattime_to_dmy sec =
  sec |> floattime_to_unixtime |> unixtime_to_dmy


let sec_to_days sec =
  let minfactor = 60 in
  let hourfactor = 60 * 60 in
  let dayfactor = 60 * 60 * 24 in

  let days  =  sec / dayfactor in
  let hours = (sec mod dayfactor) / hourfactor in
  let mins  = (sec mod hourfactor) / minfactor in
  let sec = (sec mod 60) in
  (* old:   Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
  (if days > 0  then plural days "day" ^ " "    else "") ^
  (if hours > 0 then plural hours "hour" ^ " " else "") ^
  (if mins > 0  then plural mins "min"   ^ " " else "") ^
  (spf "%dsec" sec)

let sec_to_hours sec =
  let minfactor = 60 in
  let hourfactor = 60 * 60 in

  let hours = sec / hourfactor in
  let mins  = (sec mod hourfactor) / minfactor in
  let sec = (sec mod 60) in
  (* old:   Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *)
  (if hours > 0 then plural hours "hour" ^ " " else "") ^
  (if mins > 0  then plural mins "min"   ^ " " else "") ^
  (spf "%dsec" sec)



let test_date_1 () =
  let date = DMY (Day 17, Sep, Year 1991) in
  let float, tm = dmy_to_unixtime date in
  pr2 (spf "date: %.0f" float);
  ()


(* src: ferre in logfun/.../date.ml *)

let day_secs : float = 86400.

let today     : unit -> float = fun () ->  (Unix.time () )
let yesterday : unit -> float = fun () ->  (Unix.time () -. day_secs)
let tomorrow  : unit -> float = fun () ->  (Unix.time () +. day_secs)

let lastweek  : unit -> float = fun () ->  (Unix.time () -. (7.0 *. day_secs))
let lastmonth  : unit -> float = fun () ->  (Unix.time () -. (30.0 *. day_secs))


let week_before  : float_time -> float_time = fun d ->
  (d -. (7.0 *. day_secs))
let month_before  : float_time -> float_time = fun d ->
  (d -. (30.0 *. day_secs))

let week_after  : float_time -> float_time = fun d ->
  (d +. (7.0 *. day_secs))

let timestamp () =
  let now = Unix.time () in
  let tm = floattime_to_unixtime now in

  let d = tm.Unix.tm_mday in
  let h = tm.Unix.tm_hour in
  let min = tm.Unix.tm_min in
  let s = tm.Unix.tm_sec in
  (* old: string_of_unix_time tm *)
  spf "%02d %02d:%02d:%02d" d h min s


(*****************************************************************************)
(* Lines/words/strings *)
(*****************************************************************************)

(* now in prelude:
 * let (list_of_string: string -> char list) = fun s ->
 * (enum 0 ((String.length s) - 1) +> List.map (String.get s))
 *)

let _ = assert (list_of_string "abcd" =*= ['a';'b';'c';'d'])

(*
let rec (list_of_stream: ('a Stream.t) -> 'a list) =
parser
  | [< 'c ; stream >]  -> c :: list_of_stream stream
  | [<>]               -> []

let (list_of_string: string -> char list) =
  Stream.of_string $ list_of_stream
*)

(* now in prelude:
 * let (lines: string -> string list) = fun s -> ...
 *)

let (lines_with_nl: string -> string list) = fun s ->
  let rec lines_aux = function
    | [] -> []
    | [x] -> if x =$= "" then [] else [x ^ "\n"] (* old: [x] *)
    | x::xs ->
        let e = x ^ "\n" in
        e::lines_aux xs
  in
  (time_func (fun () -> Str.split_delim (Str.regexp "\n") s)) |> lines_aux

(* in fact better make it return always complete lines, simplify *)
(*  Str.split, but lines "\n1\n2\n" dont return the \n and forget the first \n => split_delim better than split *)
(* +> List.map (fun s -> s ^ "\n") but add an \n even at the end => lines_aux *)
(* old: slow
  let chars = list_of_string s in
  chars +> List.fold_left (fun (acc, lines) char ->
    let newacc = acc ^ (String.make 1 char) in
    if char = '\n'
    then ("", newacc::lines)
    else (newacc, lines)
    ) ("", [])
       +> (fun (s, lines) -> List.rev (s::lines))
*)

(*  CHECK: unlines (lines x) = x *)
let (unlines: string list -> string) = fun s ->
  (String.concat "\n" s) ^ "\n"
let (words: string -> string list)   = fun s ->
  Str.split (Str.regexp "[ \t()\";]+") s
let (unwords: string list -> string) = fun s ->
  String.concat "" s

let (split_space: string -> string list)   = fun s ->
  Str.split (Str.regexp "[ \t\n]+") s

let n_space n = repeat " " n |> join ""

let indent_string n s =
  let xs = lines s in
  xs
  |> List.map (fun s -> n_space n ^ s)
  |> unlines


(* todo opti ? *)
let nblines s =
  lines s |> List.length
(*
let _ = example (nblines "" =|= 0)
let _ = example (nblines "toto" =|= 1)
let _ = example (nblines "toto\n" =|= 1)
let _ = example (nblines "toto\ntata" =|= 2)
let _ = example (nblines "toto\ntata\n" =|= 2)
*)

(* old: fork sucks.
 * (* note: on MacOS wc outputs some spaces before the number of lines *)
 *)


let nblines_eff2 file =
  let res = ref 0 in
  let finished = ref false in
  let ch = open_in file in
  while not !finished do
    try
      let _ = input_line ch in
      incr res
    with End_of_file -> finished := true
  done;
  close_in ch;
  !res
let nblines_eff a =
  Common.profile_code "Nblines_eff" (fun () -> nblines_eff2 a)




(* could be in h_files-format *)
let words_of_string_with_newlines s =
  lines s |> List.map words |> List.flatten |> exclude null_string

let lines_with_nl_either s =
  let xs = Str.full_split (Str.regexp "\n") s in
  xs |> List.map (function
  | Str.Delim s -> Right ()
  | Str.Text s -> Left s
  )

(*
let _ = example (lines_with_nl_either "ab\n\nc" =*=
    [Left "ab"; Right (); Right (); Left "c"])
*)

(*****************************************************************************)
(* Process/Files *)
(*****************************************************************************)
let cat_orig file =
  let chan = open_in file in
  let rec cat_orig_aux ()  =
    try
      (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
      let l = input_line chan in
      l :: cat_orig_aux ()
    with End_of_file -> [] in
  cat_orig_aux()

(* tail recursive efficient version *)
let cat file =
  let chan = open_in file in
  let rec cat_aux acc ()  =
      (* cant do input_line chan::aux() cos ocaml eval from right to left ! *)
    let (b, l) = try (true, input_line chan) with End_of_file -> (false, "") in
    if b
    then cat_aux (l::acc) ()
    else acc
  in
  cat_aux [] () |> List.rev |> (fun x -> close_in chan; x)

let cat_array file =
  (""::cat file) |> Array.of_list

(* Spec for cat_excerpts:
let cat_excerpts file lines =
  let arr = cat_array file in
  lines |> List.map (fun i -> arr.(i))
*)

let cat_excerpts file lines = Common.with_open_infile file (fun chan ->
  let lines = List.sort compare lines in
  let rec aux acc lines count =
    let (b,l) = try (true, input_line chan) with End_of_file -> (false, "") in
    if (not b) then acc else
    match lines with
    | [] -> acc
    | c::cdr when (c==count) -> aux (l::acc) cdr (count+1)
    | _ -> aux acc lines (count+1)
  in
  aux [] lines 1 |> List.rev)

let interpolate str =
  begin
    command2 ("printf \"%s\\n\" " ^ str ^ ">/tmp/caml");
    cat "/tmp/caml"
  end

(* could do a print_string but printf dont like print_string *)
let echo s = Printf.printf "%s" s; flush stdout; s

let usleep s = for i = 1 to s do () done

let sleep_little () =
  (*old:  *)
  Unix.sleep 1
  (*ignore(Sys.command ("usleep " ^ !_sleep_time))*)


(* now in prelude:
 * let command2 s = ignore(Sys.command s)
 *)

let do_in_fork f =
  let pid = Unix.fork () in
  if pid =|= 0
  then
    begin
      (* Unix.setsid(); *)
      Sys.set_signal Sys.sigint (Sys.Signal_handle   (fun _ ->
        pr2 "being killed";
        Unix.kill 0 Sys.sigkill;
        ));
      f ();
      exit 0;
    end
  else pid


exception CmdError of Unix.process_status * string

let process_output_to_list2 ?(verbose=false) command =
  let chan = Unix.open_process_in command in
  let res = ref ([] : string list) in
  let rec process_otl_aux () =
    let e = input_line chan in
    res := e::!res;
    if verbose then pr2 e;
    process_otl_aux() in
  try process_otl_aux ()
  with End_of_file ->
    let stat = Unix.close_process_in chan in (List.rev !res,stat)

let cmd_to_list ?verbose command =
  let (l,exit_status) = process_output_to_list2 ?verbose command in
  match exit_status with
  | Unix.WEXITED 0 -> l
  | _ -> raise (CmdError (exit_status,
                         (spf "CMD = %s, RESULT = %s"
                             command (String.concat "\n" l))))

let process_output_to_list = cmd_to_list
let cmd_to_list_and_status = process_output_to_list2

let nblines_with_wc2 file =
  match cmd_to_list (spf "wc -l %s" file) with
  | [s] when s =~ "^[ \t]*\\([0-9]+\\) " -> s_to_i (matched1 s)
  | _ -> failwith "pb in output of wc"
let nblines_with_wc a =
  Common.profile_code "Common.nblines_with_wc" (fun () -> nblines_eff2 a)

let unix_diff file1 file2 =
  let (xs, _status) =
    cmd_to_list_and_status (spf "diff -u %s %s" file1 file2) in
  xs
(* see also unix_diff_strings at the bottom *)

let get_mem() =
  cmd_to_list("grep VmData /proc/" ^ string_of_int (Unix.getpid()) ^ "/status")
  |> join ""

(* now in prelude:
 * let command2 s = ignore(Sys.command s)
 *)

let _batch_mode = ref false

let y_or_no msg =
  pr2 (msg ^ " [y/n] ?");
  if !_batch_mode then true
  else begin
    let rec aux () =
      match read_line () with
      | "y" | "yes" | "Y" -> true
      | "n" | "no"  | "N" -> false
      | _ ->
        pr2 "answer by 'y' or 'n'";
        aux ()
    in
    aux ()
  end

let command2_y_or_no cmd =
  if !_batch_mode then begin command2 cmd; true end
  else begin

    pr2 (cmd ^ " [y/n] ?");
    match read_line () with
    | "y" | "yes" | "Y" -> command2 cmd; true
    | "n" | "no"  | "N" -> false
    | _ -> failwith "answer by yes or no"
  end

let command2_y_or_no_exit_if_no cmd =
  let res = command2_y_or_no cmd in
  if res
  then ()
  else raise (UnixExit (1))

let command_safe ?(verbose=false) program args =
  let pid = Unix.fork () in
  let cmd_str = (program::args) |> join " " in
  if pid =|= 0 then begin
    pr2 ("running: " ^ cmd_str);
    Unix.execv program (Array.of_list (program::args))
  end
  else
    let (pid2, status) = Unix.waitpid [] pid in
    match status with
    | Unix.WEXITED retcode -> retcode
    | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
        failwith ("problem running: " ^ cmd_str)



let mkdir ?(mode=0o770) file =
  Unix.mkdir file mode

let read_file_orig file = cat file |> unlines
let read_file file =
  let ic = open_in file  in
  let size = in_channel_length ic in
  let buf = Bytes.create size in
  really_input ic buf 0 size;
  close_in ic;
  buf |> Bytes.to_string


let write_file ~file s =
  let chan = open_out file in
  (output_string chan s; close_out chan)

let unix_stat file =
  Common.profile_code "Unix.stat" (fun () ->
    Unix.stat file
  )

let filesize file =
  (unix_stat file).Unix.st_size

let filemtime file =
  (unix_stat file).Unix.st_mtime

(* opti? use wc -l ? *)
let nblines_file file =
  cat file |> List.length

let lfile_exists filename =
  try
    (match (Unix.lstat filename).Unix.st_kind with
    | (Unix.S_REG | Unix.S_LNK) -> true
    | _ -> false
    )
  with Unix.Unix_error (Unix.ENOENT, _, _) -> false

let is_directory file =
  (unix_stat file).Unix.st_kind =*= Unix.S_DIR
let is_file file =
  (unix_stat file).Unix.st_kind =*= Unix.S_REG
let is_symlink file =
  (Unix.lstat file).Unix.st_kind =*= Unix.S_LNK

let is_executable file =
  let stat = unix_stat file in
  let perms = stat.Unix.st_perm in
  stat.Unix.st_kind =*= Unix.S_REG &&
  (perms land 0o011 <> 0)


(* ---------------------------------------------------------------------- *)
(* _eff variant *)
(* ---------------------------------------------------------------------- *)
let _hmemo_unix_lstat_eff = Hashtbl.create 101
let _hmemo_unix_stat_eff = Hashtbl.create 101

let unix_lstat_eff file =
  Common.profile_code "Unix.lstat_eff" (fun () ->
    if is_absolute file
    then
      memoized _hmemo_unix_lstat_eff file (fun () ->
        Unix.lstat file
      )
    else
      (* this is for efficieny reason to be able to memoize the stats *)
      failwith "must pass absolute path to unix_lstat_eff"
  )

let unix_stat_eff file =
  Common.profile_code "Unix.stat_eff" (fun () ->
    if is_absolute file
    then
      memoized _hmemo_unix_stat_eff file (fun () ->
        Unix.stat file
      )
    else
      (* this is for efficieny reason to be able to memoize the stats *)
      failwith "must pass absolute path to unix_stat_eff"
  )

let filesize_eff file =
  (unix_lstat_eff file).Unix.st_size

let filemtime_eff file =
  (unix_lstat_eff file).Unix.st_mtime

let lfile_exists_eff filename =
  try
    (match (unix_lstat_eff filename).Unix.st_kind with
    | (Unix.S_REG | Unix.S_LNK) -> true
    | _ -> false
    )
  with Unix.Unix_error (Unix.ENOENT, _, _) -> false

let is_directory_eff file =
  (unix_lstat_eff file).Unix.st_kind =*= Unix.S_DIR
let is_file_eff file =
  (unix_lstat_eff file).Unix.st_kind =*= Unix.S_REG

let is_executable_eff file =
  let stat = unix_lstat_eff file in
  let perms = stat.Unix.st_perm in
  stat.Unix.st_kind =*= Unix.S_REG &&
  (perms land 0o011 <> 0)


(* ---------------------------------------------------------------------- *)

(* src: from chailloux et al book *)
let capsule_unix f args =
  try (f args)
  with Unix.Unix_error (e, fm, argm) ->
    log (Printf.sprintf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm)


let (readdir_to_kind_list: string -> Unix.file_kind -> string list) =
 fun path kind ->
  Sys.readdir path
  |> Array.to_list
  |> List.filter (fun s ->
    try
      let stat = Unix.lstat (path ^ "/" ^  s) in
      stat.Unix.st_kind =*= kind
    with e ->
      pr2 ("EXN pb stating file: " ^ s);
      false
    )

let (readdir_to_dir_list: string -> string list) = fun path ->
  readdir_to_kind_list path Unix.S_DIR

let (readdir_to_file_list: string -> string list) = fun path ->
  readdir_to_kind_list path Unix.S_REG

let (readdir_to_link_list: string -> string list) = fun path ->
  readdir_to_kind_list path Unix.S_LNK


let (readdir_to_dir_size_list: string -> (string * int) list) = fun path ->
  Sys.readdir path
  |> Array.to_list
  |> map_filter (fun s ->
    let stat = Unix.lstat (path ^ "/" ^  s) in
    if stat.Unix.st_kind =*= Unix.S_DIR
    then Some (s, stat.Unix.st_size)
    else None
    )

let unixname () =
  let uid = Unix.getuid () in
  let entry = Unix.getpwuid uid in
  entry.Unix.pw_name


(* could be in control section too *)

(* Why a use_cache argument ? because sometimes want disable it but dont
 * want put the cache_computation funcall in comment, so just easier to
 * pass this extra option.
 *)
let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f =
  if not use_cache
  then f ()
  else begin
    if not (Sys.file_exists file)
    then begin
      pr2 ("WARNING: cache_computation: can't find file "  ^ file);
      pr2 ("defaulting to calling the function");
      f ()
    end else begin
      let file_cache = (file ^ ext_cache) in
      if Sys.file_exists file_cache &&
        filemtime file_cache >= filemtime file
      then begin
        if verbose then pr2 ("using cache: " ^ file_cache);
        get_value file_cache
      end
      else begin
        let res = f () in
        write_value res file_cache;
        res
      end
    end
  end
let cache_computation ?verbose ?use_cache a b c =
  Common.profile_code "Common.cache_computation" (fun () ->
    cache_computation2 ?verbose ?use_cache a b c)


let cache_computation_robust2
 file ext_cache
 (need_no_changed_files, need_no_changed_variables) ext_depend
 f =
  if not (Sys.file_exists file)
  then failwith ("can't find: "  ^ file);

  let file_cache = (file ^ ext_cache) in
  let dependencies_cache = (file ^ ext_depend) in

  let dependencies =
    (* could do md5sum too *)
    ((file::need_no_changed_files) |> List.map (fun f -> f, filemtime f),
    need_no_changed_variables)
  in

  if Sys.file_exists dependencies_cache &&
     get_value dependencies_cache =*= dependencies
  then get_value file_cache
  else begin
    pr2 ("cache computation recompute " ^ file);
    let res = f () in
    write_value dependencies dependencies_cache;
    write_value res file_cache;
    res
  end

let cache_computation_robust a b c d e =
  Common.profile_code "Common.cache_computation_robust" (fun () ->
    cache_computation_robust2 a b c d e)




(* dont forget that cmd_to_list call bash and so pattern may contain
 * '*' symbols that will be expanded, so can do  glob "*.c"
 *)
let glob pattern =
  cmd_to_list ("ls -1 " ^ pattern)

let dirs_of_dir dir =
  assert(is_directory dir);
  let xs = cmd_to_list (spf "find \"%s\" -type d" dir) in
  match xs with
  | [] -> failwith ("dirs_of_dir: pb with" ^ dir)
  | x::xs -> xs


(* TODO: do a files_of_dir_or_files ?no_vcs ?filter:Ext|Reg|Filter
*)

(* update: have added the -type f, so normally need less the sanity_check_xxx
 * function below *)
let files_of_dir_or_files ext xs =
  xs |> List.map (fun x ->
    if is_directory x
    then cmd_to_list ("find " ^ x  ^" -noleaf -type f -name \"*." ^ext^"\"")
    else [x]
  ) |> List.concat


let grep_dash_v_str =
 "| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/" ^
 "| grep -v /.svn/ | grep -v .git_annot | grep -v .marshall"

let arg_symlink () =
  if !Common.follow_symlinks
  then " -L "
  else ""


let files_of_dir_or_files_no_vcs ext xs =
  xs |> List.map (fun x ->
    if is_directory x
    then
      cmd_to_list
        ("find "^arg_symlink()^x^ " -noleaf -type f -name \"*." ^ext^"\"" ^
         grep_dash_v_str
        )
    else [x]
  ) |> List.concat


let files_of_dir_or_files_no_vcs_nofilter xs =
  xs |> List.map (fun x ->
    if is_directory x
    then
      cmd_to_list_and_status
        ("find "^arg_symlink()^x^" -noleaf -type f " ^
            grep_dash_v_str
        ) |> fst
    else [x]
  ) |> List.concat


let files_of_dir_or_files_no_vcs_post_filter regex xs =
  xs |> List.map (fun x ->
    if is_directory x
    then
      cmd_to_list
        ("find "^arg_symlink()^x^
         " -noleaf -type f " ^ grep_dash_v_str
        )
        |> List.filter (fun s -> s =~ regex)
    else [x]
  ) |> List.concat


let sanity_check_files_and_adjust ext files =
  let files = files |> List.filter (fun file ->
    if not (file =~ (".*\\."^ext))
    then begin
      pr2 ("warning: seems not a ."^ext^" file");
      false
    end
    else
      if is_directory file
      then begin
        pr2 (spf "warning: %s is a directory" file);
        false
      end
    else true
  ) in
  files




(* taken from mlfuse, the predecessor of ocamlfuse *)
type rwx = [`R|`W|`X] list
let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm =
 fun ~u ~g ~o ->
  let to_oct l =
    List.fold_left (fun acc p -> acc lor ((function `R -> 4 | `W -> 2 | `X -> 1) p)) 0 l in
  let perm =
    ((to_oct u) lsl 6) lor
    ((to_oct g) lsl 3) lor
    (to_oct o)
  in
  perm


(* pixel *)
let has_env var =
  failwith "Common.has_env, TODO"
(*
  try
    let _ = Sys.getenv var in true
  with Not_found -> false
*)


let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) =
 fun file f ->
  let chan = open_out_gen [Open_creat;Open_append] 0o666 file in
  let pr s = output_string chan s in
  Common.unwind_protect (fun () ->
    let res = f (pr, chan) in
    close_out chan;
    res)
    (fun e -> close_out chan)


(* now in prelude:
 * exception Timeout
 *)

(* it seems that the toplevel block such signals, even with this explicit
 *  command :(
 *  let _ = Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigalrm]
 *)

(* could be in Control section *)

(* subtil: have to make sure that timeout is not intercepted before here, so
 * avoid exn handle such as try (...) with _ -> cos timeout will not bubble up
 * enough. In such case, add a case before such as
 * with Timeout -> raise Timeout | _ -> ...
 *
 * question: can we have a signal and so exn when in a exn handler ?
 *)
let timeout_function ?(verbose=false) timeoutval = fun f ->
  try
    begin
      Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout ));
      ignore(Unix.alarm timeoutval);
      let x = f () in
      ignore(Unix.alarm 0);
      x
    end
  with Timeout ->
    begin
      if verbose then log "timeout (we abort)";
      raise Timeout;
    end
  | e ->
     (* subtil: important to disable the alarm before relaunching the exn,
      * otherwise the alarm is still running.
      *
      * robust?: and if alarm launched after the log (...) ?
      * Maybe signals are disabled when process an exception handler ?
      *)
      begin
        ignore(Unix.alarm 0);
        (* log ("exn while in transaction (we abort too, even if ...) = " ^
           Printexc.to_string e);
        *)
        if verbose then log "exn while in timeout_function";
        raise e
      end

let timeout_function_opt timeoutvalopt f =
  match timeoutvalopt with
  | None -> f ()
  | Some x -> timeout_function x f


let with_tmp_file ~(str: string) ~(ext: string) (f: string -> 'a) : 'a =
  let tmpfile = Common.new_temp_file "tmp" ("." ^ ext) in
  write_file ~file:tmpfile str;
  Common.finalize (fun () ->
    f tmpfile
  ) (fun() ->
    Unix.unlink tmpfile
  )


let with_tmp_dir f =
  let tmp_dir = Filename.temp_file (spf "with-tmp-dir-%d" (Unix.getpid())) "" in
  Unix.unlink tmp_dir;
  (* who cares about race *)
  Unix.mkdir tmp_dir 0o755;
  Common.finalize (fun () ->
    f tmp_dir
  ) (fun () ->
    command2 (spf "rm -f %s/*" tmp_dir);
    Unix.rmdir tmp_dir
  )



(* now in prelude: exception UnixExit of int *)
let exn_to_real_unixexit f =
  try f ()
  with UnixExit x -> exit x



let uncat xs file =
  Common.with_open_outfile file (fun (pr,_chan) ->
    xs |> List.iter (fun s -> pr s; pr "\n");

  )

(*###########################################################################*)
(* Collection-like types *)
(*###########################################################################*)

(*x: common.ml *)
(*****************************************************************************)
(* List *)
(*****************************************************************************)

(* pixel *)
let uncons l = (List.hd l, List.tl l)

(* pixel *)
let safe_tl l = try List.tl l with _ -> []

(* in prelude
let push l v =
  l := v :: !l
*)

let rec zip xs ys =
  match (xs,ys) with
  | ([],[]) -> []
  | ([],_) -> failwith "zip: not same length"
  | (_,[]) -> failwith "zip: not same length"
  | (x::xs,y::ys) -> (x,y)::zip xs ys

let rec zip_safe xs ys =
  match (xs,ys) with
  | ([],_) -> []
  | (_,[]) -> []
  | (x::xs,y::ys) -> (x,y)::zip_safe xs ys

let rec unzip zs =
  List.fold_right (fun e (xs, ys)    ->
    (fst e::xs), (snd e::ys)) zs ([],[])


let map_withkeep f xs =
  xs |> List.map (fun x -> f x, x)

(* now in prelude
 * let rec take n xs =
 * match (n,xs) with
 * | (0,_) -> []
 * | (_,[]) -> failwith "take: not enough"
 * | (n,x::xs) -> x::take (n-1) xs
 *)

let rec take_safe n xs =
  match (n,xs) with
  | (0,_) -> []
  | (_,[]) -> []
  | (n,x::xs) -> x::take_safe (n-1) xs

let rec take_until p = function
  | [] -> []
  | x::xs -> if p x then [] else x::(take_until p xs)

let take_while p = take_until (p $ not)


(* now in prelude: let rec drop n xs = ... *)
let _ = assert (drop 3 [1;2;3;4] =*= [4])

let rec drop_while p = function
  | [] -> []
  | x::xs -> if p x then drop_while p xs else x::xs


let rec drop_until p xs =
  drop_while (fun x -> not (p x)) xs
let _ = assert (drop_until (fun x -> x =|= 3) [1;2;3;4;5] =*= [3;4;5])


let span p xs = (take_while p xs, drop_while p xs)


let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) =
 fun p -> function
  | []    -> ([], [])
  | x::xs ->
      if p x then
        let (l1, l2) = span p xs in
        (x::l1, l2)
      else ([], x::xs)
let _ = assert ((span (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2])))

let rec (span_tail_call: ('a -> bool) -> 'a list -> 'a list * 'a list) =
 fun p xs ->
   let rec aux acc xs =
     match xs with
     | [] -> (List.rev acc, [])
     | x::xs ->
         if p x then
           aux (x::acc) xs
         else
           (List.rev acc, x::xs)
   in
   aux [] xs
let _ = assert (
  (span_tail_call (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2]))
 )

let rec groupBy eq l =
  match l with
  | [] -> []
  | x::xs ->
      let (xs1,xs2) = List.partition (fun x' -> eq x x') xs in
      (x::xs1)::(groupBy eq xs2)

(* you should really use group_assoc_bykey_eff *)
let rec group_by_mapped_key fkey l =
  match l with
  | [] -> []
  | x::xs ->
      let k = fkey x in
      let (xs1,xs2) = List.partition (fun x' -> let k2 = fkey x' in k=*=k2) xs
      in
      (k, (x::xs1))::(group_by_mapped_key fkey xs2)


let group_and_count xs =
  xs
  |> groupBy (=*=)
  |> List.map (fun xs ->
    match xs with
    | x::rest -> x, List.length xs
    | [] -> raise Common.Impossible
  )


let (exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list)=
 fun f xs ->
   let rec aux_filter acc = function
   | [] -> [] (* drop what was accumulated because nothing to attach to *)
   | x::xs ->
       if f x
       then aux_filter (x::acc) xs
       else (x, List.rev acc)::aux_filter [] xs
   in
   aux_filter [] xs
let _ = assert
  (exclude_but_keep_attached (fun x -> x =|= 3) [3;3;1;3;2;3;3;3] =*=
      [(1,[3;3]);(2,[3])])

let (group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list)=
 fun f xs ->
   let rec aux_filter grouped_acc acc = function
   | [] ->
       List.rev grouped_acc, List.rev acc
   | x::xs ->
       if f x
       then
         aux_filter ((List.rev acc,x)::grouped_acc) [] xs
       else
         aux_filter grouped_acc (x::acc) xs
   in
   aux_filter [] [] xs

let _ = assert
  (group_by_post (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
      ([([1;1],3);([2],3);[4;5],3], [6;6;6]))

let (group_by_pre: ('a -> bool) -> 'a list -> 'a list * ('a * 'a list) list)=
  fun f xs ->
    let xs' = List.rev xs in
    let (ys, unclassified) = group_by_post f xs' in
    List.rev unclassified,
    ys |> List.rev |> List.map (fun (xs, x) -> x, List.rev xs )

let _ = assert
  (group_by_pre (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
      ([1;1], [(3,[2]); (3,[4;5]); (3,[6;6;6])]))


let rec (split_when: ('a -> bool) -> 'a list -> 'a list * 'a * 'a list) =
 fun p -> function
  | []    -> raise Not_found
  | x::xs ->
      if p x then
        [], x, xs
      else
        let (l1, a, l2) = split_when p xs in
        (x::l1, a, l2)
let _ = assert (split_when (fun x -> x =|= 3)
                    [1;2;3;4;1;2] =*= ([1;2],3,[4;1;2]))


(* not so easy to come up with ... used in aComment for split_paragraph *)
let rec split_gen_when_aux f acc xs =
  match xs with
  | [] ->
      if null acc
      then []
      else [List.rev acc]
  | (x::xs) ->
      (match f (x::xs) with
      | None ->
          split_gen_when_aux f (x::acc) xs
      | Some (rest) ->
          let before = List.rev acc in
          if null before
          then split_gen_when_aux f [] rest
          else before::split_gen_when_aux f [] rest
      )
(* could avoid introduce extra aux function by using ?(acc = []) *)
let split_gen_when f xs =
  split_gen_when_aux f [] xs

let _ = assert (split_gen_when (function (42::xs) -> Some xs | _ -> None)
                    [1;2;42;4;5;6;42;7] =*= [[1;2];[4;5;6];[7]])


(* generate exception (Failure "tl") if there is no element satisfying p *)
let rec (skip_until: ('a list -> bool) -> 'a list -> 'a list) = fun p xs ->
  if p xs then xs else skip_until p (List.tl xs)
let _ = assert
  (skip_until (function 1::2::xs -> true | _ -> false)
      [1;3;4;1;2;4;5] =*= [1;2;4;5])

let rec skipfirst e = function
  | [] -> []
  | e'::l when e =*= e' -> skipfirst e l
  | l -> l


(* now in prelude:
 * let rec enum x n = ...
 *)


let index_list xs =
  if null xs then [] (* enum 0 (-1) generate an exception *)
  else zip xs (enum 0 ((List.length xs) -1))

(* if you want to use this to show the progress while processing huge list,
 * consider instead Common_extra.progress
 *)
let index_list_and_total xs =
  let total = List.length xs in
  if null xs then [] (* enum 0 (-1) generate an exception *)
  else zip xs (enum 0 ((List.length xs) -1))
    |> List.map (fun (a,b) -> (a,b,total))

let index_list_0 xs = index_list xs

let index_list_1 xs =
  xs |> index_list |> List.map (fun (x,i) -> x, i+1)

let avg_list xs =
  let sum = sum_int xs in
  (float_of_int sum) /. (float_of_int (List.length xs))

let snoc x xs = xs @ [x]
let cons x xs = x::xs

let head_middle_tail xs =
  match xs with
  | x::y::xs ->
      let head = x in
      let reversed = List.rev (y::xs) in
      let tail = List.hd reversed in
      let middle = List.rev (List.tl reversed) in
      head, middle, tail
  | _ -> failwith "head_middle_tail, too small list"

let _ = assert_equal (head_middle_tail [1;2;3]) (1, [2], 3)
let _ = assert_equal (head_middle_tail [1;3]) (1, [], 3)

(* now in prelude
 * let (++) = (@)
 *)

(* let (++) = (@), could do that, but if load many times the common, then pb *)
(* let (++) l1 l2 = List.fold_right (fun x acc -> x::acc) l1 l2 *)

let remove x xs =
  let newxs = List.filter (fun y -> y <> x) xs in
  assert (List.length newxs =|= List.length xs - 1);
  newxs


let rec remove_first e xs =
  match xs with
  | [] -> raise Not_found
  | x::xs ->
      if x =*= e
      then xs
      else x::(remove_first e xs)

(* now in prelude
let exclude p xs =
  List.filter (fun x -> not (p x)) xs
*)
(* now in prelude
*)

let fold_k f lastk acc xs =
  let rec fold_k_aux acc = function
    | [] -> lastk acc
    | x::xs ->
        f acc x (fun acc -> fold_k_aux acc xs)
  in
  fold_k_aux acc xs


let rec list_init = function
  | []       -> raise Not_found
  | [x]      -> []
  | x::y::xs -> x::(list_init (y::xs))

(* now in prelude:
 * let rec list_last = function
 * | [] -> raise Not_found
 * | [x] -> x
 * | x::y::xs -> list_last (y::xs)
 *)

(* pixel *)
(* now in prelude
 *   let last_n n l = List.rev (take n (List.rev l))
 *   let last l = List.hd (last_n 1 l)
 *)

let rec join_gen a = function
  | [] -> []
  | [x] -> [x]
  | x::xs -> x::a::(join_gen a xs)


(* todo: foldl, foldr (a more consistent foldr) *)

(* start pixel *)
let iter_index f l =
  let rec iter_ n = function
    | [] -> ()
    | e::l -> f e n ; iter_ (n+1) l
  in iter_ 0 l

let map_index f l =
  let rec map_ n = function
    | [] -> []
    | e::l -> f e n :: map_ (n+1) l
  in map_ 0 l


(* pixel *)
let filter_index f l =
  let rec filt i = function
    | [] -> []
    | e::l -> if f i e then e :: filt (i+1) l else filt (i+1) l
  in
  filt 0 l

(* pixel *)
let do_withenv doit f env l =
  let r_env = ref env in
  let l' = doit (fun e ->
    let e', env' = f !r_env e in
    r_env := env' ; e'
  ) l in
  l', !r_env

(* now in prelude:
 * let fold_left_with_index f acc = ...
 *)

let map_withenv      f env e = do_withenv List.map f env e

let rec collect_accu f accu = function
  | [] -> accu
  | e::l -> collect_accu f (List.rev_append (f e) accu) l

let collect f l = List.rev (collect_accu f [] l)

(* cf also List.partition *)

let rec fpartition p l =
  let rec part yes no = function
  | [] -> (List.rev yes, List.rev no)
  | x :: l ->
      (match p x with
      |	None -> part yes (x :: no) l
      |	Some v -> part (v :: yes) no l) in
  part [] [] l

(* end pixel *)

let rec removelast = function
  | [] -> failwith "removelast"
  | [_] -> []
  | e::l -> e :: removelast l


let empty list = null list


let rec inits = function
  | [] -> [[]]
  | e::l -> [] :: List.map (fun l -> e::l) (inits l)

let rec tails = function
  | [] -> [[]]
  | (_::xs) as xxs -> xxs :: tails xs


let reverse = List.rev
let rev = List.rev

let nth = List.nth
let fold_left = List.fold_left
let rev_map = List.rev_map

(* pixel *)
let rec fold_right1 f = function
  | [] -> failwith "fold_right1"
  | [e] -> e
  | e::l -> f e (fold_right1 f l)

let maximum l = foldl1 max l
let minimum l = foldl1 min l


(* do a map tail recursive, and result is reversed, it is a tail recursive map => efficient *)
let map_eff_rev = fun f l ->
  let rec map_eff_aux acc =
    function
      |	[]    -> acc
      |	x::xs -> map_eff_aux ((f x)::acc) xs
  in
  map_eff_aux [] l

let acc_map f l =
  let rec loop acc = function
    [] -> List.rev acc
  | x::xs -> loop ((f x)::acc) xs in
  loop [] l


let rec (generate: int -> 'a -> 'a list) = fun i el ->
  if i =|= 0 then []
  else el::(generate (i-1) el)

let rec uniq = function
  | [] -> []
  | e::l -> if List.mem e l then uniq l else e :: uniq l

let has_no_duplicate xs =
  List.length xs =|= List.length (uniq xs)
let is_set_as_list = has_no_duplicate


let rec get_duplicates xs =
  match xs with
  | [] -> []
  | x::xs ->
      if List.mem x xs
      then x::get_duplicates xs (* todo? could x from xs to avoid double dups?*)
      else get_duplicates xs

let rec all_assoc e = function
  | [] -> []
  | (e',v) :: l when e=*=e' -> v :: all_assoc e l
  | _ :: l -> all_assoc e l

let prepare_want_all_assoc l =
  List.map (fun n -> n, uniq (all_assoc n l)) (uniq (List.map fst l))

let rotate list = List.tl list @ [(List.hd list)]

let or_list  = List.fold_left (||) false
let and_list = List.fold_left (&&) true

let rec (return_when: ('a -> 'b option) -> 'a list -> 'b) = fun p -> function
  | [] -> raise Not_found
  | x::xs -> (match p x with None -> return_when p xs | Some b -> b)

let rec splitAt n xs =
  if n =|= 0 then ([],xs)
  else
    (match xs with
    | []      -> ([],[])
    | (x::xs) -> let (a,b) = splitAt (n-1) xs in (x::a, b)
    )

let pack n xs =
  let rec pack_aux l i = function
    | [] -> failwith "not on a boundary"
    | [x] -> if i =|= n then [l@[x]] else failwith "not on a boundary"
    | x::xs ->
        if i =|= n
        then (l@[x])::(pack_aux [] 1 xs)
        else pack_aux (l@[x]) (i+1) xs
  in
  pack_aux [] 1 xs

let rec pack_safe n xs =
  match xs with
  | [] -> []
  | y::ys ->
      let (a, b) = splitAt n xs in
      a::pack_safe n b
let _ = assert
  (pack_safe 2 [1;2;3;4;5] =*= [[1;2];[3;4];[5]])

let chunks n xs =
  let size = List.length xs in
  let chunksize =
    if size mod n =|= 0
    then size / n
    else 1 + (size / n)
  in
  let xxs = pack_safe chunksize xs in
  if List.length xxs <> n
  then failwith "chunks: impossible, wrong size";
  xxs

let _ = assert
  (chunks 2 [1;2;3;4] =*= [[1;2];[3;4]])
let _ = assert
  (chunks 2 [1;2;3;4;5] =*= [[1;2;3];[4;5]])


let min_with f = function
  | [] -> raise Not_found
  | e :: l ->
      let rec min_with_ min_val min_elt = function
        | [] -> min_elt
        | e::l ->
            let val_ = f e in
            if val_ < min_val
            then min_with_ val_ e l
            else min_with_ min_val min_elt l
      in min_with_ (f e) e l

let two_mins_with f = function
  | e1 :: e2 :: l ->
      let rec min_with_ min_val min_elt min_val2 min_elt2 = function
        | [] -> min_elt, min_elt2
        | e::l ->
            let val_ = f e in
            if val_ < min_val2
            then
              if val_ < min_val
              then min_with_ val_ e min_val min_elt l
              else min_with_ min_val min_elt val_ e l
            else min_with_ min_val min_elt min_val2 min_elt2 l
      in
      let v1 = f e1 in
      let v2 = f e2 in
      if v1 < v2 then min_with_ v1 e1 v2 e2 l else min_with_ v2 e2 v1 e1 l
  | _ -> raise Not_found

let grep_with_previous f = function
  | [] -> []
  | e::l ->
      let rec grep_with_previous_ previous = function
        | [] -> []
        | e::l -> if f previous e then e :: grep_with_previous_ e l else grep_with_previous_ previous l
      in e :: grep_with_previous_ e l

let iter_with_previous f = function
  | [] -> ()
  | e::l ->
      let rec iter_with_previous_ previous = function
        | [] -> ()
        | e::l -> f previous e ; iter_with_previous_ e l
      in iter_with_previous_ e l

let iter_with_previous_opt f = function
  | [] -> ()
  | e::l ->
      f None e;
      let rec iter_with_previous_ previous = function
        | [] -> ()
        | e::l -> f (Some previous) e ; iter_with_previous_ e l
      in iter_with_previous_ e l


let iter_with_before_after f xs =
  let rec aux before_rev after =
    match after with
    | [] -> ()
    | x::xs ->
        f   before_rev x xs;
        aux (x::before_rev) xs
  in
  aux [] xs



(* kind of cartesian product of x*x  *)
let rec (get_pair: ('a list) -> (('a * 'a) list)) = function
  | [] -> []
  | x::xs -> (List.map (fun y -> (x,y)) xs) @ (get_pair xs)


(* retourne le rang dans une liste d'un element *)
let rang elem liste =
  let rec rang_rec elem accu = function
    | []   -> raise Not_found
    | a::l -> if a =*= elem then accu
    else rang_rec elem (accu+1) l in
  rang_rec elem 1 liste

(* retourne vrai si une liste contient des doubles *)
let rec doublon = function
  | []   -> false
  | a::l -> if List.mem a l then true
  else doublon l

let rec (insert_in: 'a -> 'a list -> 'a list list) = fun x -> function
  | []    -> [[x]]
  | y::ys -> (x::y::ys)  :: (List.map (fun xs -> y::xs) (insert_in x ys))
(* insert_in 3 [1;2] = [[3; 1; 2]; [1; 3; 2]; [1; 2; 3]] *)

let rec (permutation: 'a list -> 'a list list) = function
  | [] -> []
  | [x] -> [[x]]
  | x::xs -> List.flatten (List.map (insert_in x) (permutation xs))
(* permutation [1;2;3] =
 * [[1; 2; 3]; [2; 1; 3]; [2; 3; 1]; [1; 3; 2]; [3; 1; 2]; [3; 2; 1]]
 *)


let rec remove_elem_pos pos xs =
  match (pos, xs) with
  | _, [] -> failwith "remove_elem_pos"
  | 0, x::xs -> xs
  | n, x::xs -> x::(remove_elem_pos (n-1) xs)

let rec insert_elem_pos (e, pos) xs =
  match (pos, xs) with
  | 0, xs -> e::xs
  | n, x::xs -> x::(insert_elem_pos (e, (n-1)) xs)
  | n, [] -> failwith "insert_elem_pos"

let rec uncons_permut xs =
  let indexed = index_list xs in
  indexed |> List.map (fun (x, pos) -> (x, pos),  remove_elem_pos pos xs)
let _ =
  assert
    (uncons_permut ['a';'b';'c'] =*=
     [('a', 0),  ['b';'c'];
      ('b', 1),  ['a';'c'];
      ('c', 2),  ['a';'b']
     ])

let rec uncons_permut_lazy xs =
  let indexed = index_list xs in
  indexed |> List.map (fun (x, pos) ->
    (x, pos),
    lazy (remove_elem_pos pos xs)
  )




(* pixel *)
let rec map_flatten f l =
  let rec map_flatten_aux accu = function
    | [] -> accu
    | e :: l -> map_flatten_aux (List.rev (f e) @ accu) l
  in List.rev (map_flatten_aux [] l)

(* now in prelude: let rec repeat e n *)

let rec map2 f = function
  | [] -> []
  | x::xs -> let r = f x in r::map2 f xs

let rec map3 f l =
  let rec map3_aux acc = function
    | [] -> acc
    | x::xs -> map3_aux (f x::acc) xs in
  map3_aux [] l

(*
let tails2 xs = map rev (inits (rev xs))
let res = tails2 [1;2;3;4]
let res = tails [1;2;3;4]
let id x = x
*)

let pack_sorted same xs =
  let rec pack_s_aux acc xs =
    match (acc,xs) with
    |	((cur,rest),[]) -> cur::rest
    |	((cur,rest), y::ys) ->
          if same (List.hd cur) y then pack_s_aux (y::cur, rest) ys
          else pack_s_aux ([y], cur::rest) ys
  in pack_s_aux ([List.hd xs],[]) (List.tl xs) |> List.rev
let test_pack = pack_sorted (=*=) [1;1;1;2;2;3;4]


let rec keep_best f =
  let rec partition e = function
    | [] -> e, []
    | e' :: l ->
        match f(e,e') with
        | None -> let (e'', l') = partition e l in e'', e' :: l'
        | Some e'' -> partition e'' l
  in function
  | [] -> []
  | e::l ->
      let (e', l') = partition e l in
      e' :: keep_best f l'

let rec sorted_keep_best f = function
  | [] -> []
  | [a] -> [a]
  | a :: b :: l ->
      match f a b with
      |	None -> a :: sorted_keep_best f (b :: l)
      |	Some e -> sorted_keep_best f (e :: l)



let (cartesian_product: 'a list -> 'b list -> ('a * 'b) list) = fun xs ys ->
  xs |> List.map (fun x ->  ys |> List.map (fun y -> (x,y)))
     |> List.flatten

let _ = assert_equal
    (cartesian_product [1;2] ["3";"4";"5"])
    [1,"3";1,"4";1,"5";  2,"3";2,"4";2,"5"]

let sort_prof a b =
  Common.profile_code "Common.sort_by_xxx" (fun () -> List.sort a b)

type order = HighFirst | LowFirst
let compare_order order a b =
  match order with
  | HighFirst -> compare b a
  | LowFirst -> compare a b

let sort_by_val_highfirst xs =
  sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs
let sort_by_val_lowfirst xs =
  sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs

let sort_by_key_highfirst xs =
  sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
let sort_by_key_lowfirst xs =
  sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs

let _ = assert (sort_by_key_lowfirst [4, (); 7,()] =*= [4,(); 7,()])
let _ = assert (sort_by_key_highfirst [4,(); 7,()] =*= [7,(); 4,()])


let sortgen_by_key_highfirst xs =
  sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
let sortgen_by_key_lowfirst xs =
  sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs




(*----------------------------------*)

(* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ...      *)
(* mais pas p2;p3                                                            *)
(* (aop) *)
let surEnsemble  liste_el liste_liste_el =
  List.filter
    (function liste_elbis ->
      List.for_all (function el -> List.mem el liste_elbis) liste_el
    ) liste_liste_el;;



(*----------------------------------*)
(* combinaison/product/.... (aop) *)
(* 123 -> 123 12 13 23 1 2 3 *)
let rec realCombinaison = function
  | []  -> []
  | [a] -> [[a]]
  | a::l  ->
      let res  = realCombinaison l in
      let res2 = List.map (function x -> a::x) res in
      res2 @ res @ [[a]]

(* genere toutes les combinaisons possible de paire      *)
(* par exemple combinaison [1;2;4] -> [1, 2; 1, 4; 2, 4] *)
let rec combinaison = function
  | [] -> []
  | [a] -> []
  | [a;b] -> [(a, b)]
  | a::b::l -> (List.map (function elem -> (a, elem)) (b::l)) @
     (combinaison (b::l))

(*----------------------------------*)

(* list of list(aop) *)
(* insere elem dans la liste de liste (si elem est deja present dans une de  *)
(* ces listes, on ne fait rien                                               *)
let rec insere elem = function
  | []   -> [[elem]]
  | a::l ->
      if (List.mem elem a) then a::l
      else a::(insere elem l)

let rec insereListeContenant lis el = function
  | []   -> [el::lis]
  | a::l ->
      if List.mem el a then
        (List.append lis a)::l
      else a::(insereListeContenant lis el l)

(* fusionne les listes contenant et1 et et2  dans la liste de liste*)
let rec fusionneListeContenant (et1, et2) = function
  | []   -> [[et1; et2]]
  | a::l ->
      (* si les deux sont deja dedans alors rien faire *)
      if List.mem et1 a then
        if List.mem et2 a then a::l
        else
          insereListeContenant a et2 l
      else if List.mem et2 a then
        insereListeContenant a et1 l
      else a::(fusionneListeContenant (et1, et2) l)

(*****************************************************************************)
(* Arrays *)
(*****************************************************************************)

(* do bound checking ? *)
let array_find_index f a =
  let rec array_find_index_ i =
    if f i then i else array_find_index_ (i+1)
  in
  try array_find_index_ 0 with _ -> raise Not_found

let array_find_index_via_elem f a =
  let rec array_find_index_ i =
    if f a.(i) then i else array_find_index_ (i+1)
  in
  try array_find_index_ 0 with _ -> raise Not_found



type idx = Idx of int
let next_idx (Idx i) = (Idx (i+1))
let int_of_idx (Idx i) = i

let array_find_index_typed f a =
  let rec array_find_index_ i =
    if f i then i else array_find_index_ (next_idx i)
  in
  try array_find_index_ (Idx 0) with _ -> raise Not_found



(*****************************************************************************)
(* Matrix *)
(*****************************************************************************)

type 'a matrix = 'a array array

let map_matrix f mat =
  mat |> Array.map (fun arr -> arr |> Array.map f)

let (make_matrix_init:
        nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) =
 fun ~nrow ~ncolumn f ->
  Array.init nrow (fun i ->
    Array.init ncolumn (fun j ->
      f i j
    )
  )

let iter_matrix f m =
  Array.iteri (fun i e ->
    Array.iteri (fun j x ->
      f i j x
    ) e
  ) m

let nb_rows_matrix m =
  Array.length m

let nb_columns_matrix m =
  assert(Array.length m > 0);
  Array.length m.(0)

(* check all nested arrays have the same size *)
let invariant_matrix m =
  raise Common.Todo

let (rows_of_matrix: 'a matrix -> 'a list list) = fun m ->
  Array.to_list m |> List.map Array.to_list

let (columns_of_matrix: 'a matrix -> 'a list list) = fun m ->
  let nbcols = nb_columns_matrix m in
  let nbrows = nb_rows_matrix m in
  (enum 0 (nbcols -1)) |> List.map (fun j ->
    (enum 0 (nbrows -1)) |> List.map (fun i ->
      m.(i).(j)
    ))


let all_elems_matrix_by_row m =
  rows_of_matrix m |> List.flatten


let ex_matrix1 =
  [|
    [|0;1;2|];
    [|3;4;5|];
    [|6;7;8|];
  |]
let ex_rows1 =
  [
    [0;1;2];
    [3;4;5];
    [6;7;8];
  ]
let ex_columns1 =
  [
    [0;3;6];
    [1;4;7];
    [2;5;8];
  ]
let _ = assert (rows_of_matrix ex_matrix1 =*= ex_rows1)
let _ = assert (columns_of_matrix ex_matrix1 =*= ex_columns1)


(*****************************************************************************)
(* Fast array *)
(*****************************************************************************)
(*
module B_Array = Bigarray.Array2
*)

(*
open B_Array
open Bigarray
*)


(* for the string_of auto generation of camlp4
val b_array_string_of_t : 'a -> 'b -> string
val bigarray_string_of_int16_unsigned_elt : 'a -> string
val bigarray_string_of_c_layout : 'a -> string
let b_array_string_of_t f a = "<>"
let bigarray_string_of_int16_unsigned_elt a = "<>"
let bigarray_string_of_c_layout a = "<>"

*)


(*****************************************************************************)
(* Set. Have a look too at set*.mli  *)
(*****************************************************************************)
type 'a set = 'a list
  (* with sexp *)

let (empty_set: 'a set) = []
let (insert_set: 'a -> 'a set -> 'a set) = fun x xs ->
  if List.mem x xs
  then (* let _ = print_string "warning insert: already exist" in *)
    xs
  else x::xs

let is_set xs =
  has_no_duplicate xs

let (single_set: 'a -> 'a set) = fun x -> insert_set x empty_set
let (set: 'a list -> 'a set) = fun xs ->
  xs |> List.fold_left (flip insert_set) empty_set |> List.sort compare

let (exists_set: ('a -> bool) -> 'a set -> bool) = List.exists
let (forall_set: ('a -> bool) -> 'a set -> bool) = List.for_all
let (filter_set: ('a -> bool) -> 'a set -> 'a set) = List.filter
let (fold_set: ('a -> 'b -> 'a) -> 'a -> 'b set -> 'a) = List.fold_left
let (map_set: ('a -> 'b) -> 'a set -> 'b set) = List.map
let (member_set: 'a -> 'a set -> bool) = List.mem

let find_set = List.find
let sort_set = List.sort
let iter_set = List.iter

let (top_set: 'a set -> 'a) = List.hd

let (inter_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
  s1 |> fold_set (fun acc x -> if member_set x s2 then insert_set x acc else acc) empty_set
let (union_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
  s2 |> fold_set (fun acc x -> if member_set x s1 then acc else insert_set x acc) s1
let (minus_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
  s1 |> filter_set  (fun x -> not (member_set x s2))


let union_all l = List.fold_left union_set [] l

let big_union_set f xs = xs |> map_set f |> fold_set union_set empty_set

let (card_set: 'a set -> int) = List.length

let (include_set: 'a set -> 'a set -> bool) = fun s1 s2 ->
  (s1 |> forall_set (fun p -> member_set p s2))

let equal_set s1 s2 = include_set s1 s2 && include_set s2 s1

let (include_set_strict: 'a set -> 'a set -> bool) = fun s1 s2 ->
  (card_set s1 < card_set s2) && (include_set s1 s2)

let ($*$) = inter_set
let ($+$) = union_set
let ($-$) = minus_set
let ($?$) a b =
  Common.profile_code "$?$" (fun () -> member_set a b)
let ($<$) = include_set_strict
let ($<=$) = include_set
let ($=$) = equal_set

(* as $+$ but do not check for memberness, allow to have set of func *)
let ($@$) = fun a b -> a @ b

let rec nub = function
    [] -> []
  | x::xs -> if List.mem x xs then nub xs else x::(nub xs)

(*****************************************************************************)
(* Set as normal list *)
(*****************************************************************************)
(*
let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 ->
  List.fold_left (fun acc x -> if List.mem x l1 then acc else x::acc) l1 l2

let insert_normal x xs = union xs [x]

(* retourne lis1 - lis2 *)
let minus l1 l2 = List.filter    (fun x -> not (List.mem x l2)) l1

let inter l1 l2 = List.fold_left (fun acc x -> if List.mem x l2 then x::acc else acc) [] l1

let union_list =  List.fold_left union []

let uniq lis =
  List.fold_left (function acc -> function el -> union [el] acc) [] lis

(* pixel *)
let rec non_uniq = function
  | [] -> []
  | e::l -> if mem e l then e :: non_uniq l else non_uniq l

let rec inclu lis1 lis2 =
  List.for_all (function el -> List.mem el lis2) lis1

let equivalent lis1 lis2 =
  (inclu lis1 lis2) && (inclu lis2 lis1)

*)


(*****************************************************************************)
(* Set as sorted list *)
(*****************************************************************************)
(* liste trie, cos we need to do intersection, and insertion (it is a set
   cos when introduce has, if we create a new has => must do a recurse_rep
   and another categ can have to this has => must do an union
 *)
(*
let rec insert x = function
  | [] -> [x]
  | y::ys ->
      if x = y then y::ys
      else (if x < y then x::y::ys else y::(insert x ys))

(* same, suppose sorted list *)
let rec intersect x y =
  match(x,y) with
  | [], y -> []
  | x,  [] -> []
  | x::xs, y::ys ->
      if x = y then x::(intersect xs ys)
      else
  (if x < y then intersect xs (y::ys)
  else intersect (x::xs) ys
 )
(* intersect [1;3;7] [2;3;4;7;8];;   *)
*)

(*****************************************************************************)
(* Sets specialized *)
(*****************************************************************************)

(* people often do that *)
module StringSetOrig = Set.Make(struct type t = string let compare = compare end)

module StringSet = struct
  include StringSetOrig
  let of_list xs =
    xs |> List.fold_left (fun acc e ->
      StringSetOrig.add e acc
    ) StringSetOrig.empty
  let to_list t =
    StringSetOrig.elements t
end


(*****************************************************************************)
(* Assoc *)
(*****************************************************************************)
type ('a,'b) assoc  = ('a * 'b) list
  (* with sexp *)


let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
  xs |> List.fold_left (fun acc (k, v) ->
    (fun k' ->
      if k =*= k' then v else acc k'
    )) (fun k -> failwith "no key in this assoc")
(* simpler:
let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
  fun k -> List.assoc k xs
*)

let (empty_assoc: ('a, 'b) assoc) = []
let fold_assoc = List.fold_left
let insert_assoc = fun x xs -> x::xs
let map_assoc = List.map
let filter_assoc = List.filter

let assoc = List.assoc
let keys xs = List.map fst xs

let lookup = assoc

(* assert unique key ?*)
let del_assoc key xs = xs |> List.filter (fun (k,v) -> k <> key)
let replace_assoc (key, v) xs = insert_assoc (key, v) (del_assoc key xs)

let apply_assoc key f xs =
  let old = assoc key xs in
  replace_assoc (key, f old) xs

let big_union_assoc f xs = xs |> map_assoc f |> fold_assoc union_set empty_set

(* todo: pb normally can suppr fun l -> .... l but if do that, then strange type _a
 => assoc_map is strange too => equal dont work
*)
let (assoc_reverse: (('a * 'b) list) -> (('b * 'a) list)) = fun l ->
  List.map (fun(x,y) -> (y,x)) l

let (assoc_map: (('a * 'b) list) -> (('a * 'b) list) -> (('a * 'a) list)) =
 fun l1 l2 ->
  let (l1bis, l2bis) = (assoc_reverse l1, assoc_reverse l2) in
  List.map (fun (x,y) -> (y, List.assoc x l2bis )) l1bis

let rec (lookup_list: 'a -> ('a, 'b) assoc list -> 'b) = fun el -> function
  | [] -> raise Not_found
  | (xs::xxs) -> try List.assoc el xs with Not_found -> lookup_list el xxs

let (lookup_list2: 'a -> ('a, 'b) assoc list -> ('b * int)) = fun el xxs ->
  let rec lookup_l_aux i = function
  | [] -> raise Not_found
  | (xs::xxs) ->
      try let res = List.assoc el xs in (res,i)
      with Not_found -> lookup_l_aux (i+1) xxs
  in lookup_l_aux 0 xxs

let _ = assert
  (lookup_list2 "c" [["a",1;"b",2];["a",1;"b",3];["a",1;"c",7]] =*= (7,2))


let assoc_opt  k l =
  optionise (fun () -> List.assoc k l)

let assoc_with_err_msg k l =
  try List.assoc k l
  with Not_found ->
    pr2 (spf "pb assoc_with_err_msg: %s" (dump k));
    raise Not_found

(*****************************************************************************)
(* Assoc int -> xxx with binary tree.  Have a look too at Mapb.mli *)
(*****************************************************************************)

(* ex: type robot_list = robot_info IntMap.t *)
module IntMap = Map.Make
    (struct
      type t = int
      let compare = compare
    end)
let intmap_to_list m = IntMap.fold (fun id v acc -> (id, v) :: acc) m []
let intmap_string_of_t f a = "<Not Yet>"

module IntIntMap = Map.Make
    (struct
      type t = int * int
      let compare = compare
end)

let intintmap_to_list m = IntIntMap.fold (fun id v acc -> (id, v) :: acc) m []
let intintmap_string_of_t f a = "<Not Yet>"


(*****************************************************************************)
(* Hash *)
(*****************************************************************************)

(* il parait que better  when choose a prime *)
let hcreate () = Hashtbl.create 401
let hadd (k,v) h = Hashtbl.add h k v
let hmem k h = Hashtbl.mem h k
let hfind k h = Hashtbl.find h k
let hreplace (k,v) h = Hashtbl.replace h k v
let hiter = Hashtbl.iter
let hfold = Hashtbl.fold
let hremove k h = Hashtbl.remove h k


let hash_to_list h =
  Hashtbl.fold (fun k v acc -> (k,v)::acc) h []
  |> List.sort compare

let hash_to_list_unsorted h =
  Hashtbl.fold (fun k v acc -> (k,v)::acc) h []

let hash_of_list xs =
  let h = Hashtbl.create 101 in
  begin
    (* replace or add? depends the semantic of hashtbl you want *)
    xs |> List.iter (fun (k, v) -> Hashtbl.replace h k v);
    h
  end

(*
let _  =
  let h = Hashtbl.create 101 in
  Hashtbl.add h "toto" 1;
  Hashtbl.add h "toto" 1;
  assert(hash_to_list h =*= ["toto",1; "toto",1])
*)


let hfind_default key value_if_not_found h =
  try Hashtbl.find h key
  with Not_found ->
    (Hashtbl.add h key (value_if_not_found ()); Hashtbl.find h key)

(* not as easy as Perl  $h->{key}++; but still possible *)
let hupdate_default key ~update:op ~default:value_if_not_found h =
  let old = hfind_default key value_if_not_found h in
  Hashtbl.replace h key (op old)

let add1 old = old + 1
let cst_zero () = 0

let hfind_option key h =
  optionise (fun () -> Hashtbl.find h key)


(* see below: let hkeys h = ... *)

let count_elements_sorted_highfirst xs =
  let h = Hashtbl.create 101 in
  xs |> List.iter (fun e ->
    hupdate_default e (fun old -> old + 1) (fun () -> 0) h
  );
  let xs = hash_to_list h in
  (* not very efficient ... but simpler. use max_with_elem stuff ? *)
  sort_by_val_highfirst xs

let most_recurring_element xs =
  let xs' = count_elements_sorted_highfirst xs in
  match xs' with
  | (e, count)::_ -> e
  | [] -> failwith "most_recurring_element: empty list"



(*****************************************************************************)
(* Hash sets *)
(*****************************************************************************)

type 'a hashset = ('a, bool) Hashtbl.t
  (* with sexp *)


let hash_hashset_add k e h =
  match optionise (fun () -> Hashtbl.find h k) with
  | Some hset -> Hashtbl.replace hset e true
  | None ->
      let hset = Hashtbl.create 11 in
      begin
        Hashtbl.add h k hset;
        Hashtbl.replace hset e true;
      end

let hashset_to_set baseset h =
 h |> hash_to_list |> List.map fst |> (fun xs -> baseset#fromlist xs)

let hashset_to_list h = hash_to_list h |> List.map fst

let hashset_of_list xs =
  xs |> List.map (fun x -> x, true) |> hash_of_list

let hashset_union h1 h2 =
  h2 |> Hashtbl.iter (fun k _bool ->
    Hashtbl.replace h1 k true
  )

let hashset_inter h1 h2 =
  h1 |> Hashtbl.iter (fun k _bool ->
    if not (Hashtbl.mem h2 k)
    then Hashtbl.remove h1 k
  )


let hkeys h =
  let hkey = Hashtbl.create 101 in
  h |> Hashtbl.iter (fun k v -> Hashtbl.replace hkey k true);
  hashset_to_list hkey

let hunion h1 h2 =
  h2 |> Hashtbl.iter (fun k v ->
    Hashtbl.add h1 k v
  )


let group_assoc_bykey_eff2 xs =
  let h = Hashtbl.create 101 in
  xs |> List.iter (fun (k, v) -> Hashtbl.add h k v);
  let keys = hkeys h in
  keys |> List.map (fun k -> k, Hashtbl.find_all h k)

let group_assoc_bykey_eff xs =
  Common.profile_code "Common.group_assoc_bykey_eff" (fun () ->
    group_assoc_bykey_eff2 xs)


let test_group_assoc () =
  let xs = enum 0 10000 |> List.map (fun i -> i_to_s i, i) in
  let xs = ("0", 2)::xs in
(*    let _ys = xs +> Common.groupBy (fun (a,resa) (b,resb) -> a =$= b)  *)
  let ys = xs |> group_assoc_bykey_eff
  in
  pr2_gen ys


let uniq_eff xs =
  let h = Hashtbl.create 101 in
  xs |> List.iter (fun k ->
    Hashtbl.replace h k true
  );
  hkeys h

let big_union_eff xxs =
  let h = Hashtbl.create 101 in

  xxs |> List.iter (fun xs ->
    xs |> List.iter (fun k ->
    Hashtbl.replace h k true
  );
  );
  hkeys h

let rec uniq_from_sorted acc = function
  | [] -> acc
  | [x] -> x :: acc
  | x :: (y :: _ as rl) when x = y ->
      uniq_from_sorted acc rl
  | x :: rl -> uniq_from_sorted (x :: acc) rl

let uniq_more_eff xs =
  let l = List.sort (fun x y -> - compare x y) xs in
  uniq_from_sorted [] l


let diff_set_eff xs1 xs2 =
  let h1 = hashset_of_list xs1 in
  let h2 = hashset_of_list xs2 in

  let hcommon = Hashtbl.create 101 in
  let honly_in_h1 = Hashtbl.create 101 in
  let honly_in_h2 = Hashtbl.create 101 in

  h1 |> Hashtbl.iter (fun k _ ->
    if Hashtbl.mem h2 k
    then Hashtbl.replace hcommon k true
    else Hashtbl.add honly_in_h1 k true
  );
  h2 |> Hashtbl.iter (fun k _ ->
    if Hashtbl.mem h1 k
    then Hashtbl.replace hcommon k true
    else Hashtbl.add honly_in_h2 k true
  );
  hashset_to_list hcommon,
  hashset_to_list honly_in_h1,
  hashset_to_list honly_in_h2

(*****************************************************************************)
(* Hash with default value *)
(*****************************************************************************)

(*
type ('k,'v) hash_with_default = {
  h: ('k, 'v) Hashtbl.t;
  default_value: unit -> 'v;
}
*)
type ('a, 'b) hash_with_default =
  < add : 'a -> 'b -> unit;
    to_list : ('a * 'b) list;
    to_h: ('a, 'b) Hashtbl.t;
    update : 'a -> ('b -> 'b) -> unit;
    assoc: 'a -> 'b;
  >

let hash_with_default fv =
object
  val h = Hashtbl.create 101
  method to_list = hash_to_list h
  method to_h = h

  method add k v =
    Hashtbl.replace h k v
  method assoc k =
    Hashtbl.find h k
  method update k f =
    hupdate_default k ~update:f ~default:fv h
end



(*****************************************************************************)
(* Stack *)
(*****************************************************************************)
type 'a stack = 'a list
  (* with sexp *)

let (empty_stack: 'a stack) = []
(*let (push: 'a -> 'a stack -> 'a stack) = fun x xs -> x::xs *)
let (top: 'a stack -> 'a) = List.hd
let (pop: 'a stack -> 'a stack) = List.tl

let top_option = function
  | [] -> None
  | x::xs -> Some x




(* now in prelude:
 * let push2 v l = l := v :: !l
 *)

let pop2 l =
  let v = List.hd !l in
  begin
    l := List.tl !l;
    v
  end


(*****************************************************************************)
(* Undoable Stack *)
(*****************************************************************************)

(* Okasaki use such structure also for having efficient data structure
 * supporting fast append.
 *)

type 'a undo_stack = 'a list * 'a list (* redo *)

let (empty_undo_stack: 'a undo_stack) =
  [], []

(* push erase the possible redo *)
let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) ->
  x::undo, []

let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) ->
  List.hd undo

let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
  match undo with
  | [] ->  failwith "empty undo stack"
  | x::xs ->
      xs, x::redo

let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
  match redo with
  | [] -> failwith "empty redo, nothing to redo"
  | x::xs ->
      x::undo, xs

let redo_undo x = undo_pop x


let top_undo_option = fun (undo, redo) ->
  match undo with
  | [] -> None
  | x::xs -> Some x

(*****************************************************************************)
(* Binary tree *)
(*****************************************************************************)

(* type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree) *)


(*****************************************************************************)
(* N-ary tree *)
(*****************************************************************************)

(* no empty tree, must have one root at list *)
type 'a tree2 = Tree of 'a * ('a tree2) list

let rec (tree2_iter: ('a -> unit) -> 'a tree2 -> unit) = fun f tree ->
  match tree with
  | Tree (node, xs) ->
      f node;
      xs |> List.iter (tree2_iter f)


type ('a, 'b) tree =
  | Node of 'a * ('a, 'b) tree list
  | Leaf of 'b
 (* with tarzan *)

let rec map_tree ~fnode ~fleaf tree  =
  match tree with
  | Leaf x -> Leaf (fleaf x)
  | Node (x, xs) ->
      Node (fnode x, xs |> List.map (map_tree ~fnode ~fleaf))


(*****************************************************************************)
(* N-ary tree with updatable childrens *)
(*****************************************************************************)

(* no empty tree, must have one root at list *)

type 'a treeref =
  | NodeRef of 'a * 'a treeref list ref

let treeref_children_ref tree =
  match tree with
  | NodeRef (n, x) -> x



let rec (treeref_node_iter:
(*   (('a * ('a, 'b) treeref list ref) -> unit) ->
   ('a, 'b) treeref -> unit
*) 'a)
 =
 fun f tree ->
  match tree with
(*  | LeafRef _ -> ()*)
  | NodeRef (n, xs) ->
      f (n, xs);
      !xs |> List.iter (treeref_node_iter f)


let find_treeref f tree =
  let res = ref [] in

  tree |> treeref_node_iter (fun (n, xs) ->
    if f (n,xs)
    then push (n, xs) res;
  );
  match !res with
  | [n,xs] -> NodeRef (n, xs)
  | [] -> raise Not_found
  | x::y::zs -> raise Common.Multi_found

let rec (treeref_node_iter_with_parents:
 (*  (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) ->
   ('a, 'b) treeref -> unit)
 *) 'a)
 =
 fun f tree ->
  let rec aux acc tree =
    match tree with
(*    | LeafRef _ -> ()*)
    | NodeRef (n, xs) ->
        f (n, xs) acc ;
        !xs |> List.iter (aux (n::acc))
  in
  aux [] tree


(* ---------------------------------------------------------------------- *)
(* Leaf can seem redundant, but sometimes want to directly see if
 * a children is a leaf without looking if the list is empty.
 *)
type ('a, 'b) treeref2 =
  | NodeRef2 of 'a * ('a, 'b) treeref2 list ref
  | LeafRef2 of 'b


let treeref2_children_ref tree =
  match tree with
  | LeafRef2 _ -> failwith "treeref_tail: leaf"
  | NodeRef2 (n, x) -> x



let rec (treeref_node_iter2:
   (('a * ('a, 'b) treeref2 list ref) -> unit) ->
   ('a, 'b) treeref2 -> unit) =
 fun f tree ->
  match tree with
  | LeafRef2 _ -> ()
  | NodeRef2 (n, xs) ->
      f (n, xs);
      !xs |> List.iter (treeref_node_iter2 f)


let find_treeref2 f tree =
  let res = ref [] in

  tree |> treeref_node_iter2 (fun (n, xs) ->
    if f (n,xs)
    then push (n, xs) res;
  );
  match !res with
  | [n,xs] -> NodeRef2 (n, xs)
  | [] -> raise Not_found
  | x::y::zs -> raise Common.Multi_found




let rec (treeref_node_iter_with_parents2:
  (('a * ('a, 'b) treeref2 list ref) -> ('a list) -> unit) ->
   ('a, 'b) treeref2 -> unit) =
 fun f tree ->
  let rec aux acc tree =
    match tree with
    | LeafRef2 _ -> ()
    | NodeRef2 (n, xs) ->
        f (n, xs) acc ;
        !xs |> List.iter (aux (n::acc))
  in
  aux [] tree













let find_treeref_with_parents_some f tree =
  let res = ref [] in

  tree |> treeref_node_iter_with_parents (fun (n, xs) parents ->
    match f (n,xs) parents with
    | Some v -> push v res;
    | None -> ()
  );
  match !res with
  | [v] -> v
  | [] -> raise Not_found
  | x::y::zs -> raise Common.Multi_found

let find_multi_treeref_with_parents_some f tree =
  let res = ref [] in

  tree |> treeref_node_iter_with_parents (fun (n, xs) parents ->
    match f (n,xs) parents with
    | Some v -> push v res;
    | None -> ()
  );
  match !res with
  | [v] -> !res
  | [] -> raise Not_found
  | x::y::zs -> !res


(*****************************************************************************)
(* Graph. Have a look too at Ograph_*.mli  *)
(*****************************************************************************)
(*
 * Very simple implementation of a (directed) graph by list of pairs.
 * Could also use a matrix, or adjacent list, or pointer(ref).
 * todo: do some check (dont exist already, ...)
 * todo: generalise to put in common (need 'edge (and 'c ?),
 *  and take in param a display func, cos caml sux, no overloading of show :(
 *)

type 'node graph = ('node set) * (('node * 'node) set)

let (add_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) ->
  (node::nodes, arcs)

let (del_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) ->
  (nodes $-$ set [node], arcs)
(* could do more job:
  let _ = assert (successors node (nodes, arcs) = empty) in
   +> List.filter (fun (src, dst) -> dst != node))
*)
let (add_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) ->
  (nodes, set [arc] $+$ arcs)

let (del_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) ->
  (nodes, arcs |> List.filter (fun a -> not (arc =*= a)))

let (successors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) ->
  arcs |> List.filter (fun (src, dst) -> src =*= x) |> List.map snd

let (predecessors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) ->
  arcs |> List.filter (fun (src, dst) -> dst =*= x) |> List.map fst

let (nodes: 'a graph -> 'a set) = fun (nodes, arcs) -> nodes

(* pre: no cycle *)
let rec (fold_upward: ('b -> 'a -> 'b) -> 'a set -> 'b -> 'a graph  -> 'b) =
 fun f xs acc graph ->
  match xs with
  | [] -> acc
  | x::xs -> (f acc x)
        |> (fun newacc -> fold_upward f (graph |> predecessors x) newacc graph)
        |> (fun newacc -> fold_upward f xs newacc graph)
   (* TODO avoid already visited *)

let empty_graph = ([], [])



(*
let (add_arcs_toward: int -> (int list) -> 'a graph -> 'a graph) = fun i xs ->
  function
    (nodes, arcs) -> (nodes, (List.map (fun j -> (j,i) ) xs)++arcs)
let (del_arcs_toward: int -> (int list) -> 'a graph -> 'a graph)= fun i xs g ->
    List.fold_left (fun acc el -> del_arc (el, i) acc) g xs
let (add_arcs_from: int -> (int list) -> 'a graph -> 'a graph) = fun i xs ->
 function
    (nodes, arcs) -> (nodes, (List.map (fun j -> (i,j) ) xs)++arcs)


let (del_node: (int * 'node) -> 'node graph -> 'node graph) = fun node ->
 function (nodes, arcs) ->
  let newnodes = List.filter (fun a -> not (node = a)) nodes in
    if newnodes = nodes then (raise Not_found) else (newnodes, arcs)
let (replace_node: int -> 'node -> 'node graph -> 'node graph) = fun i n ->
 function (nodes, arcs) ->
  let newnodes = List.filter (fun (j,_) -> not (i = j)) nodes in
    ((i,n)::newnodes, arcs)
let (get_node: int -> 'node graph -> 'node) = fun i -> function
    (nodes, arcs) -> List.assoc i nodes

let (get_free: 'a graph -> int) = function
    (nodes, arcs) -> (maximum (List.map fst nodes))+1
(* require no cycle !!
  TODO if cycle check that we have already visited a node *)
let rec (succ_all: int -> 'a graph -> (int list)) = fun i -> function
    (nodes, arcs) as g ->
      let direct = succ i g in
      union direct (union_list (List.map (fun i -> succ_all i g) direct))
let rec (pred_all: int -> 'a graph -> (int list)) = fun i -> function
    (nodes, arcs) as g ->
      let direct = pred i g in
      union direct (union_list (List.map (fun i -> pred_all i g) direct))
(* require that the nodes are different !! *)
let rec (equal: 'a graph -> 'a graph -> bool) = fun g1 g2 ->
  let ((nodes1, arcs1),(nodes2, arcs2)) = (g1,g2) in
  try
   (* do 2 things, check same length and to assoc *)
    let conv = assoc_map nodes1 nodes2 in
    List.for_all (fun (i1,i2) ->
       List.mem (List.assoc i1 conv, List.assoc i2 conv) arcs2)
     arcs1
      && (List.length arcs1 = List.length arcs2)
    (* could think that only forall is needed, but need check same lenth too*)
  with _ -> false

let (display: 'a graph -> ('a -> unit) -> unit) = fun g display_func ->
  let rec aux depth i =
    print_n depth " ";
    print_int i; print_string "->"; display_func (get_node i g);
    print_string "\n";
    List.iter (aux (depth+2)) (succ i g)
  in aux 0 1

let (display_dot: 'a graph -> ('a -> string) -> unit)= fun (nodes,arcs) func ->
  let file = open_out "test.dot" in
  output_string file "digraph misc {\n" ;
  List.iter (fun (n, node) ->
    output_int file n; output_string file " [label=\"";
    output_string file (func node); output_string file " \"];\n"; ) nodes;
  List.iter (fun (i1,i2) ->  output_int file i1 ; output_string file " -> " ;
    output_int file i2 ; output_string file " ;\n"; ) arcs;
  output_string file "}\n" ;
  close_out file;
  let status = Unix.system "viewdot test.dot" in
  ()
(* todo: faire = graphe (int can change !!! => cant make simply =)
   reassign number first !!
 *)

(* todo: mettre diff(modulo = !!) en rouge *)
let (display_dot2: 'a graph -> 'a graph -> ('a -> string) -> unit) =
  fun (nodes1, arcs1) (nodes2, arcs2) func ->
  let file = open_out "test.dot" in
  output_string file "digraph misc {\n" ;
  output_string file "rotate = 90;\n";
  List.iter (fun (n, node) ->
    output_string file "100"; output_int file n;
    output_string file " [label=\"";
    output_string file (func node); output_string file " \"];\n"; ) nodes1;
  List.iter (fun (n, node) ->
    output_string file "200"; output_int file n;
    output_string file " [label=\"";
    output_string file (func node); output_string file " \"];\n"; ) nodes2;
  List.iter (fun (i1,i2) ->
    output_string file "100"; output_int file i1 ; output_string file " -> " ;
    output_string file "100"; output_int file i2 ; output_string file " ;\n";
    )
   arcs1;
  List.iter (fun (i1,i2) ->
    output_string file "200"; output_int file i1 ; output_string file " -> " ;
    output_string file "200"; output_int file i2 ; output_string file " ;\n"; )
   arcs2;
(*  output_string file "500 -> 1001; 500 -> 2001}\n" ; *)
  output_string file "}\n" ;
  close_out file;
  let status = Unix.system "viewdot test.dot" in
  ()


*)
(*****************************************************************************)
(* Generic op *)
(*****************************************************************************)
(* overloading *)

let map = List.map (* note: really really slow, use rev_map if possible *)
let filter = List.filter
let fold = List.fold_left
let member = List.mem
let iter = List.iter
let find = List.find
let exists = List.exists
let forall = List.for_all
let big_union f xs = xs |> map f |> fold union_set empty_set
(* let empty = [] *)
let empty_list = []
let sort xs = List.sort compare xs
let length = List.length
(* in prelude now: let null xs = match xs with [] -> true | _ -> false *)
let head = List.hd
let tail = List.tl
let is_singleton = fun xs -> List.length xs =|= 1
(*x: common.ml *)

(*###########################################################################*)
(* Misc functions *)
(*###########################################################################*)

(*****************************************************************************)
(* Geometry (raytracer) *)
(*****************************************************************************)

type vector = (float * float * float)
type point = vector
type color = vector (* color(0-1) *)

(* todo: factorise *)
let (dotproduct: vector * vector -> float) =
  fun ((x1,y1,z1),(x2,y2,z2)) -> (x1*.x2 +. y1*.y2 +. z1*.z2)
let (vector_length: vector -> float) =
  fun (x,y,z) -> sqrt (square x +. square y +. square z)
let (minus_point: point * point -> vector) =
  fun ((x1,y1,z1),(x2,y2,z2)) -> ((x1 -. x2),(y1 -. y2),(z1 -. z2))
let (distance: point * point -> float) =
  fun (x1, x2) -> vector_length (minus_point (x2,x1))
let (normalise: vector -> vector) =
  fun (x,y,z) ->
    let len = vector_length (x,y,z) in (x /. len, y /. len, z /. len)
let (mult_coeff: vector -> float -> vector) =
  fun (x,y,z) c -> (x *. c, y *. c, z *. c)
let (add_vector: vector -> vector -> vector) =
  fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in
  (x1+.x2, y1+.y2, z1+.z2)
let (mult_vector: vector -> vector -> vector) =
  fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in
  (x1*.x2, y1*.y2, z1*.z2)
let sum_vector = List.fold_left add_vector (0.0,0.0,0.0)

(*****************************************************************************)
(* Pics (raytracer) *)
(*****************************************************************************)

type pixel = (int * int * int) (* RGB *)

(* required pixel list in row major order, line after line *)
let (write_ppm: int -> int -> (pixel list) -> string -> unit) = fun
  width height xs filename ->
    let chan = open_out filename in
    begin
     output_string chan "P6\n";
     output_string chan ((string_of_int width)  ^ "\n");
     output_string chan ((string_of_int height) ^ "\n");
     output_string chan "255\n";
     List.iter (fun (r,g,b) ->
       List.iter (fun byt -> output_byte chan byt) [r;g;b]
        ) xs;
     close_out chan
    end

let test_ppm1 () = write_ppm 100 100
    ((generate (50*100) (1,45,100)) @ (generate (50*100) (1,1,100)))
    "img.ppm"

(*****************************************************************************)
(* Diff (lfs) *)
(*****************************************************************************)
type diff = Match | BnotinA | AnotinB

let (diff: (int -> int -> diff -> unit)-> (string list * string list) -> unit)=
  fun f (xs,ys) ->
    let file1 = "/tmp/diff1-" ^ (string_of_int (Unix.getuid ())) in
    let file2 = "/tmp/diff2-" ^ (string_of_int (Unix.getuid ())) in
    let fileresult = "/tmp/diffresult-" ^ (string_of_int (Unix.getuid ())) in
    write_file file1 (unwords xs);
    write_file file2 (unwords ys);
    command2
      ("diff --side-by-side -W 1 " ^ file1 ^ " " ^ file2 ^ " > " ^ fileresult);
    let res = cat fileresult in
    let a = ref 0 in
    let b = ref 0 in
    res |> List.iter (fun s ->
      match s with
      | ("" | " ") -> f !a !b Match; incr a; incr b;
      | ">" -> f !a !b BnotinA; incr b;
      | ("|" | "/" | "\\" ) ->
          f !a !b BnotinA; f !a !b AnotinB; incr a; incr b;
      | "<" -> f !a !b AnotinB; incr a;
      | _ -> raise Common.Impossible
    )
(*
let _ =
  diff
    ["0";"a";"b";"c";"d";    "f";"g";"h";"j";"q";            "z"]
    [    "a";"b";"c";"d";"e";"f";"g";"i";"j";"k";"r";"x";"y";"z"]
   (fun x y -> pr "match")
   (fun x y -> pr "a_not_in_b")
   (fun x y -> pr "b_not_in_a")
*)

let (diff2: (int -> int -> diff -> unit) -> (string * string) -> unit) =
 fun f (xstr,ystr) ->
    write_file "/tmp/diff1" xstr;
    write_file "/tmp/diff2" ystr;
    command2
     ("diff --side-by-side --left-column -W 1 " ^
      "/tmp/diff1 /tmp/diff2 > /tmp/diffresult");
    let res = cat "/tmp/diffresult" in
    let a = ref 0 in
    let b = ref 0 in
    res |> List.iter (fun s ->
      match s with
      | "(" -> f !a !b Match; incr a; incr b;
      | ">" -> f !a !b BnotinA; incr b;
      | "|" -> f !a !b BnotinA; f !a !b AnotinB; incr a; incr b;
      | "<" -> f !a !b AnotinB; incr a;
      | _ -> raise Common.Impossible
    )


(*****************************************************************************)
(* Grep *)
(*****************************************************************************)

(* src: coccinelle *)
let contain_any_token_with_egrep tokens file =
  let tokens = tokens |> List.map (fun s ->
    match () with
    | _ when s =~ "^[A-Za-z_][A-Za-z_0-9]*$" ->
        "\\b" ^ s ^ "\\b"

    | _ when s =~ "^[A-Za-z_]" ->
        "\\b" ^ s

    | _ when s =~ ".*[A-Za-z_]$" ->
        s ^ "\\b"
    | _ -> s

  ) in
  let cmd = spf "egrep -q '(%s)' %s" (join "|" tokens) file
  in
  (match Sys.command cmd with
  | 0 (* success *) -> true
  | _ (* failure *) -> false (* no match, so not worth trying *)
  )

(*****************************************************************************)
(* Parsers (aop-colcombet) *)
(*****************************************************************************)

let parserCommon lexbuf parserer lexer =
  try
    let result = parserer lexer lexbuf in
    result
  with Parsing.Parse_error ->
    print_string "buf: "; print_bytes lexbuf.Lexing.lex_buffer;
    print_string "\n";
    print_string "current: "; print_int lexbuf.Lexing.lex_curr_pos;
    print_string "\n";
    raise Parsing.Parse_error


(* marche pas ca neuneu *)
(*
let getDoubleParser parserer lexer string =
  let lexbuf1 = Lexing.from_string string in
  let chan = open_in string in
  let lexbuf2 = Lexing.from_channel chan in
  (parserCommon lexbuf1 parserer lexer  , parserCommon lexbuf2 parserer lexer )
*)

let getDoubleParser parserer lexer =
  (
   (function string ->
     let lexbuf1 = Lexing.from_string string in
     parserCommon lexbuf1 parserer lexer
   ),
   (function string ->
     let chan = open_in string in
     let lexbuf2 = Lexing.from_channel chan in
     parserCommon lexbuf2 parserer lexer
   ))


(*****************************************************************************)
(* parser combinators *)
(*****************************************************************************)

(* cf parser_combinators.ml
 *
 * Could also use ocaml stream. but not backtrack and forced to do LL,
 * so combinators are better.
 *
 *)


(*****************************************************************************)
(* Parser related (cocci) *)
(*****************************************************************************)
(* now in h_program-lang/parse_info.ml *)

(*x: common.ml *)
(*****************************************************************************)
(* Regression testing bis (cocci) *)
(*****************************************************************************)

(* todo: keep also size of file, compute md5sum ? cos maybe the file
 * has changed!.
 *
 * todo: could also compute the date, or some version info of the program,
 * can record the first date when was found a OK, the last date where
 * was ok, and then first date when found fail. So the
 * Common.Ok would have more information that would be passed
 * to the Common.Pb of date * date * date * string   peut etre.
 *
 * todo? maybe use plain text file instead of marshalling.
 *)

type score_result = Ok | Pb of string
 (* with sexp *)
type score = (string (* usually a filename *), score_result) Hashtbl.t
 (* with sexp *)
type score_list = (string (* usually a filename *) * score_result) list
 (* with sexp *)

let empty_score () = (Hashtbl.create 101 : score)



let regression_testing_vs newscore bestscore =

  let newbestscore = empty_score () in

  let allres =
    (hash_to_list newscore |> List.map fst)
      $+$
    (hash_to_list bestscore |> List.map fst)
  in
  begin
    allres |> List.iter (fun res ->
      match
        optionise (fun () -> Hashtbl.find newscore res),
        optionise (fun () -> Hashtbl.find bestscore res)
      with
      | None, None -> raise Common.Impossible
      | Some x, None ->
          Printf.printf "new test file appeared: %s\n" res;
          Hashtbl.add newbestscore res x;
      | None, Some x ->
          Printf.printf "old test file disappeared: %s\n" res;
      | Some newone, Some bestone ->
          (match newone, bestone with
          | Ok, Ok ->
              Hashtbl.add newbestscore res Ok
          | Pb x, Ok ->
              Printf.printf
                "PBBBBBBBB: a test file does not work anymore!!! : %s\n" res;
              Printf.printf "Error : %s\n" x;
              Hashtbl.add newbestscore res Ok
          | Ok, Pb x ->
              Printf.printf "Great: a test file now works: %s\n" res;
              Hashtbl.add newbestscore res Ok
          | Pb x, Pb y ->
              Hashtbl.add newbestscore res (Pb x);
              if not (x =$= y)
              then begin
                Printf.printf
                  "Semipb: still error but not same error : %s\n" res;
                Printf.printf "%s\n" (chop ("Old error: " ^ y));
                Printf.printf "New error: %s\n" x;
              end
          )
    );
    flush stdout; flush stderr;
    newbestscore
  end

let regression_testing newscore best_score_file =

  pr2 ("regression file: "^ best_score_file);
  let (bestscore : score) =
    if not (Sys.file_exists best_score_file)
    then write_value (empty_score()) best_score_file;
    get_value best_score_file
  in
  let newbestscore = regression_testing_vs newscore bestscore in
  write_value newbestscore (best_score_file ^ ".old");
  write_value newbestscore best_score_file;
  ()




let string_of_score_result v =
  match v with
  | Ok -> "Ok"
  | Pb s -> "Pb: " ^ s

let total_scores score =
  let total = hash_to_list score |> List.length in
  let good  = hash_to_list score |> List.filter
    (fun (s, v) -> v =*= Ok) |> List.length in
  good, total


let print_total_score score =
  pr2 "--------------------------------";
  pr2 "total score";
  pr2 "--------------------------------";
  let (good, total) = total_scores score in
  pr2 (Printf.sprintf "good = %d/%d" good total)

let print_score score =
  score |> hash_to_list |> List.iter (fun (k, v) ->
    pr2 (Printf.sprintf "%s --> %s" k (string_of_score_result v))
  );
  print_total_score score;
  ()
(*x: common.ml *)
(*****************************************************************************)
(* Scope managment (cocci) *)
(*****************************************************************************)

(* could also make a function Common.make_scope_functions that return
 * the new_scope, del_scope, do_in_scope, add_env. Kind of functor :)
 *)

type ('a, 'b) scoped_env = ('a, 'b) assoc list

(*
let rec lookup_env f env =
  match env with
  | [] -> raise Not_found
  | []::zs -> lookup_env f zs
  | (x::xs)::zs ->
      match f x with
      | None -> lookup_env f (xs::zs)
      | Some y -> y

let member_env_key k env =
  try
    let _ = lookup_env (fun (k',v) -> if k = k' then Some v else None) env in
    true
  with Not_found -> false

*)

let rec lookup_env k env =
  match env with
  | [] -> raise Not_found
  | []::zs -> lookup_env k zs
  | ((k',v)::xs)::zs ->
      if k =*= k'
      then v
      else lookup_env k (xs::zs)

let member_env_key k env =
  match optionise (fun () -> lookup_env k env) with
  | None -> false
  | Some _ -> true


let new_scope scoped_env = scoped_env := []::!scoped_env
let del_scope scoped_env = scoped_env := List.tl !scoped_env

let do_in_new_scope scoped_env f =
  begin
    new_scope scoped_env;
    let res = f () in
    del_scope scoped_env;
    res
  end

let add_in_scope scoped_env def =
  let (current, older) = uncons !scoped_env in
  scoped_env := (def::current)::older





(* note that ocaml hashtbl store also old value of a binding when add
 * add a newbinding; that's why del_scope works
 *)

type ('a, 'b) scoped_h_env = {
  scoped_h : ('a, 'b) Hashtbl.t;
  scoped_list : ('a, 'b) assoc list;
}

let empty_scoped_h_env () = {
  scoped_h = Hashtbl.create 101;
  scoped_list = [[]];
}
let clone_scoped_h_env x =
  { scoped_h = Hashtbl.copy x.scoped_h;
    scoped_list = x.scoped_list;
  }

let rec lookup_h_env k env =
  Hashtbl.find env.scoped_h k

let member_h_env_key k env =
  match optionise (fun () -> lookup_h_env k env) with
  | None -> false
  | Some _ -> true


let new_scope_h scoped_env =
  scoped_env := {!scoped_env with scoped_list = []::!scoped_env.scoped_list}
let del_scope_h scoped_env =
  begin
    List.hd !scoped_env.scoped_list |> List.iter (fun (k, v) ->
      Hashtbl.remove !scoped_env.scoped_h k
    );
    scoped_env := {!scoped_env with scoped_list =
        List.tl !scoped_env.scoped_list
    }
  end

let do_in_new_scope_h scoped_env f =
  begin
    new_scope_h scoped_env;
    let res = f () in
    del_scope_h scoped_env;
    res
  end

(*
let add_in_scope scoped_env def =
  let (current, older) = uncons !scoped_env in
  scoped_env := (def::current)::older
*)

let add_in_scope_h x (k,v) =
  begin
    Hashtbl.add !x.scoped_h k v;
    x := { !x with scoped_list =
        ((k,v)::(List.hd !x.scoped_list))::(List.tl !x.scoped_list);
    };
  end

(*****************************************************************************)
(* Terminal *)
(*****************************************************************************)

(* See console.ml *)

(*****************************************************************************)
(* Gc optimisation (pfff) *)
(*****************************************************************************)

(* opti: to avoid stressing the GC with a huge graph, we sometimes
 * change a big AST into a string, which reduces the size of the graph
 * to explore when garbage collecting.
 *)
type 'a cached = 'a serialized_maybe ref
 and 'a serialized_maybe =
    | Serial of string
    | Unfold of 'a

let serial x =
  ref (Serial (Marshal.to_string x []))

let unserial x =
  match !x with
  | Unfold c -> c
  | Serial s ->
      let res = Marshal.from_string s 0 in
      (*        x := Unfold res; *)
      res

(*****************************************************************************)
(* Random *)
(*****************************************************************************)

let _init_random = Random.self_init ()
(*
let random_insert i l =
    let p = Random.int (length l +1)
    in let rec insert i p l =
      if (p = 0) then i::l else (hd l)::insert i (p-1) (tl l)
    in insert i p l

let rec randomize_list = function
  []  -> []
  | a::l -> random_insert a (randomize_list l)
*)
let random_list xs =
  List.nth xs (Random.int (length xs))

(* todo_opti: use fisher/yates algorithm.
 * ref: http://en.wikipedia.org/wiki/Knuth_shuffle
 *
 * public static void shuffle (int[] array)
 * {
 *  Random rng = new Random ();
 *  int n = array.length;
 *  while (--n > 0)
 *  {
 *    int k = rng.nextInt(n + 1);  // 0 <= k <= n (!)
 *    int temp = array[n];
 *    array[n] = array[k];
 *    array[k] = temp;
 *   }
 * }

 *)
let randomize_list xs =
  let permut = permutation xs in
  random_list permut



let random_subset_of_list num xs =
  let array = Array.of_list xs in
  let len = Array.length array in

  let h = Hashtbl.create 101 in
  let cnt = ref num in
  while !cnt > 0 do
    let x = Random.int len in
    if not (Hashtbl.mem h (array.(x))) (* bugfix2: not just x :) *)
    then begin
      Hashtbl.add h (array.(x)) true; (* bugfix1: not just x :) *)
      decr cnt;
    end
  done;
  let objs = hash_to_list h |> List.map fst in
  objs
(*x: common.ml *)
(*###########################################################################*)
(* Postlude *)
(*###########################################################################*)


(*****************************************************************************)
(* Flags and actions *)
(*****************************************************************************)

(*s: common.ml cmdline *)

(* I put it inside a func as it can help to give a chance to
 * change the globals before getting the options as some
 * options sometimes may want to show the default value.
 *)
let cmdline_flags_devel () =
  [
    "-debugger",         Arg.Set Common.debugger,
    " option to set if launched inside ocamldebug";
    "-profile",          Arg.Unit (fun () -> Common.profile := Common.ProfAll),
    " output profiling information";
  ]
let cmdline_flags_verbose () =
  [
    "-verbose_level",  Arg.Set_int verbose_level,
    " <int> guess what";
    "-disable_pr2_once",     Arg.Set Common.disable_pr2_once,
    " to print more messages";
    "-show_trace_profile",          Arg.Set Common.show_trace_profile,
    " show trace";
  ]

let cmdline_flags_other () =
  [
    "-nocheck_stack",      Arg.Clear _check_stack,
    " ";
    "-batch_mode", Arg.Set _batch_mode,
    " no interactivity";
    "-keep_tmp_files", Arg.Set Common.save_tmp_files,
    " ";
  ]

(* potentially other common options but not yet integrated:

  "-timeout",        Arg.Set_int timeout,
  "  <sec> interrupt LFS or buggy external plugins";

  (* can't be factorized because of the $ cvs stuff, we want the date
   * of the main.ml file, not common.ml
   *)
  "-version",   Arg.Unit (fun () ->
    pr2 "version: _dollar_Date: 2008/06/14 00:54:22 _dollar_";
    raise (Common.UnixExit 0)
    ),
  "   guess what";

  "-shorthelp", Arg.Unit (fun () ->
    !short_usage_func();
    raise (Common.UnixExit 0)
  ),
  "    see short list of options";
  "-longhelp", Arg.Unit (fun () ->
    !long_usage_func();
    raise (Common.UnixExit 0)
    ),
  "-help", Arg.Unit (fun () ->
    !long_usage_func();
    raise (Common.UnixExit 0)
  ),
  " ";
  "--help", Arg.Unit (fun () ->
    !long_usage_func();
    raise (Common.UnixExit 0)
  ),
  " ";

*)

let cmdline_actions () =
  [
    "-test_check_stack", "  <limit>",
    Common.mk_action_1_arg test_check_stack_size;
  ]

(*e: common.ml cmdline *)

(*x: common.ml *)
(*****************************************************************************)
(* Postlude *)
(*****************************************************************************)
(* stuff put here cos of of forward definition limitation of ocaml *)


(* Infix trick, seen in jane street lib and harrop's code, and maybe in GMP *)
module Infix = struct
  let (|>) = (|>)
  let (|>) = (|>)
  let (==~) = (==~)
  let (=~) = (=~)
end

(* based on code found in cameleon from maxence guesdon 
 * alt: use Digest.string! far faster!
 *)
let md5sum_of_string s =
  let com = spf "echo %s | md5sum | cut -d\" \" -f 1"
      (Filename.quote s)
  in
  match cmd_to_list com with
  | [s] ->
      (*pr2 s;*)
      s
  | _ -> failwith "md5sum_of_string wrong output"

(* less: could also use the realpath C binding in Jane Street Core library. *)
let realpath path =
  match cmd_to_list (spf "realpath %s" path) with
  | [s] -> s
  | xs ->
      failwith (spf "problem with realpath on %s: %s " path (unlines xs))


let with_pr2_to_string f =
  let file = Common.new_temp_file "pr2" "out" in
  redirect_stdout_stderr file f;
  cat file

(* julia: convert something printed using format to print into a string *)
let format_to_string f =
  let (nm,o) = Filename.open_temp_file "format_to_s" ".out" in
  (* to avoid interference with other code using Format.printf, e.g.
   * Ounit.run_tt
   *)
  Format.print_flush();
  Format.set_formatter_out_channel o;
  let _ = f () in
  Format.print_newline();
  Format.print_flush();
  Format.set_formatter_out_channel stdout;
  close_out o;
  let i = open_in nm in
  let lines = ref [] in
  let rec loop _ =
    let cur = input_line i in
    lines := cur :: !lines;
    loop() in
  (try loop() with End_of_file -> ());
  close_in i;
  command2 ("rm -f " ^ nm);
  String.concat "\n" (List.rev !lines)



(*---------------------------------------------------------------------------*)
(* Directories part 2 *)
(*---------------------------------------------------------------------------*)

(* todo? vs common_prefix_of_files_or_dirs? *)
let find_common_root files =
  let dirs_part = files |> List.map fst in

  let rec aux current_candidate xs =
    try
      let topsubdirs = xs |> List.map List.hd |> uniq_eff in
      (match topsubdirs with
      | [x] -> aux (x::current_candidate)        (xs |> List.map List.tl)
      | _ -> List.rev current_candidate
      )
    with  _ -> List.rev current_candidate
  in
  aux [] dirs_part

(*
let _ = example
  (find_common_root
      [(["home";"pad"], "foo.php");
       (["home";"pad";"bar"], "bar.php");
      ]
    =*= ["home";"pad"])
*)


let dirs_and_base_of_file file =
  let (dir, base) = db_of_filename file in
  let dirs = split "/" dir in
  let dirs =
    match dirs with
    | ["."] -> []
    | _ -> dirs
  in
  dirs, base

(*
let _ = example
  (dirs_and_base_of_file "/home/pad/foo.php" =*= (["home";"pad"], "foo.php"))
*)


let inits_of_absolute_dir dir =
  if not (is_absolute dir)
  then failwith (spf "inits_of_absolute_dir: %s is not an absolute path" dir);
  if not (is_directory dir)
  then failwith (spf "inits_of_absolute_dir: %s is not a directory" dir);
  let dir = chop_dirsymbol dir in

  let dirs = split "/" dir in
  let dirs =
    match dirs with
    | ["."] -> []
    | _ -> dirs
  in
  inits dirs |> List.map (fun xs ->
    "/" ^ join "/" xs
  )

let inits_of_relative_dir dir =
  if not (is_relative dir)
  then failwith (spf "inits_of_relative_dir: %s is not a relative dir" dir);
  let dir = chop_dirsymbol dir in

  let dirs = split "/" dir in
  let dirs =
    match dirs with
    | ["."] -> []
    | _ -> dirs
  in
  inits dirs |> List.tl |> List.map (fun xs ->
   join "/" xs
  )

(*
let _ = example
  (inits_of_absolute_dir "/usr/bin" =*= (["/"; "/usr"; "/usr/bin"]))

let _ = example
  (inits_of_relative_dir "usr/bin" =*= (["usr"; "usr/bin"]))
*)


(* main entry *)
let (tree_of_files: filename list -> (string, (string * filename)) tree) =
 fun files ->

  let files_fullpath = files in

  (* extract dirs and file from file, e.g. ["home";"pad"], "__flib.php", path *)
  let files = files |> List.map dirs_and_base_of_file in


  (* find root, eg ["home";"pad"] *)
  let root = find_common_root files in

  let files = zip files files_fullpath in

  (* remove the root part *)
  let files = files |> List.map (fun ((dirs, base), path) ->
    let n = List.length root in
    let (root', rest) =
      take n dirs,
      drop n dirs
    in
    assert(root' =*= root);
    (rest, base), path
  )
  in

  (* now ready to build the tree recursively *)
  let rec aux (xs: ((string list * string) * filename) list) =
    let files_here, rest =
      xs |> List.partition (fun ((dirs, base), _) -> null dirs)
    in
    let groups =
      rest |> group_by_mapped_key (fun ((dirs, base),_) ->
        (* would be a file if null dirs *)
        assert(not (null dirs));
        List.hd dirs
      ) in


    let nodes =
      groups |> List.map (fun (k, xs) ->
        let xs' = xs |> List.map (fun ((dirs, base), path) ->
          (List.tl dirs, base), path
        )
        in
        Node (k, aux xs')
      )
    in
    let leaves = files_here |> List.map (fun ((_dir, base), path) ->
      Leaf (base, path)
    ) in
    nodes @ leaves
  in
  Node (join "/" root,
        aux files)


(* finding the common root *)
let common_prefix_of_files_or_dirs2 xs =
  let xs = xs |> List.map relative_to_absolute in
  match xs with
  | [] -> failwith "common_prefix_of_files_or_dirs: empty list"
  | [x] -> x
  | y::ys ->
      (* todo: work when dirs ?*)
      let xs = xs |> List.map dirs_and_base_of_file in
      let dirs = find_common_root xs in
      "/" ^ join "/" dirs

let common_prefix_of_files_or_dirs xs =
  Common.profile_code "Common.common_prefix_of" (fun () ->
    common_prefix_of_files_or_dirs2 xs)

(*
let _ =
  example
    (common_prefix_of_files_or_dirs ["/home/pad/pfff/visual";
                                     "/home/pad/pfff/commons";]
     =*= "/home/pad/pfff"
    )
*)

let unix_diff_strings s1 s2 =
  let tmp1 = Common.new_temp_file "s1" "" in
  write_file tmp1 s1;
  let tmp2 = Common.new_temp_file "s2" "" in
  write_file tmp2 s2;
  unix_diff tmp1 tmp2

(*****************************************************************************)
(* Misc/test *)
(*****************************************************************************)

let (generic_print: 'a -> string -> string) = fun v typ ->
  write_value v "/tmp/generic_print";
  command2
   ("printf 'let (v:" ^ typ ^ ")= Common.get_value \"/tmp/generic_print\" " ^
     " in v;;' " ^
     " | calc.top > /tmp/result_generic_print");
   cat "/tmp/result_generic_print"
   |> drop_while (fun e -> not (e =~ "^#.*")) |> tail
   |> unlines
   |> (fun s ->
       if (s =~ ".*= \\(.+\\)")
       then matched1 s
       else "error in generic_print, not good format:" ^ s)

(* let main () = pr (generic_print [1;2;3;4] "int list") *)

class ['a] olist (ys: 'a list) =
  object(o)
    val xs = ys
    method view = xs
(*    method fold f a = List.fold_left f a xs *)
    method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b =
      fun f accu -> List.fold_left f accu xs
  end


(* let _ = write_value ((new setb[])#add 1) "/tmp/test" *)
let typing_sux_test () =
   let x = Obj.magic [1;2;3] in
   let f1 xs = List.iter print_int xs in
   let f2 xs = List.iter print_string xs in
   (f1 x; f2 x)

(* let (test: 'a osetb -> 'a ocollection) = fun o -> (o :> 'a ocollection) *)
(* let _ = test (new osetb (Setb.empty)) *)

(*e: common.ml *)