module LexingExt = struct

  open Lexing

  let new_line lexbuf = 
    lexbuf.lex_curr_p <- { 
      lexbuf.lex_curr_p with 
	pos_bol  = 0;
	pos_lnum = lexbuf.lex_curr_p.pos_lnum + 1
    }

  let lex_num s pos =
    let rec num i = 
	if s.[i] >= '0' && s.[i] <= '9' then
	  num (i + 1)
	else 
	  i
    in
    let pos' = num pos in
    if pos = pos' then 
      None
    else 
      Some (pos, pos', int_of_string (String.sub s pos (pos' - pos)))

end

module ListExt = struct

  let inv_assoc l = List.map (fun (x, y) -> (y, x)) l

  exception EmptyList

  let last l = try List.hd (List.rev l) with _ -> raise EmptyList

  let cut_last l = 
    let rec aux l = function
      | []      -> raise EmptyList
      | [ x ]   -> (x, List.rev l)
      | x :: xs -> aux (x :: l) xs
    in
    aux [] l

  let multi_set_of_list l = 
    let h = Hashtbl.create 13 in 
    let incr_occ x = 
      let o = try Hashtbl.find h x with Not_found -> 0 in
      Hashtbl.replace h x (o + 1)
    in
    List.iter incr_occ l;
    Hashtbl.fold (fun k v accu -> (k, v) :: accu) h []

  let hashtbl_of_assoc l = 
    let h = Hashtbl.create 13 in 
    List.iter (fun (k, v) -> Hashtbl.add h k v) l;
    h

  exception Conflict
  let assoc_union l1 l2 = 
    let h1 = hashtbl_of_assoc l1 in
    l1 
    @ List.filter 
      (fun (k, v1) -> 
	try 
	  let v2 = Hashtbl.find h1 k in
	  if v1 <> v2 then raise Conflict;
	  false
	with _ -> true) l2

  let assoc_diff l1 l2 = 
    let h1 = hashtbl_of_assoc l1 in
    let h2 = hashtbl_of_assoc l2 in
    let diff h1 h2 f = 
      Hashtbl.fold
	(fun k v1 accu -> 
	  let v2 = 
	    try Some (Hashtbl.find h2 k)
	    with Not_found -> None
	  in
	  if Some v1 <> v2 then 
	    if f then 
	      (k, (Some v1, v2)) :: accu
	    else 
	      (k, (v2, Some v1)) :: accu
	  else
	    accu)
	h1 []
    in
    let d1 = diff h1 h2 true in
    let d2 = diff h2 h1 false in
    try assoc_union d1 d2
    with Conflict -> assert false

  let transitive_forall2 p l = 
    let rec aux = function
      | []  -> None
      | [x] -> None
      | x1 :: ((x2 :: _) as xs) -> 
	if not (p x1 x2) then Some (x1, x2) else aux xs
    in
    aux l

  let repeat init n f = 
    let rec aux accu vs i = 
      if i = 0 then (accu, vs) else 
	let (accu, v) = f accu i in
	aux accu (v :: vs) (pred i) 
    in
    assert (n >= 0);
    aux init [] n

end

module ArgExt = struct

  let extra_doc s = "", Arg.Unit ignore, s

end

module SysExt = struct

  let safe_remove name =
    try Sys.remove name with Sys_error _ -> ()

  let rec alternative name = 
    let split name = 
      match LexingExt.lex_num name 0 with
	| None -> None
	| Some (start, stop, num) ->
	  let len = String.length name in
	  Some (num, String.sub name (stop+1) (len - stop - 1))
    in
    if not (Sys.file_exists name) then
      name
    else 
      let dirname = Filename.dirname name in
      let filename = Filename.basename name in
      let filename = 
	match split filename with
	  | None -> 
	    "01-" ^ filename
	  | Some (i, name) -> 
	    Printf.sprintf "%02d-%s" (i + 1) name
      in
      alternative (Filename.concat dirname filename)
      
end

module IOExt = struct

  let stdout_buffer    = Buffer.create 13
  let stdout_formatter = Format.formatter_of_buffer stdout_buffer
  let stderr_buffer    = Buffer.create 13
  let stderr_formatter = Format.formatter_of_buffer stderr_buffer
  let enable_buffering = ref false

  let printf fmt = 
    if !enable_buffering then 
      Format.fprintf stdout_formatter fmt
    else 
      Format.printf fmt

  let eprintf fmt = 
    if !enable_buffering then 
      Format.fprintf stderr_formatter fmt
    else 
      Format.eprintf fmt
    
  let get_buffers () = 
    let out = 
      (Buffer.contents stdout_buffer, Buffer.contents stderr_buffer)
    in
    Buffer.clear stdout_buffer;
    Buffer.clear stderr_buffer;
    out

  let set_buffered_mode () = 
    enable_buffering := true

end

module Timed = struct

  let time now print_date f = 
    fun x -> 
      let start_date = now () in
      let y = f x in 
      let stop_date = now () in
      print_date start_date stop_date;
      y

  let get_now = ref (fun () -> 0.)

  let set_now now = get_now := now

  let enable_profiling = ref false

  let set_profiling_flag t = enable_profiling := t

  let profile title f = 
    let print_date start stop = 
      IOExt.eprintf "[%05.0fms] %s\n" (stop -. start) title
    in
    if !enable_profiling then
      time !get_now print_date f
    else 
      f

end