module String =
struct
  include String

  let explode s sep =
    let len = length s in
    let buff = Buffer.create 40 in
    let rec loop i =
      if i >= len then
	[ Buffer.contents buff ]
      else
	let c = s.[i] in
	if c == sep then
	  let ss = Buffer.contents buff in
	  Buffer.clear buff;
	  ss :: loop (i+1)
	else begin
	  Buffer.add_char buff c;
	  loop (i+1);
	end
    in
    loop 0
end
;;

module System =
struct
  let status () =
    let pid = Unix.getpid() in
    let cin = open_in (Printf.sprintf "/proc/%i/status" pid) in
    let h = Hashtbl.create 17 in
    try
      while true do
        let s = input_line cin in
        Scanf.sscanf s "%s@: %s@\n" (fun k v ->
          Hashtbl.replace h k v)
      done;
      (* never reached *)
      h
    with
      End_of_file -> begin
        close_in cin;
        h
      end
  let get_status s = Hashtbl.find (status()) s

  let pr_mem_status fmt h =
    Format.fprintf fmt "[";
    List.iter (fun k ->
      let v = Hashtbl.find h k in
      Format.fprintf fmt "%s: %s " k v
    ) [ "VmStk"; "VmRSS"; "VmPeak" ];
    Format.fprintf fmt "]"

end

module Timing =
  struct
    let _timings = Hashtbl.create 43
    let _t_queue = Queue.create ()

    let get_timing s =
      try
        Hashtbl.find _timings s
      with
        Not_found -> []

    let set_timing s v =
      Hashtbl.replace _timings s v


    let display_result fmt msg sub l =
      let h = Hashtbl.create 0 in
      let tmin, tmax, ttotal, len, memo, memn =
        List.fold_left (fun
        (atmin, atmax, attotal, alen, _, _)
        (t, om, nm) ->
          (min t atmin,
           max atmax t,
           attotal +. t,
           alen + 1,
           om, nm))
          (infinity, 0., 0., 0, h, h) l
      in
      Logger.start_msg fmt "[Stats] ";
      Logger.msg fmt "%s %s:@\n    @[<v 0>[" sub msg;
      begin
        if len <= 1 then
        Logger.msg fmt
          "@\n\
| Time:           %fms@\n"
          tmin
      else
        Logger.msg fmt
          "@\n\
| Number of runs: %i@\n\
| Average time:   %fms@\n\
| Minimum time:   %fms@\n\
| Maximum time:   %fms@\n"
          len
          (ttotal /. (float_of_int len))
          tmin
          tmax

      end;
      Logger.msg fmt
"| Memory before:  %a@\n\
| Memory after:   %a@\n]@]"
        System.pr_mem_status memo
        System.pr_mem_status memn;
      Logger.end_msg fmt "\n\n"


let time f ?(count=1) ?(msg="") x =
  if not !Config.verbose then f x
  else
  let rec loop i =
    let oldmem = System.status () in
    let t1 = Unix.gettimeofday () in
    set_timing msg ((t1, oldmem, oldmem)::(get_timing msg));
    let r = f x in
    let t2 = Unix.gettimeofday () in
    let newmem = System.status () in
    let t1, oldmem, l =
      match get_timing msg with
        (a, b, _) :: l -> a,b,l
      | _ -> assert false
    in
    let t = (1000. *. (t2 -. t1)) in
    set_timing msg ((t, oldmem, newmem)::l);
    if i >= count then r
    else loop (i+1)
  in
  Queue.push msg _t_queue;
  let r = loop 1 in
  begin
    if (Queue.peek _t_queue) = msg then
    let pr_stack = Queue.fold (fun a e -> e::a)  [] _t_queue in
    Queue.clear _t_queue;
    List.iter (fun msg' ->
      let sub =
        if msg' <> msg then "+" else "="
      in
      display_result Format.err_formatter msg' sub (get_timing msg')) pr_stack;
  end;
  r


  end
let time = Timing.time