Source

ocaml-lib / common.ml

(** Common utility functions. *)

(* space *)

let heap_size () : float = float_of_int (Gc.quick_stat ()).Gc.heap_words *. float_of_int (Sys.word_size / 8)  (* in bytes *)

let live_words () : float = float_of_int (Gc.stat ()).Gc.live_words *. float_of_int (Sys.word_size / 8)  (* in bytes *)

(* extensions a Weak *)

let weak_get_index : 'a Weak.t ref -> int =
  fun w ->
    let l = Weak.length !w in
    let i = ref 0 in
    while !i < l & Weak.check !w !i do incr i done;
    if !i >= l then begin
      let ar = Weak.create (l + 10)
      in Weak.blit !w 0 ar 0 l; w := ar end;
    !i

let weak_add : 'a Weak.t ref -> 'a -> unit =
  fun w x ->
    let i = weak_get_index w in
    Weak.set !w i (Some x)
      
let weak_iter : 'a Weak.t -> ('a -> unit) -> unit =
  fun w f ->
    for i=0 to Weak.length w - 1 do
      match Weak.get w i with
	None -> ()
      | Some x -> f x
    done

let list_of_weak : 'a Weak.t -> 'a list =
  fun w ->
    let res = ref [] in
    for i=0 to Weak.length w - 1 do
      match Weak.get w i with
	None -> ()
      |	Some x -> res := x::!res
    done;
    !res

(* List functionals *)
(* ---------------- *)

