Source

ocaml-lib / common.ml

Sébastien Ferré cc1f59c 

Sébastien Ferré c4d35a4 
Sébastien Ferré 7c44fa1 
Sébastien Ferré 197256e 


Sébastien Ferré 4dd3368 






Sébastien Ferré 7c3e360 
Sébastien Ferré 4dd3368 
















Sébastien Ferré b2b2e5f 













Sébastien Ferré c7e1b2e 









Sébastien Ferré 197256e 




Sébastien Ferré c7e1b2e 




Sébastien Ferré cc1f59c 





Sébastien Ferré 06460f4 







Sébastien Ferré b2b2e5f 






Sébastien Ferré 82645ae 





Sébastien Ferré 2798b01 
Sébastien Ferré 6ea40b6 









Sébastien Ferré 99a257d 





Sébastien Ferré e7c7cb3 















Sébastien Ferré c4d35a4 




Sébastien Ferré 7c44fa1 








Sébastien Ferré 197256e 














Sébastien Ferré 2798b01 










Sébastien Ferré c7e1b2e 





Sébastien Ferré 2798b01 













Sébastien Ferré 197256e 













Sébastien Ferré 06460f4 


































Sébastien Ferré 197256e 
Sébastien Ferré c4d35a4 








Sébastien Ferré 2798b01 
Sébastien Ferré 6ea40b6 






Sébastien Ferré 2798b01 

Sébastien Ferré 06460f4 

Sébastien Ferré 2798b01 

Sébastien Ferré cc1f59c 
Sébastien Ferré 06460f4 






Sébastien Ferré 7c44fa1 
Sébastien Ferré 06460f4 
Sébastien Ferré 7c44fa1 
Sébastien Ferré 6ea40b6 
Sébastien Ferré 7c44fa1 
Sébastien Ferré 06460f4 



Sébastien Ferré 7c44fa1 
Sébastien Ferré 2798b01 
Sébastien Ferré 7c44fa1 
Sébastien Ferré c4d35a4 















Sébastien Ferré cc1f59c 



Sébastien Ferré 197256e 
Sébastien Ferré cc1f59c 



Sébastien Ferré 197256e 

Sébastien Ferré 6ea40b6 

Sébastien Ferré 197256e 
Sébastien Ferré 6ea40b6 























Sébastien Ferré 197256e 
Sébastien Ferré 7c44fa1 























Sébastien Ferré bbf4380 



Sébastien Ferré 7c44fa1 




Sébastien Ferré cc1f59c 









Sébastien Ferré c7e1b2e 



Sébastien Ferré cc1f59c 

Sébastien Ferré c7e1b2e 


Sébastien Ferré cc1f59c 



Sébastien Ferré c7e1b2e 





Sébastien Ferré cc1f59c 
(** 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.