let iter_option : ('a -> unit) -> 'a option -> unit =
  fun f -> function
    | None -> ()
    | Some x -> f x

let fold_option : ('a -> 'b) -> 'b -> 'a option -> 'b =
  fun f e -> function
    | None -> e
    | Some x -> f x

let flat_option : 'a -> 'a option -> 'a =
  fun e -> function
    | None -> e
    | Some x -> x

let map_option : ('a -> 'b) -> 'a option -> 'b option =
  fun f -> function
    | None -> None
    | Some x -> Some (f x)

let rec filter : 'a option list -> 'a list =
  function
    | [] -> []
    | None::l -> filter l
    | Some x::l -> x::filter l

let rec remove_first : 'a -> 'a list -> 'a list =
  fun e -> function
    | [] -> []
    | x::l ->
	if x = e
	then l
	else x::remove_first e l

let rec mapfilter : ('a -> 'b option) -> 'a list -> 'b list =
  fun f -> function
      [] -> []
    | x::l -> match f x with
	None -> mapfilter f l
      |	Some y -> y::mapfilter f l

let rec mapfind : ('a -> 'b option) -> 'a list -> 'b =
  fun f -> function
  | [] -> raise Not_found
  | x::l -> match f x with
      | None -> mapfind f l
      | Some y -> y

let rec mapfind_right : ('a -> 'b option) -> 'a list -> 'b =
  fun f -> function
    | [] -> raise Not_found
    | x::l ->
	try mapfind_right f l
	with Not_found ->
	  match f x with
	  | None -> raise Not_found
	  | Some y -> y

let rec fold_while : ('a -> 'a option) -> 'a -> 'a =
  fun f e ->
    match f e with
    | None -> e
    | Some e' -> fold_while f e'

let fold_for : (int -> 'a -> 'a) -> int -> int -> 'a -> 'a =
  fun f a b e ->
    let res = ref e in
    for x = a to b do
      res := f x !res
    done;
    !res

let fold_for_down : (int -> 'a -> 'a) -> int -> int -> 'a -> 'a =
  fun f a b e ->
    let res = ref e in
    for x = a downto b do
      res := f x !res
    done;
    !res

let rec fold_in_channel : ('b -> string -> 'b) -> 'b -> in_channel -> 'b =
  fun f e ch ->
    try fold_in_channel f (f e (input_line ch)) ch
    with End_of_file -> e

let rec insert : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list =
  fun order x ->
    function
    | [] -> [x]
    | y::ys ->
       if order x y
       then x::y::ys
       else y::insert order x ys

let rec insert_max : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list =
  fun order x ->
    function
      | [] -> [x]
      | y::ys ->
	  if order x y then y::ys
	  else if order y x then insert_max order x ys
	  else y::insert_max order x ys

let rec merge_max : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list =
  fun order l1 l2 ->
    List.fold_left
      (fun res x2 -> insert_max order x2 res)
      l1 l2

(* fold on all ordered pairs of a list *)
let rec fold_pair : ('a -> 'a -> 'b -> 'b) -> 'a list -> 'b -> 'b =
  fun f l e ->
    match l with
    | [] -> e
    | x1::xs ->
       List.fold_right
         (fun x2 res -> f x1 x2 res)
         xs
         (fold_pair f xs e)

let compare_pair : ('a -> 'a -> int) * ('b -> 'b -> int) -> 'a * 'b -> 'a * 'b -> int =
  fun (comp1,comp2) (a1,a2) (b1,b2) ->
    match comp1 a1 b1 with
    | 0 -> comp2 a2 b2
    | c1 -> c1

let rec scramble : 'a list -> 'a list =
  function
  | [] -> []
  | x::l ->
     let l' = scramble l in
     if Random.int 2 = 0
     then x::l'
     else l'@[x]

let rec scrambles : 'a list -> int -> 'a list =
  fun l -> function
  | 0 -> l
  | n -> scrambles (scramble l) (n-1)

let rec sub_list l pos len =
  if pos = 0
  then
    if len = 0
    then []
    else
      match l with
      | [] -> []
      | x::xs -> x::sub_list xs 0 (len-1)
  else
    match l with
    | [] -> []
    | x::xs -> sub_list xs (pos-1) len

let rec list_set_nth l n x =
  match l with
  | [] -> invalid_arg "Common.list_set_nth"
  | e::l' ->
      if n = 0
      then x::l'
      else e::list_set_nth l' (n-1) x

let rec list_insert_nth l n l1 =
  match l with
  | [] -> invalid_arg "Common.list_insert_nth"
  | e::l' ->
      if n = 0
      then l1 @ l'
      else e :: list_insert_nth l' (n-1) l1

let rec list_remove_nth l n =
  match l with
  | [] -> invalid_arg "Common.list_remove_nth"
  | e::l' ->
      if n = 0
      then l'
      else e::list_remove_nth l' (n-1)

let list_n n =
  let aux i acc =
    if i = 0
    then acc
    else aux (i-1) ((i-1)::acc)
  in
  aux n []

let rec list_index i = function
  | [] -> []
  | x::l -> (i,x)::list_index (i+1) l

(* utilities on streams *)

let rec stream_map f = parser
  | [<'x; str>] -> [<'f x; stream_map f str>]
  | [<>] -> [<>]

(* time *)

let utime () : float = (Unix.times ()).Unix.tms_utime (* in seconds *)

let chrono (f : unit -> 'a) : float * 'a =
  let t1 = utime () in
  let res = f () in
  let t2 = utime () in
  t2 -. t1, res


(* for profiling *)

type prof_elem = {mutable prof_on : bool; mutable prof_nb : int; mutable prof_time : float; mutable prof_mem : float}
let tbl_prof : (string, prof_elem) Hashtbl.t = Hashtbl.create 100

let prof : string -> (unit -> 'a) -> 'a =
  fun s f -> (* f () *)
    let elem =
      try Hashtbl.find tbl_prof s
      with Not_found ->
	let elem = {prof_on = false; prof_nb = 0; prof_time = 0.; prof_mem = 0.} in
	Hashtbl.add tbl_prof s elem;
	elem in
    let on = elem.prof_on in
(* print_string ("<"^s^":"); flush stdout; *)
    elem.prof_on <- true;
    let m1 = Gc.allocated_bytes () (* float_of_int (Gc.stat ()).Gc.live_words *) in
    let d, y = chrono f in
    let m2 = Gc.allocated_bytes () (* float_of_int (Gc.stat ()).Gc.live_words *) in
    elem.prof_on <- on;
    elem.prof_nb <- elem.prof_nb + 1;
    if not on then elem.prof_time <- elem.prof_time +. d;
    if not on then elem.prof_mem <- elem.prof_mem +. (m2 -. m1);
(* print_string (s^">\n"); flush stdout; *)
    y

(* utilities on files *)

(* found at http://pauillac.inria.fr/~remy/poly/system/camlunix/fich.html#toc13 *)
let file_copy input_name output_name =
  let buffer_size = 8192 in
  let buffer = String.create buffer_size in
  let fd_in = Unix.openfile input_name [Unix.O_RDONLY] 0 in
  let fd_out = Unix.openfile output_name [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o666 in
  let rec copy_loop () =
    match Unix.read fd_in buffer 0 buffer_size with
    | 0 -> ()
    | r -> ignore (Unix.write fd_out buffer 0 r); copy_loop () in
  copy_loop ();
  Unix.close fd_in;
  Unix.close fd_out

let string_of_file (filename : string) : string =
  let ch = open_in filename in
  let buf = Buffer.create 10000 in
  fold_in_channel
    (fun () line -> Buffer.add_string buf line; Buffer.add_char buf '\n')
    () ch;
  close_in ch;
  Buffer.contents buf

(* safe rewrite of a file *)
let safe_file_update path f =
  let path_tmp = Filename.concat (Filename.dirname path) ("tmp_" ^ Filename.basename path) in
  f path_tmp;
  (try Sys.remove path with _ -> ());
  Sys.rename path_tmp path

(*
let pipe_command (cmd : string) (f : in_channel -> 'a) : 'a =
  let path = Filename.temp_file "cmd" ".txt" in
  let code = Sys.command (cmd ^ " > " ^ path) in
  if code <> 0
  then raise (Sys_error ("error while executing: " ^ cmd))
  else begin
    let ch = open_in path in
    let res = f ch in
    close_in ch;
    Sys.remove path;
    res
  end
*)

let pipe_command (cmd : string) (f : in_channel -> 'a) : 'a =
  let ch = Unix.open_process_in cmd in
  let res = f ch in
  let status = Unix.close_process_in ch in
  if status = Unix.WEXITED 0
  then res
  else raise (Sys_error ("Common.pipe_command: error while executing: " ^ cmd))

(* probabilities *)

open Num

let comb_tbl : (int*int,num) Hashtbl.t = Hashtbl.create 10000
let rec comb (k,n) =
  if k > n or n < 0 then Int 0
  else if k = n or k = 0 then Int 1
  else if k > n / 2 then comb (n-k,n)
  else
    try Hashtbl.find comb_tbl (k,n)
    with Not_found ->
      let res = comb (k,n-1) +/ comb (k-1,n-1) in
      Hashtbl.add comb_tbl (k,n) res;
      res

let chance_eq_num (r,w) (k,n) =
  comb (k,r) */ comb (n-k,w-r) // comb (n,w)

let chance_eq (r,w) (k,n) = prof "chance_eq" (fun () ->
  float_of_num (chance_eq_num (r,w) (k,n)))

let chance_ge_num (r,w) (k,n) =
  let res = ref (Int 0) in
  for tp = k to r do
    for fp = n-k downto 0 do
      res := !res +/ chance_eq_num (r,w) (tp,tp+fp)
    done
  done;
  !res

let chance_ge (r,w) (k,n) = prof "chance_ge" (fun () ->
  float_of_num (chance_ge_num (r,w) (k,n)))

(* external applications *)

let xemacs filename pattern =
  ignore (Sys.command ("xemacs -eval '(progn (find-file \""^filename^"\") (search-forward \"" ^ pattern ^ "\"))' &"))

let mozilla url =
  ignore (Sys.command ("mozilla -remote \"openurl(" ^ url ^ ")\""))
    
let gqview filename =
  ignore (Sys.command ("gqview \"" ^ String.escaped filename ^ "\" &"))

let xmms filename =
  ignore (Sys.command ("xmms \"" ^ String.escaped filename ^ "\" &"))

let cyg2win path = (* convert a Cygwin path to a Windows path *)
  match Str.split (Str.regexp "/") path with
  | "cygdrive"::drive::l -> String.uppercase drive ^ ":\\" ^ String.concat "\\" l
  | l -> "C:\\cygwin\\" ^ String.concat "\\" l

let acdsee_cygwin filename =
  ignore (Sys.command ("/cygdrive/c/Program\\ Files/ACD\\ Systems/ACDSee\\ Trial\\ Version/ACDSee.exe /v \"" ^ cyg2win filename ^ "\" &"))

let irfanview_cygwin filename =
  ignore (Sys.command ("/cygdrive/c/Program\\ Files/IrfanView/i_view32.exe \"" ^ cyg2win filename ^ "\" &"))

let irfanslideshow_cygwin filename =
  ignore (Sys.command ("/cygdrive/c/Program\\ Files/IrfanView/i_view32.exe /slideshow=\"" ^ cyg2win filename ^ "\" &"))

let winamp_cygwin filename =
   ignore (Sys.command ("/cygdrive/c/Program\\ Files/Winamp/winamp.exe \"" ^ cyg2win filename ^ "\" &"))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.