(* Yoann Padioleau
*
+ * Copyright (C) 2010 INRIA, University of Copenhagen DIKU
* 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
* functions depends on other functions from this common, it would
* be tedious to add those dependencies. Here simpler (have just the
* pb of the Prelude, but it's a small problem).
- *
+ *
* pixel means code from Pascal Rigaux
* julia means code from Julia Lawall
*)
(*****************************************************************************)
(* We use *)
(*****************************************************************************)
-(*
+(*
* modules:
* - Pervasives, of course
* - List
* - Str
* - Hashtbl
- * - Format
+ * - Format
* - Buffer
* - Unix and Sys
* - Arg
- *
- * functions:
- * - =, <=, max min, abs, ...
+ *
+ * functions:
+ * - =, <=, max min, abs, ...
* - List.rev, List.mem, List.partition,
- * - List.fold*, List.concat, ...
+ * - List.fold*, List.concat, ...
* - Str.global_replace
* - Filename.is_relative
* - String.uppercase, String.lowercase
- *
- *
+ *
+ *
* The Format library allows to hide passing an indent_level variable.
* You use as usual the print_string function except that there is
* this automatic indent_level variable handled for you (and maybe
* more services). src: julia in coccinelle unparse_cocci.
- *
- * Extra packages
+ *
+ * Extra packages
* - ocamlbdb
* - ocamlgtk, and gtksourceview
* - ocamlgl
* - ocamlfuse
* - ocamlmpi
* - ocamlcalendar
- *
+ *
* - pcre
* - sdl
- *
+ *
* Many functions in this file were inspired by Haskell or Lisp librairies.
*)
let (++) = (@)
exception Timeout
-exception UnixExit of int
+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 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
+ | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs
in fold_lwi_aux acc 0
-let rec drop n xs =
+let rec drop n xs =
match (n,xs) with
| (0,_) -> xs
| (_,[]) -> failwith "drop: not enough"
let rec enum_orig x n = if x = n then [n] else x::enum_orig (x+1) n
-let enum x 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
+ 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 rec take n xs =
+let rec take n xs =
match (n,xs) with
| (0,_) -> []
| (_,[]) -> failwith "take: not enough"
"" -> []
| s -> (enum 0 ((String.length s) - 1) +> List.map (String.get s))
-let (lines: string -> string list) = fun 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
+ | [x] -> if x = "" then [] else [x]
+ | x::xs ->
+ x::lines_aux xs
in
Str.split_delim (Str.regexp "\n") s +> lines_aux
-let debugger = ref false
+let debugger = ref false
let unwind_protect f cleanup =
- if !debugger then f() else
+ if !debugger then f() else
try f ()
with e -> begin cleanup e; raise e end
-let finalize f cleanup =
- if !debugger then f() else
- try
+let finalize f cleanup =
+ if !debugger then f() else
+ try
let res = f () in
cleanup ();
res
- with e ->
+ with e ->
cleanup ();
raise e
let command2 s = ignore(Sys.command s)
-let (matched: int -> string -> string) = fun i s ->
+let (matched: int -> string -> string) = fun i s ->
Str.matched_group i s
let matched1 = fun s -> matched 1 s
(* Debugging/logging *)
(*****************************************************************************)
-(* I used this in coccinelle where the huge logging of stuff ask for
+(* 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
+ *
+ * todo? could maybe use log4j instead ? or use Format module more
* consistently ?
*)
let _prefix_pr = ref ""
-let indent_do f =
+let indent_do f =
_tab_level_print := !_tab_level_print + _tab_indent;
- finalize f
+ finalize f
(fun () -> _tab_level_print := !_tab_level_print - _tab_indent;)
-let pr s =
+let pr s =
print_string !_prefix_pr;
do_n !_tab_level_print (fun () -> print_string " ");
print_string s;
- print_string "\n";
+ print_string "\n";
flush stdout
-let pr_no_nl s =
+let pr_no_nl s =
print_string !_prefix_pr;
do_n !_tab_level_print (fun () -> print_string " ");
print_string s;
let _chan_pr2 = ref (None: out_channel option)
-let out_chan_pr2 ?(newline=true) s =
+let out_chan_pr2 ?(newline=true) s =
match !_chan_pr2 with
| None -> ()
- | Some chan ->
- output_string chan (s ^ (if newline then "\n" else ""));
+ | Some chan ->
+ output_string chan (s ^ (if newline then "\n" else ""));
flush chan
+let print_to_stderr = ref true
-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 s =
+ if !print_to_stderr
+ then
+ begin
+ prerr_string !_prefix_pr;
+ do_n !_tab_level_print (fun () -> prerr_string " ");
+ prerr_string s;
+ prerr_string "\n";
+ flush stderr;
+ out_chan_pr2 s;
+ ()
+ end
-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 pr2_no_nl s =
+ if !print_to_stderr
+ then
+ begin
+ prerr_string !_prefix_pr;
+ do_n !_tab_level_print (fun () -> prerr_string " ");
+ prerr_string s;
+ flush stderr;
+ out_chan_pr2 ~newline:false s;
+ ()
+ end
-let pr_xxxxxxxxxxxxxxxxx () =
+let pr_xxxxxxxxxxxxxxxxx () =
pr "-----------------------------------------------------------------------"
-let pr2_xxxxxxxxxxxxxxxxx () =
+let pr2_xxxxxxxxxxxxxxxxx () =
pr2 "-----------------------------------------------------------------------"
let reset_pr_indent () =
_tab_level_print := 0
-(* old:
+(* old:
* let pr s = (print_string s; print_string "\n"; flush stdout)
- * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr)
+ * 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
+(* 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
+ *
+ * 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.
(* 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
+ * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp
*)
open Printf
open Obj
let _already_printed = Hashtbl.create 101
-let disable_pr2_once = ref false
+let disable_pr2_once = ref false
-let xxx_once f s =
+let xxx_once f s =
if !disable_pr2_once then pr2 s
- else
+ else
if not (Hashtbl.mem _already_printed s)
then begin
Hashtbl.add _already_printed s true;
let pr2_once s = xxx_once pr2 s
(* ---------------------------------------------------------------------- *)
-let mk_pr2_wrappers aref =
- let fpr2 s =
+let mk_pr2_wrappers aref =
+ let fpr2 s =
if !aref
then pr2 s
- else
+ else
(* just to the log file *)
out_chan_pr2 s
in
- let fpr2_once s =
+ let fpr2_once s =
if !aref
then pr2_once s
- else
+ else
xxx_once out_chan_pr2 s
in
- fpr2, fpr2_once
-
+ fpr2, fpr2_once
(* ---------------------------------------------------------------------- *)
(* could also be in File section *)
-let redirect_stdout_stderr file f =
+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
close_out chan;
end
-let redirect_stdin file f =
+let redirect_stdin file f =
begin
let chan = open_in file in
let descr = Unix.descr_of_in_channel chan in
close_in chan;
end
-let redirect_stdin_opt optfile f =
+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 =
+(* cf end
+let with_pr2_to_string f =
*)
-
+
(* ---------------------------------------------------------------------- *)
* val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
*)
-(* ex of printf:
+(* ex of printf:
* printf "%02d" i
* for padding
*)
(* ---------------------------------------------------------------------- *)
let _chan = ref stderr
-let start_log_file () =
+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
(* src: from getopt from frish *)
let bip () = Printf.printf "\007"; flush stdout
-let wait () = Unix.sleep 1
+let wait () = Unix.sleep 1
(* was used by fix_caml *)
let _trace_var = ref 0
let dec_var() = decr _trace_var
let get_var() = !_trace_var
-let (print_n: int -> string -> unit) = fun i s ->
+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 ->
+let (printerr_n: int -> string -> unit) = fun i s ->
do_n i (fun () -> prerr_string s)
let _debug = ref true
(* now in prelude:
- * let debugger = ref false
+ * let debugger = ref false
*)
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 () =
+let timenow () =
"sys:" ^ (string_of_float (Sys.time ())) ^ " seconds" ^
- ":real:" ^
+ ":real:" ^
(let tm = Unix.time () +> Unix.gmtime in
- tm.Unix.tm_min +> string_of_int ^ " min:" ^
+ 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 = 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 count4 () = incr _count4
let count5 () = incr _count5
-let profile_diagnostic_basic () =
- Printf.sprintf
- "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n"
+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 time_func f =
(* let _ = Timing () in *)
let x = f () in
(* let _ = Timing () in *)
let _profile_table = ref (Hashtbl.create 100)
let adjust_profile_entry category difftime =
- let (xtime, xcount) =
+ let (xtime, xcount) =
(try Hashtbl.find !_profile_table category
- with Not_found ->
+ with Not_found ->
let xtime = ref 0.0 in
let xcount = ref 0 in
Hashtbl.add !_profile_table category (xtime, xcount);
(* subtil: don't forget to give all argumens to f, otherwise partial app
* and will profile nothing.
- *
+ *
* todo: try also detect when complexity augment each time, so can
- * detect the situation for a function gets worse and worse ?
- *)
-let profile_code category f =
+ * detect the situation for a function gets worse and worse ?
+ *)
+let profile_code category f =
if not (check_profile category)
- then f()
+ then f()
else begin
if !show_trace_profile then pr2 (spf "p: %s" category);
let t = Unix.gettimeofday () in
- let res, prefix =
+ let res, prefix =
try Some (f ()), ""
with Timeout -> None, "*"
in
end
-let _is_in_exclusif = ref (None: string option)
+let _is_in_exclusif = ref (None: string option)
-let profile_code_exclusif category f =
+let profile_code_exclusif category f =
if not (check_profile category)
- then f()
+ then f()
else begin
match !_is_in_exclusif with
- | Some s ->
+ | Some s ->
failwith (spf "profile_code_exclusif: %s but already in %s " category s);
- | None ->
+ | None ->
_is_in_exclusif := (Some category);
- finalize
- (fun () ->
+ finalize
+ (fun () ->
profile_code category f
- )
- (fun () ->
+ )
+ (fun () ->
_is_in_exclusif := None
)
end
-let profile_code_inside_exclusif_ok category f =
+let profile_code_inside_exclusif_ok category f =
failwith "Todo"
(* todo: also put % ? also add % to see if coherent numbers *)
-let profile_diagnostic () =
+let profile_diagnostic () =
if !profile = PNONE then "" else
- let xs =
- Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table []
+ let xs =
+ Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table []
+> List.sort (fun (k1, (t1,n1)) (k2, (t2,n2)) -> compare t2 t1)
in
- with_open_stringbuf (fun (pr,_) ->
+ with_open_stringbuf (fun (pr,_) ->
pr "---------------------";
pr "profiling result";
pr "---------------------";
- xs +> List.iter (fun (k, (t,n)) ->
+ xs +> List.iter (fun (k, (t,n)) ->
pr (sprintf "%-40s : %10.3f sec %10d count" k !t !n)
)
)
-let report_if_take_time timethreshold s f =
+let report_if_take_time timethreshold s f =
let t = Unix.gettimeofday () in
let res = f () in
let t' = Unix.gettimeofday () in
- if (t' -. t > float_of_int timethreshold)
- then pr2 (sprintf "NOTE: this code takes more than: %ds %s" timethreshold s);
+ if (t' -. t > float_of_int timethreshold)
+ then pr2 (sprintf "Note: processing took %7.1fs: %s" (t' -. t) s);
res
-let profile_code2 category f =
- profile_code category (fun () ->
+let profile_code2 category f =
+ profile_code category (fun () ->
if !profile = PALL
then pr2 ("starting: " ^ category);
let t = Unix.gettimeofday () in
then pr2 (spf "ending: %s, %fs" category (t' -. t));
res
)
-
+
(*****************************************************************************)
(* Test *)
let _ex1 = example (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" ^
+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 ->
+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 ->
+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 ->
+ * 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) ->
+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
+let (test: string -> unit) = fun s ->
+ Printf.printf "%s: %s\n" s
(if (List.assoc s (!_list_bool)) then "passed" else "failed")
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
+(* cf end of file. It uses too many other common functions so I
* have put the code at the end of this file.
*)
ok_ref := 0;
bug_ref := 0
-let test x s =
+let test x s =
if x then ok () else begin Printf.printf "%s\n" s; bug () end;;
let test_exn x s =
(* Better than quickcheck, cos cant do a test_all_prop in haskell cos
* prop were functions, whereas here we have not prop_Unix x = ... but
- * laws "unit" ...
+ * laws "unit" ...
*
* How to do without overloading ? objet ? can pass a generator as a
* parameter, mais lourd, prefer automatic inferring of the
* generator? But at the same time quickcheck does not do better cos
- * we must explictly type the property. So between a
- * prop_unit:: [Int] -> [Int] -> bool ...
- * prop_unit x = reverse [x] == [x]
- * and
- * let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg)
- * there is no real differences.
+ * we must explictly type the property. So between a
+ * prop_unit:: [Int] -> [Int] -> bool ...
+ * prop_unit x = reverse [x] == [x]
+ * and
+ * let _ = laws "unit" (fun x -> reverse [x] = [x]) (listg intg)
+ * there is no real differences.
*
* Yes I define typeg generator but quickcheck too, he must define
* class instance. I emulate the context Gen a => Gen [a] by making
* listg take as a param a type generator. Moreover I have not the pb of
- * monad. I can do random independently, so my code is more simple
+ * monad. I can do random independently, so my code is more simple
* I think than the haskell code of quickcheck.
- *
+ *
* update: apparently Jane Street have copied some of my code for their
* Ounit_util.ml and quichcheck.ml in their Core library :)
*)
let (ig: int gen) = fun () ->
Random.int 10
-let (lg: ('a gen) -> ('a list) gen) = fun gen () ->
+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 () ->
+let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () ->
(gen1 (), gen2 ())
let polyg = ig
-let (ng: (string gen)) = fun () ->
+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: ('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 (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 (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"
+ 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] ()
*)
* 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 =
+ *
+ * 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
- *
+ *
*)
(*---------------------------------------------------------------------------*)
(* 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
- *
+ * 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
+ *
+ * todo classify, collect, forall
*)
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 ))) =
+ 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 b = laws "appb" (fun (xs,ys) -> reverse (xs++ys) = reverse xs++reverse ys)(pg (lg ig)(lg ig))
let b = laws "max" (fun (x,y) -> x <= y ==> (max x y = y) )(pg ig ig)
-let b = laws2 "max" (fun (x,y) -> ((x <= y ==> (max x y = y)), x <= y))(pg ig ig)
+let b = laws2 "max" (fun (x,y) -> ((x <= y ==> (max x y = y)), x <= y))(pg ig ig)
*)
*)
(*
-let one_of xs = List.nth xs (Random.int (List.length xs))
+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
+ 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 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 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)
+ close_out chan)
-let write_back func filename =
+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 =
+let marshal__to_string2 v flags =
Marshal.to_string v flags
-let marshal__to_string a b =
+let marshal__to_string a b =
profile_code "Marshalling" (fun () -> marshal__to_string2 a b)
-let marshal__from_string2 v flags =
+let marshal__from_string2 v flags =
Marshal.from_string v flags
-let marshal__from_string a b =
+let marshal__from_string a b =
profile_code "Marshalling" (fun () -> marshal__from_string2 a b)
(* To work with the macro system autogenerated string_of and print_ function
(kind of deriving a la haskell) *)
-(* int, bool, char, float, ref ?, string *)
+(* int, bool, char, float, ref ?, string *)
let string_of_string s = "\"" ^ s "\""
-let string_of_list f xs =
+let string_of_list f xs =
"[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]"
let string_of_unit () = "()"
| None -> print_string "None"
| Some x -> print_string "Some ("; pr x; print_string ")"
-let print_list pr xs =
+let print_list pr xs =
begin
- print_string "[";
- List.iter (fun x -> pr x; print_string ",") xs;
+ print_string "[";
+ List.iter (fun x -> pr x; print_string ",") xs;
print_string "]";
end
-(* specialised
-let (string_of_list: char list -> string) =
+(* specialised
+let (string_of_list: char list -> string) =
List.fold_left (fun acc x -> acc^(Char.escaped x)) ""
*)
-let adjust_pp_with_indent f =
- Format.open_box !_tab_level_print;
+let adjust_pp_with_indent f =
+ Format.open_box !_tab_level_print;
(*Format.force_newline();*)
- f();
+ 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);
+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();
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
+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
-let mk_str_func_of_assoc_conv xs =
+let mk_str_func_of_assoc_conv xs =
let swap (x,y) = (y,x) in
- (fun s ->
+ (fun s ->
let xs' = List.map swap xs in
List.assoc s xs'
),
- (fun a ->
+ (fun a ->
List.assoc a xs
)
(*****************************************************************************)
(* put your macro in macro.ml4, and you can test it interactivly as in lisp *)
-let macro_expand s =
+let macro_expand s =
let c = open_out "/tmp/ttttt.ml" in
begin
output_string c s; close_out c;
let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)"
*)
-
+
(*****************************************************************************)
(* Composition/Control *)
(*****************************************************************************)
(* I like the obj.func object notation. In OCaml cant use '.' so I use +>
- *
+ *
* update: it seems that F# agrees with me :) but they use |>
*)
(* now in prelude:
* let (+>) o f = f o
*)
-let (+!>) refo f = refo := f !refo
-(* alternatives:
+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 o f g x = f (g x)
*)
let ($) f g x = g (f x)
by Keisuke Nakano on the caml mailing list.
> let ( /* ) x y = y x
> and ( */ ) x y = x y
-or
+or
let ( <| ) x y = y x
and ( |> ) x y = x y
let rec applyn n f o = if n = 0 then o else applyn (n-1) f (f o)
-let forever f =
+let forever f =
while true do
f();
done
-class ['a] shared_variable_hook (x:'a) =
+class ['a] shared_variable_hook (x:'a) =
object(self)
val mutable data = x
val mutable registered = []
- method set x =
+ method set x =
begin
data <- x;
pr "refresh registered";
end
method get = data
method modify f = self#set (f self#get)
- method register f =
- registered <- f :: registered
- end
+ 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)
+ if (image = elem)
then elem (* point fixe *)
else fixpoint trans image
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) =
+let (add_hook: ('a -> ('a -> 'b) -> 'b) ref -> ('a -> ('a -> 'b) -> 'b) -> unit) =
fun var f ->
- let oldvar = !var in
+ 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 ->
+let (add_hook_action: ('a -> unit) -> ('a -> unit) list ref -> unit) =
+ fun f hooks ->
push2 f hooks
-let (run_hooks_action: 'a -> ('a -> unit) list ref -> unit) =
- fun obj 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 *)
-let save_excursion reference f =
+let save_excursion reference f =
let old = !reference in
- let res = f() in
+ let res = try f() with e -> reference := old; raise e in
reference := old;
res
-let save_excursion_and_disable reference f =
- save_excursion reference (fun () ->
+let save_excursion_and_disable reference f =
+ save_excursion reference (fun () ->
reference := false;
f ()
)
-let save_excursion_and_enable reference f =
- save_excursion reference (fun () ->
+let save_excursion_and_enable reference f =
+ save_excursion reference (fun () ->
reference := true;
f ()
)
-let memoized h k f =
- try Hashtbl.find h k
- with Not_found ->
+let memoized h k f =
+ 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 =
+let cache_in_ref myref f =
match !myref with
| Some e -> e
- | None ->
+ | None ->
let e = f () in
myref := Some e;
e
-let once f =
+let once f =
let already = ref false in
- (fun x ->
+ (fun x ->
if not !already
then begin already := true; f x end
)
(* cache_file, cf below *)
-let before_leaving f x =
+let before_leaving f x =
f x;
x
(*****************************************************************************)
(* 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
* 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.
*)
-exception FileAlreadyLocked
+exception FileAlreadyLocked
(* Racy if lock file on NFS!!! But still racy with recent Linux ? *)
-let acquire_file_lock filename =
+let acquire_file_lock filename =
pr2 ("Locking file: " ^ filename);
- try
+ try
let _fd = Unix.openfile filename [Unix.O_CREAT;Unix.O_EXCL] 0o777 in
()
- with Unix.Unix_error (e, fm, argm) ->
+ with Unix.Unix_error (e, fm, argm) ->
pr2 (spf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm);
raise FileAlreadyLocked
(* 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 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 (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 :(
+ *
+ * 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
+ * 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 =
+let exn_to_s exn =
Printexc.to_string exn
(* alias *)
(*****************************************************************************)
let check_stack = ref true
-let check_stack_size limit =
+let check_stack_size limit =
if !check_stack then begin
pr2 "checking stack size (do ulimit -s 50000 if problem)";
- let rec aux i =
+ let rec aux i =
if i = limit
then 0
else 1 + aux (i + 1)
()
end
-let test_check_stack_size limit =
+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)
+ * (adjustable by ulimit -s)
*)
-let _init_gc_stack =
+let _init_gc_stack =
Gc.set {(Gc.get ()) with Gc.stack_limit = 100 * 1024 * 1024}
* so for this we are ready to spend some extra time at the beginning that
* could save far more later.
*)
-let check_stack_nbfiles nbfiles =
+let check_stack_nbfiles nbfiles =
if nbfiles > 200
then check_stack_size 10000000
(* Arguments/options and command line (cocci and acomment) *)
(*****************************************************************************)
-(*
+(*
* Why define wrappers ? Arg not good enough ? Well the Arg.Rest is not that
* good and I need a way sometimes to get a list of argument.
- *
+ *
* I could define maybe a new Arg.spec such as
- * | String_list of (string list -> unit), but the action may require
+ * | String_list of (string list -> unit), but the action may require
* some flags to be set, so better to process this after all flags have
* been set by parse_options. So have to split. Otherwise it would impose
- * an order of the options such as
+ * an order of the options such as
* -verbose_parsing -parse_c file1 file2. and I really like to use bash
* history and add just at the end of my command a -profile for instance.
- *
- *
+ *
+ *
* Why want a -action arg1 arg2 arg3 ? (which in turn requires this
- * convulated scheme ...) Why not use Arg.String action such as
- * "-parse_c", Arg.String (fun file -> ...) ?
- * I want something that looks like ocaml function but at the UNIX
- * command line level. So natural to have this scheme instead of
+ * convulated scheme ...) Why not use Arg.String action such as
+ * "-parse_c", Arg.String (fun file -> ...) ?
+ * I want something that looks like ocaml function but at the UNIX
+ * command line level. So natural to have this scheme instead of
* -taxo_file arg2 -sample_file arg3 -parse_c arg1.
- *
- *
- * Why not use the toplevel ?
+ *
+ *
+ * Why not use the toplevel ?
* - because to debug, ocamldebug is far superior to the toplevel
* (can go back, can go directly to a specific point, etc).
- * I want a kind of testing at cmdline level.
- * - Also I don't have file completion when in the ocaml toplevel.
+ * I want a kind of testing at cmdline level.
+ * - Also I don't have file completion when in the ocaml toplevel.
* I have to type "/path/to/xxx" without help.
- *
- *
- * Why having variable flags ? Why use 'if !verbose_parsing then ...' ?
+ *
+ *
+ * Why having variable flags ? Why use 'if !verbose_parsing then ...' ?
* why not use strings and do stuff like the following
* 'if (get_config "verbose_parsing") then ...'
* Because I want to make the interface for flags easier for the code
* that use it. The programmer should not be bothered wether this
- * flag is set via args cmd line or a config file, so I want to make it
+ * flag is set via args cmd line or a config file, so I want to make it
* as simple as possible, just use a global plain caml ref variable.
- *
+ *
* Same spirit a little for the action. Instead of having function such as
* test_parsing_c, I could do it only via string. But I still prefer
* to have plain caml test functions. Also it makes it easier to call
* those functions from a toplevel for people who prefer the toplevel.
- *
- *
- * So have flag_spec and action_spec. And in flag have debug_xxx flags,
+ *
+ *
+ * So have flag_spec and action_spec. And in flag have debug_xxx flags,
* verbose_xxx flags and other flags.
- *
+ *
* I would like to not have to separate the -xxx actions spec from the
* corresponding actions, but those actions may need more than one argument
* and so have to wait for parse_options, which in turn need the options
- * spec, so circle.
- *
+ * spec, so circle.
+ *
* Also I dont want to mix code with data structures, so it's better that the
* options variable contain just a few stuff and have no side effects except
* setting global variables.
- *
+ *
* Why not have a global variable such as Common.actions that
* other modules modify ? No, I prefer to do less stuff behind programmer's
* back so better to let the user merge the different options at call
* site, but at least make it easier by providing shortcut for set of options.
- *
- *
- *
- *
+ *
+ *
+ *
+ *
* todo? isn't unison or scott-mcpeak-lib-in-cil handles that kind of
* stuff better ? That is the need to localize command line argument
* while still being able to gathering them. Same for logging.
* Similiar to the type prof = PALL | PNONE | PSOME of string list.
* Same spirit of fine grain config in log4j ?
- *
+ *
* todo? how mercurial/cvs/git manage command line options ? because they
* all have a kind of DSL around arguments with some common options,
* specific options, conventions, etc.
- *
- *
- * todo? generate the corresponding noxxx options ?
+ *
+ *
+ * todo? generate the corresponding noxxx options ?
* todo? generate list of options and show their value ?
- *
- * todo? make it possible to set this value via a config file ?
- *
- *
+ *
+ * todo? make it possible to set this value via a config file ?
+ *
+ *
*)
type arg_spec_full = Arg.key * Arg.spec * Arg.doc
(* ---------------------------------------------------------------------- *)
-(* now I use argv as I like at the call sites to show that
+(* now I use argv as I like at the call sites to show that
* this function internally use argv.
*)
let parse_options options usage_msg argv =
-let usage usage_msg options =
+let usage usage_msg options =
Arg.usage (Arg.align options) usage_msg
Arg.align xs +> List.rev +> drop 2 +> List.rev
-let short_usage usage_msg ~short_opt =
+let short_usage usage_msg ~short_opt =
usage usage_msg short_opt
-let long_usage usage_msg ~short_opt ~long_opt =
+let long_usage usage_msg ~short_opt ~long_opt =
pr usage_msg;
pr "";
- let all_options_with_title =
+ let all_options_with_title =
(("main options", "", short_opt)::long_opt) in
- all_options_with_title +> List.iter
- (fun (title, explanations, xs) ->
+ all_options_with_title +> List.iter
+ (fun (title, explanations, xs) ->
pr title;
pr_xxxxxxxxxxxxxxxxx();
- if explanations <> ""
+ if explanations <> ""
then begin pr explanations; pr "" end;
- arg_align2 xs +> List.iter (fun (key,action,s) ->
+ arg_align2 xs +> List.iter (fun (key,action,s) ->
pr (" " ^ key ^ s)
);
pr "";
let args = ref [] in
let f = (fun file -> args := file::!args) in
let l = Arg.align l in
- (try begin
+ (try begin
Arg.parse_argv Sys.argv l f msg;
args := List.rev !args;
!args
(* ---------------------------------------------------------------------- *)
-(* kind of unit testing framework, or toplevel like functionnality
+(* kind of unit testing framework, or toplevel like functionnality
* at shell command line. I realize than in fact It follows a current trend
- * to have a main cmdline program where can then select different actions,
+ * to have a main cmdline program where can then select different actions,
* as in cvs/hg/git where do hg <action> <arguments>, and the shell even
* use a curried syntax :)
- *
- *
+ *
+ *
* Not-perfect-but-basic-feels-right: an action
* spec looks like this:
- *
+ *
* let actions () = [
- * "-parse_taxo", " <file>",
+ * "-parse_taxo", " <file>",
* Common.mk_action_1_arg test_parse_taxo;
* ...
* ]
- *
+ *
* Not-perfect-but-basic-feels-right because for such functionality we
* need a way to transform a string into a caml function and pass arguments
* and the preceding design does exactly that, even if then the
* functions that use this design are not so convenient to use (there
* are 2 places where we need to pass those data, in the options and in the
- * main dispatcher).
- *
+ * main dispatcher).
+ *
* Also it's not too much intrusive. Still have an
- * action ref variable in the main.ml and can still use the previous
+ * action ref variable in the main.ml and can still use the previous
* simpler way to do where the match args with in main.ml do the
* dispatch.
- *
- * Use like this at option place:
+ *
+ * Use like this at option place:
* (Common.options_of_actions actionref (Test_parsing_c.actions())) ++
- * Use like this at dispatch action place:
- * | xs when List.mem !action (Common.action_list all_actions) ->
+ * Use like this at dispatch action place:
+ * | xs when List.mem !action (Common.action_list all_actions) ->
* Common.do_action !action xs all_actions
- *
+ *
*)
type flag_spec = Arg.key * Arg.spec * Arg.doc
-type action_spec = Arg.key * Arg.doc * action_func
+type action_spec = Arg.key * Arg.doc * action_func
and action_func = (string list -> unit)
type cmdline_actions = action_spec list
exception WrongNumberOfArguments
-let options_of_actions action_ref actions =
- actions +> List.map (fun (key, doc, _func) ->
+let options_of_actions action_ref actions =
+ actions +> List.map (fun (key, doc, _func) ->
(key, (Arg.Unit (fun () -> action_ref := key)), doc)
)
-
-let (action_list: cmdline_actions -> Arg.key list) = fun xs ->
- List.map (fun (a,b,c) -> a) xs
+
+let (action_list: cmdline_actions -> Arg.key list) = fun xs ->
+ List.map (fun (a,b,c) -> a) xs
let (do_action: Arg.key -> string list (* args *) -> cmdline_actions -> unit) =
- fun key args xs ->
+ fun key args xs ->
let assoc = xs +> List.map (fun (a,b,c) -> (a,c)) in
let action_func = List.assoc key assoc in
action_func args
-(* todo? if have a function with default argument ? would like a
- * mk_action_0_or_1_arg ?
+(* todo? if have a function with default argument ? would like a
+ * mk_action_0_or_1_arg ?
*)
-let mk_action_0_arg f =
- (function
+let mk_action_0_arg f =
+ (function
| [] -> f ()
| _ -> raise WrongNumberOfArguments
)
-let mk_action_1_arg f =
- (function
+let mk_action_1_arg f =
+ (function
| [file] -> f file
| _ -> raise WrongNumberOfArguments
)
-let mk_action_2_arg f =
- (function
+let mk_action_2_arg f =
+ (function
| [file1;file2] -> f file1 file2
| _ -> raise WrongNumberOfArguments
)
-let mk_action_3_arg f =
- (function
+let mk_action_3_arg f =
+ (function
| [file1;file2;file3] -> f file1 file2 file3
| _ -> raise WrongNumberOfArguments
)
(* the evil generic (=). I define another symbol to more easily detect
* it, cos the '=' sign is syntaxically overloaded in caml. It is also
- * used to define function.
+ * used to define function.
*)
let (=*=) = (=)
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) &&
+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'
(* 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
+(* 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 between i min max = i > min && i < max
-let (between_strict: int -> int -> int -> bool) = fun a b c ->
+let (between_strict: int -> int -> int -> bool) = fun a b c ->
a < b && b < c
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 =
+let (prime1: int -> int option) = fun x ->
+ let rec prime1_aux n =
if n =|= 1 then None
- else
+ 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 =
+let (prime: int -> int option) = fun x ->
+ let rec prime_aux n =
if n =|= x then None
- else
+ 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 product = List.fold_left ( * ) 1
-let decompose x =
- let rec decompose x =
+let decompose x =
+ let rec decompose x =
if x =|= 1 then []
- else
+ 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
type uint = int
-let int_of_stringchar s =
+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 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))
(* let int_of_hex s = int_of_base s 16, NONONONO cos 'A' - '0' does not give 10 !! *)
-let int_of_all s =
+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 =
+let pourcent x total =
(x * 100) / total
-let pourcent_float x total =
+let pourcent_float x total =
((float_of_int x) *. 100.0) /. (float_of_int total)
-let pourcent_float_of_floats x total =
+let pourcent_float_of_floats x total =
(x *. 100.0) /. total
-let pourcent_good_bad good bad =
+let pourcent_good_bad good bad =
(good * 100) / (good + bad)
-let pourcent_good_bad_float 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
+let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) =
+ if is_better newv aref
then begin
aref := newv;
aelem := newelem;
(* Numeric/overloading *)
(*****************************************************************************)
-type 'a numdict =
- NumDict of (('a-> 'a -> 'a) *
- ('a-> 'a -> 'a) *
- ('a-> 'a -> 'a) *
+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 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
+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
+module ArithFloatInfix = struct
let (+..) = (+)
let (-..) = (-)
let (/..) = (/)
| None -> ()
| Some x -> f x
-let optionise f =
+let optionise f =
try Some (f ()) with Not_found -> None
let partition_either f l =
let rec part_either left right = function
| [] -> (List.rev left, List.rev right)
- | x :: l ->
+ | 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
let rec find_some p = function
| [] -> raise Not_found
- | x :: l ->
+ | x :: l ->
match p x with
| Some v -> v
| None -> find_some p l
(* same
-let map_find f xs =
+let map_find f xs =
xs +> List.map f +> List.find (function Some x -> true | None -> false)
+> (function Some x -> x | None -> raise Impossible)
*)
(*****************************************************************************)
(* Note: OCaml Str regexps are different from Perl regexp:
- * - The OCaml regexp must match the entire way.
- * So "testBee" =~ "Bee" is wrong
+ * - The OCaml regexp must match the entire way.
+ * So "testBee" =~ "Bee" is wrong
* but "testBee" =~ ".*Bee" is right
- * Can have the perl behavior if use Str.search_forward instead of
+ * Can have the perl behavior if use Str.search_forward instead of
* Str.string_match.
- * - Must add some additional \ in front of some special char. So use
+ * - Must add some additional \ in front of some special char. So use
* \\( \\| and also \\b
* - It does not always handle newlines very well.
* - \\b does consider _ but not numbers in indentifiers.
- *
+ *
* Note: PCRE regexps are then different from Str regexps ...
* - just use '(' ')' for grouping, not '\\)'
* - still need \\b for word boundary, but this time it works ...
* so can match some word that have some digits in them.
- *
+ *
*)
(* put before String section because String section use some =~ *)
(* let gsubst = global_replace *)
-let (==~) s re = Str.string_match re s 0
+let (==~) s re = Str.string_match re s 0
let _memo_compiled_regexp = Hashtbl.create 101
-let candidate_match_func s re =
+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)
+ 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 =
+let match_func s re =
profile_code "Common.=~" (fun () -> candidate_match_func s re)
-let (=~) 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
+let string_match_substring re s =
+ try let _i = Str.search_forward re s 0 in true
with Not_found -> false
-let _ =
+let _ =
example(string_match_substring (Str.regexp "foo") "a foo b")
-let _ =
+let _ =
example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b")
-let _ =
+let _ =
example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b")
-let _ =
+let _ =
example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b")
-(* does not work :(
-let _ =
+(* 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 ->
+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 ->
+ * 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)
fun re xs ->
let rec split_lr_aux (heading, accu) = function
| [] -> [(heading, List.rev accu)]
- | x::xs ->
- if x =~ re
+ | 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
+ split_lr_aux ("__noheading__", []) xs
+> (fun xs -> if (List.hd xs) =*= ("__noheading__",[]) then List.tl xs else xs)
"^[a-zA-Z_][A-Za-z_0-9]*$"
-let all_match re s =
+let all_match re s =
let regexp = Str.regexp re in
let res = ref [] in
- let _ = Str.global_substitute regexp (fun _s ->
+ 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
) s in
List.rev !res
-let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment"
+let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment"
=*= ["@Et";"@Comment"])
-let global_replace_regexp re f_on_substr s =
+let global_replace_regexp re f_on_substr s =
let regexp = Str.regexp re in
- Str.global_substitute regexp (fun _wholestr ->
+ Str.global_substitute regexp (fun _wholestr ->
let substr = Str.matched_string s in
f_on_substr substr
) s
-let regexp_word_str =
+let regexp_word_str =
"\\([a-zA-Z_][A-Za-z_0-9]*\\)"
let regexp_word = Str.regexp regexp_word_str
-let regular_words s =
+let regular_words s =
all_match regexp_word_str s
-let contain_regular_word s =
+let contain_regular_word s =
let xs = regular_words s in
List.length xs >= 1
(* 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
+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 -> s
-let (<!!>) s (i,j) =
+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
+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 ::
+ String.sub s 0 sp ::
split_on_char c (String.sub s (sp+1) (String.length s - sp - 1))
with Not_found -> [s]
let lowercase = String.lowercase
-let quote s = "\"" ^ s ^ "\""
+let quote s = "\"" ^ s ^ "\""
(* easier to have this to be passed as hof, because ocaml dont have
* haskell "section" operators
*)
-let null_string s =
- s =$= ""
+let null_string s =
+ s =$= ""
-let is_blank_string 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.length s1 <= String.length s2) &&
(String.sub s2 0 (String.length s1) =$= s1)
-let plural i s =
+let plural i s =
if i =|= 1
- then Printf.sprintf "%d %s" i s
+ then Printf.sprintf "%d %s" i s
else Printf.sprintf "%d %ss" i s
let showCodeHex xs = List.iter (fun i -> printf "%02x" i) xs
let take_string n s =
String.sub s 0 (n-1)
-let take_string_safe n s =
+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 size_mo_ko i =
let ko = (i / 1024) mod 1024 in
let mo = (i / 1024) / 1024 in
- (if mo > 0
+ (if mo > 0
then sprintf "%dMo%dKo" mo ko
else sprintf "%dKo" ko
)
-let size_ko i =
+let size_ko i =
let ko = i / 1024 in
sprintf "%dKo" ko
-
-(* done in summer 2007 for julia
+
+(* 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:
+ * 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:
* 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)
- *
- *
+ * D(i-1, j)+1
+ * D(i-1, j-1) +
+ * t(i,j)
+ *
+ *
*)
-let matrix_distance s1 s2 =
+let matrix_distance s1 s2 =
let n = (String.length s1) in
- let m = (String.length s2) in
+ let m = (String.length s2) in
let mat = Array.make_matrix (n+1) (m+1) 0 in
- let t i j =
+ let t i j =
if String.get s1 (i-1) =<= String.get s2 (j-1)
then 0
- else 1
+ else 1
in
let min3 a b c = min (min a b) c in
done;
for i = 1 to n do
for j = 1 to m do
- mat.(i).(j) <-
+ 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 =
+let edit_distance s1 s2 =
(matrix_distance s1 s2).(String.length s1).(String.length s2)
end
-let (filesuffix: filename -> string) = fun s ->
+let (filesuffix: filename -> string) = fun s ->
(try regexp_match s ".+\\.\\([a-zA-Z0-9_]+\\)$" with _ -> "NOEXT")
-let (fileprefix: filename -> string) = fun s ->
+let (fileprefix: filename -> string) = fun s ->
(try regexp_match s "\\(.+\\)\\.\\([a-zA-Z0-9_]+\\)?$" with _ -> s)
let _ = example (filesuffix "toto.c" =$= "c")
(withoutExtension "toto.s.toto" = "toto")
*)
-let adjust_ext_if_needed filename ext =
- if String.get ext 0 <> '.'
+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))
-let db_of_filename file =
+let db_of_filename file =
dirname file, basename file
-let filename_of_db (basedir, file) =
+let filename_of_db (basedir, file) =
Filename.concat basedir file
-let dbe_of_filename file =
+let dbe_of_filename file =
(* raise Invalid_argument if no ext, so safe to use later the unsafe
* fileprefix and filesuffix functions.
*)
- ignore(Filename.chop_extension file);
- Filename.dirname file,
- Filename.basename file +> fileprefix,
+ ignore(Filename.chop_extension file);
+ Filename.dirname file,
+ Filename.basename file +> fileprefix,
Filename.basename file +> filesuffix
-let filename_of_dbe (dir, base, ext) =
+let filename_of_dbe (dir, base, ext) =
Filename.concat dir (base ^ "." ^ ext)
-let dbe_of_filename_safe file =
+let dbe_of_filename_safe file =
try Left (dbe_of_filename file)
- with Invalid_argument _ ->
+ with Invalid_argument _ ->
Right (Filename.dirname file, Filename.basename file)
-let dbe_of_filename_nodot 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
-let replace_ext file oldext newext =
+let replace_ext file oldext newext =
let (d,b,e) = dbe_of_filename file in
assert(e =$= oldext);
filename_of_dbe (d,b,newext)
-let normalize_path file =
+let normalize_path file =
let (dir, filename) = Filename.dirname file, Filename.basename file in
let xs = split "/" dir in
let rec aux acc = function
| [] -> List.rev acc
- | x::xs ->
+ | x::xs ->
(match x with
| "." -> aux acc xs
| ".." -> aux (List.tl acc) xs
(*
-let relative_to_absolute s =
+let relative_to_absolute s =
if Filename.is_relative s
- then
+ then
begin
let old = Sys.getcwd () in
Sys.chdir s;
else s
*)
-let relative_to_absolute s =
+let relative_to_absolute s =
if Filename.is_relative s
then Sys.getcwd () ^ "/" ^ s
else s
(* @Pre: prj_path must not contain regexp symbol *)
-let filename_without_leading_path prj_path s =
+let filename_without_leading_path prj_path s =
let prj_path = chop_dirsymbol prj_path in
if s =~ ("^" ^ prj_path ^ "/\\(.*\\)$")
then matched1 s
- else
- failwith
+ else
+ failwith
(spf "cant find filename_without_project_path: %s %s" prj_path s)
(*****************************************************************************)
(* i18n *)
(*****************************************************************************)
-type langage =
+type langage =
| English
| Francais
| Deutsch
(* maybe I should use ocamlcalendar, but I don't like all those functors ... *)
-type month =
+type month =
| Jan | Feb | Mar | Apr | May | Jun
| Jul | Aug | Sep | Oct | Nov | Dec
type year = Year of int
-let check_date_dmy (DMY (day, month, year)) =
+let check_date_dmy (DMY (day, month, year)) =
raise Todo
-let check_time_dmy (TimeDMY (day, month, year)) =
+let check_time_dmy (TimeDMY (day, month, year)) =
raise Todo
let check_time_hms (HMS (x,y,a)) =
(* ---------------------------------------------------------------------- *)
(* older code *)
-let int_to_month i =
+let int_to_month i =
assert (i <= 12 && i >= 1);
match i with
6 , Saturday , "Sat" ,"Sam" , "Saturday";
]
-let i_to_month_h =
+let i_to_month_h =
month_info +> List.map (fun (i,month,monthstr,mlong,days) -> i, month)
-let s_to_month_h =
+let s_to_month_h =
month_info +> List.map (fun (i,month,monthstr,mlong,days) -> monthstr, month)
-let slong_to_month_h =
+let slong_to_month_h =
month_info +> List.map (fun (i,month,monthstr,mlong,days) -> mlong, month)
-let month_to_s_h =
+let month_to_s_h =
month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, monthstr)
-let month_to_i_h =
+let month_to_i_h =
month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, i)
-let i_to_wday_h =
+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 =
+let month_of_string s =
List.assoc s s_to_month_h
-let month_of_string_long s =
+let month_of_string_long s =
List.assoc s slong_to_month_h
-let string_of_month s =
+let string_of_month s =
List.assoc s month_to_s_h
-let month_of_int i =
+let month_of_int i =
List.assoc i i_to_month_h
-let int_of_month m =
+let int_of_month m =
List.assoc m month_to_i_h
-let wday_of_int i =
+let wday_of_int i =
List.assoc i i_to_wday_h
-let string_en_of_wday wday =
+let string_en_of_wday wday =
List.assoc wday wday_to_en_h
-let string_fr_of_wday wday =
+let string_fr_of_wday wday =
List.assoc wday wday_to_fr_h
(* ---------------------------------------------------------------------- *)
-let wday_str_of_int ~langage i =
+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 Todo
-
-let string_of_date_dmy (DMY (Day n, month, Year y)) =
+
+let string_of_date_dmy (DMY (Day n, month, Year y)) =
(spf "%02d-%s-%d" n (string_of_month month) y)
-let string_of_unix_time ?(langage=English) tm =
+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 s = tm.Unix.tm_sec in
let wday = wday_str_of_int ~langage tm.Unix.tm_wday in
-
+
spf "%02d/%03s/%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 =~
+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 =
+ let mon =
smonth +> month_of_string +> int_of_month +> (fun i -> i -1)
in
let tm = Unix.localtime (Unix.time ()) in
- { tm with
+ { tm with
Unix.tm_year = y;
Unix.tm_mon = mon;
Unix.tm_mday = s_to_i sday;
-let short_string_of_unix_time ?(langage=English) tm =
+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 _s = tm.Unix.tm_sec in
let wday = wday_str_of_int ~langage tm.Unix.tm_wday in
-
+
spf "%02d/%03s/%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))
+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 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 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 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 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 start_d = mday - wday in
let end_d = mday + (6 - wday) in
- enum start_d end_d +> List.map (fun mday ->
+ 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 =
+let first_day_in_week_of_day day =
List.hd (days_in_week_of_day day)
-let last_day_in_week_of_day day =
+let last_day_in_week_of_day day =
last (days_in_week_of_day day)
(* ---------------------------------------------------------------------- *)
(* (modified) copy paste from ocamlcalendar/src/date.ml *)
-let days_month =
+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 +
+let rough_days_since_jesus (DMY (Day nday, month, Year year)) =
+ let n =
+ nday +
(days_month.(int_of_month month -1)) +
year * 365
in
-let is_more_recent d1 d2 =
+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)
+ (n1 > n2)
-let max_dmy d1 d2 =
- if is_more_recent d1 d2
+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
+let min_dmy d1 d2 =
+ if is_more_recent d1 d2
then d2
else d1
-let maximum_dmy ds =
+let maximum_dmy ds =
foldl1 max_dmy ds
-let minimum_dmy ds =
+let minimum_dmy ds =
foldl1 min_dmy ds
-
-let rough_days_between_dates d1 d2 =
+
+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 _ = example
- (rough_days_between_dates
+let _ = example
+ (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
+ (rough_days_between_dates
(DMY (Day 29, Feb, Year 1977))
- (DMY (Day 1, Mar , Year 1977)))
+ (DMY (Day 1, Mar , Year 1977)))
(Days 1)
*)
*)
-let mk_date_dmy day month year =
+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 = {
+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 *)
} in
Unix.mktime tm
-let unixtime_to_dmy 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 =
+let unixtime_to_floattime tm =
Unix.mktime tm +> fst
-let floattime_to_unixtime sec =
+let floattime_to_unixtime sec =
Unix.localtime sec
-let sec_to_days sec =
+let sec_to_days sec =
let minfactor = 60 in
let hourfactor = 60 * 60 in
let dayfactor = 60 * 60 * 24 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 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 sec_to_hours sec =
let minfactor = 60 in
let hourfactor = 60 * 60 in
(if hours > 0 then plural hours "hour" ^ " " else "") ^
(if mins > 0 then plural mins "min" ^ " " else "") ^
(spf "%dsec" sec)
-
+
let test_date_1 () =
let lastmonth : unit -> float = fun () -> (Unix.time () -. (30.0 *. day_secs))
-let week_before : float_time -> float_time = fun d ->
+let week_before : float_time -> float_time = fun d ->
(d -. (7.0 *. day_secs))
-let month_before : float_time -> float_time = fun d ->
+let month_before : float_time -> float_time = fun d ->
(d -. (30.0 *. day_secs))
-let week_after : float_time -> float_time = fun d ->
+let week_after : float_time -> float_time = fun d ->
(d +. (7.0 *. day_secs))
(*****************************************************************************)
(* now in prelude:
- * let (list_of_string: string -> char list) = fun s ->
+ * let (list_of_string: string -> char list) = fun s ->
* (enum 0 ((String.length s) - 1) +> List.map (String.get s))
*)
let _ = example (list_of_string "abcd" =*= ['a';'b';'c';'d'])
(*
-let rec (list_of_stream: ('a Stream.t) -> 'a list) =
+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) =
+let (list_of_string: string -> char list) =
Stream.of_string $ list_of_stream
*)
-(* now in prelude:
+(* now in prelude:
* let (lines: string -> string list) = fun s -> ...
*)
-let (lines_with_nl: 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 ->
+ | x::xs ->
let e = x ^ "\n" in
- e::lines_aux xs
+ e::lines_aux xs
in
(time_func (fun () -> Str.split_delim (Str.regexp "\n") s)) +> lines_aux
(* +> 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 ->
+ chars +> List.fold_left (fun (acc, lines) char ->
let newacc = acc ^ (String.make 1 char) in
- if char = '\n'
+ 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 ->
+let (unlines: string list -> string) = fun s ->
(String.concat "\n" s) ^ "\n"
-let (words: string -> string list) = fun s ->
+let (words: string -> string list) = fun s ->
Str.split (Str.regexp "[ \t()\";]+") s
-let (unwords: string list -> string) = fun s ->
+let (unwords: string list -> string) = fun s ->
String.concat "" s
-let (split_space: string -> string list) = fun s ->
+let (split_space: string -> string list) = fun s ->
Str.split (Str.regexp "[ \t\n]+") s
(* todo opti ? *)
-let nblines s =
+let nblines s =
lines s +> List.length
let _ = example (nblines "" =|= 0)
let _ = example (nblines "toto" =|= 1)
(*****************************************************************************)
(* Process/Files *)
(*****************************************************************************)
-let cat_orig file =
+let cat_orig file =
let chan = open_in file in
- let rec cat_orig_aux () =
- try
+ 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 ()
cat_orig_aux()
(* tail recursive efficient version *)
-let cat file =
+let cat file =
let chan = open_in file in
- let rec cat_aux acc () =
+ 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
+ if b
then cat_aux (l::acc) ()
- else acc
+ else acc
in
cat_aux [] () +> List.rev +> (fun x -> close_in chan; x)
-let cat_array file =
- (""::cat file) +> Array.of_list
+let cat_array file =
+ (""::cat file) +> Array.of_list
-let interpolate str =
+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 "%s" s; flush stdout; s
+let echo s = printf "%s" s; flush stdout; s
let usleep s = for i = 1 to s do () done
let sleep_little () =
- (*old: *)
+ (*old: *)
Unix.sleep 1
(*ignore(Sys.command ("usleep " ^ !_sleep_time))*)
* let command2 s = ignore(Sys.command s)
*)
-let do_in_fork f =
+let do_in_fork f =
let pid = Unix.fork () in
if pid =|= 0
- then
- begin
+ then
+ begin
(* Unix.setsid(); *)
- Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ ->
+ Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ ->
pr2 "being killed";
Unix.kill 0 Sys.sigkill;
));
- f();
+ f();
exit 0;
end
else pid
-let process_output_to_list2 = fun command ->
+let process_output_to_list2 = fun command ->
let chan = Unix.open_process_in command in
let res = ref ([] : string list) in
- let rec process_otl_aux () =
+ let rec process_otl_aux () =
let e = input_line chan in
res := e::!res;
process_otl_aux() in
(* now in prelude:
* let command2 s = ignore(Sys.command s)
- *)
+ *)
-let _batch_mode = ref false
-let command2_y_or_no cmd =
+let _batch_mode = ref false
+let command2_y_or_no cmd =
if !_batch_mode then begin command2 cmd; true end
else begin
| _ -> failwith "answer by yes or no"
end
-let command2_y_or_no_exit_if_no cmd =
+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 mkdir ?(mode=0o770) file =
+
+let mkdir ?(mode=0o770) file =
Unix.mkdir file mode
let read_file_orig file = cat file +> unlines
buf
-let write_file ~file s =
+let write_file ~file s =
let chan = open_out file in
(output_string chan s; close_out chan)
-let filesize file =
+let filesize file =
(Unix.stat file).Unix.st_size
-let filemtime file =
+let filemtime file =
(Unix.stat file).Unix.st_mtime
(* opti? use wc -l ? *)
-let nblines_file file =
+let nblines_file file =
cat file +> List.length
-let lfile_exists filename =
- try
+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 =
+ with
+ Unix.Unix_error (Unix.ENOENT, _, _) -> false
+ | Unix.Unix_error (Unix.ENOTDIR, _, _) -> false
+ | Unix.Unix_error (error, _, fl) ->
+ failwith
+ (Printf.sprintf "unexpected error %s for file %s"
+ (Unix.error_message error) fl)
+
+let is_directory file =
(Unix.stat file).Unix.st_kind =*= Unix.S_DIR
-
-
+
+
(* src: from chailloux et al book *)
-let capsule_unix f args =
- try (f args)
- with Unix.Unix_error (e, fm, argm) ->
+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 (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 ->
+ with e ->
pr2 ("EXN pb stating file: " ^ s);
false
)
-let (readdir_to_dir_list: string -> string list) = fun path ->
+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 ->
+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 ->
+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 (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)
+ if stat.Unix.st_kind =*= Unix.S_DIR
+ then Some (s, stat.Unix.st_size)
else None
)
* 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
+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)
+ if not (Sys.file_exists file)
then failwith ("can't find: " ^ file);
let file_cache = (file ^ ext_cache) in
- if Sys.file_exists file_cache &&
+ if Sys.file_exists file_cache &&
filemtime file_cache >= filemtime file
then begin
if verbose then pr2 ("using cache: " ^ file_cache);
res
end
end
-let cache_computation ?verbose ?use_cache a b c =
- profile_code "Common.cache_computation" (fun () ->
+let cache_computation ?verbose ?use_cache a b c =
+ profile_code "Common.cache_computation" (fun () ->
cache_computation2 ?verbose ?use_cache a b c)
-
-let cache_computation_robust2
- file ext_cache
+
+let cache_computation_robust2
+ file ext_cache
(need_no_changed_files, need_no_changed_variables) ext_depend
- f =
- if not (Sys.file_exists file)
+ 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 =
+ let dependencies =
(* could do md5sum too *)
- ((file::need_no_changed_files) +> List.map (fun f -> f, filemtime f),
- need_no_changed_variables)
+ ((file::need_no_changed_files) +> List.map (fun f -> f, filemtime f),
+ need_no_changed_variables)
in
- if Sys.file_exists dependencies_cache &&
+ if Sys.file_exists dependencies_cache &&
get_value dependencies_cache =*= dependencies
then get_value file_cache
- else begin
+ else begin
pr2 ("cache computation recompute " ^ file);
let res = f () in
write_value dependencies dependencies_cache;
end
let cache_computation_robust a b c d e =
- profile_code "Common.cache_computation_robust" (fun () ->
+ profile_code "Common.cache_computation_robust" (fun () ->
cache_computation_robust2 a b c d e)
(* 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 ->
+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 files_of_dir_or_files_no_vcs ext xs =
- xs +> List.map (fun x ->
+let files_of_dir_or_files_no_vcs ext xs =
+ xs +> List.map (fun x ->
if is_directory x
- then
- cmd_to_list
+ then
+ cmd_to_list
("find " ^ x ^" -noleaf -type f -name \"*." ^ext^"\"" ^
"| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
)
) +> List.concat
-let files_of_dir_or_files_no_vcs_post_filter regex xs =
- xs +> List.map (fun x ->
+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
+ then
+ cmd_to_list
("find " ^ x ^
" -noleaf -type f | grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/"
)
let sanity_check_files_and_adjust ext files =
- let files = files +> List.filter (fun file ->
+ let files = files +> List.filter (fun file ->
if not (file =~ (".*\\."^ext))
- then begin
+ then begin
pr2 ("warning: seems not a ."^ext^" file");
false
end
- else
+ else
if is_directory file
then begin
pr2 (spf "warning: %s is a directory" file);
false
- end
+ 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 =
+let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm =
fun ~u ~g ~o ->
- let to_oct l =
+ 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 =
+ let perm =
((to_oct u) lsl 6) lor
((to_oct g) lsl 3) lor
(to_oct o)
(* pixel *)
-let has_env var =
- try
+let has_env var =
+ try
let _ = Sys.getenv var in true
with Not_found -> false
(* emacs/lisp inspiration (eric cooper and yaron minsky use that too) *)
-let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) =
+let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) =
fun file f ->
let chan = open_out file in
let pr s = output_string chan s in
- unwind_protect (fun () ->
+ unwind_protect (fun () ->
let res = f (pr, chan) in
close_out chan;
res)
let (with_open_infile: filename -> ((in_channel) -> 'a) -> 'a) = fun file f ->
let chan = open_in file in
- unwind_protect (fun () ->
+ unwind_protect (fun () ->
let res = f chan in
close_in chan;
res)
(fun e -> close_in chan)
-let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) =
+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
- unwind_protect (fun () ->
+ unwind_protect (fun () ->
let res = f (pr, chan) in
close_out chan;
res)
*)
(* it seems that the toplevel block such signals, even with this explicit
- * command :(
+ * 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
+(* 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 ?
+ * 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 timeoutval = fun f ->
- try
+
+let interval_timer = ref true
+
+let timeout_function timeoutval = fun f ->
+ try
+ if !interval_timer
+ then
+ begin
+ Sys.set_signal Sys.sigvtalrm
+ (Sys.Signal_handle (fun _ -> raise Timeout));
+ ignore
+ (Unix.setitimer Unix.ITIMER_VIRTUAL
+ {Unix.it_interval=float_of_int timeoutval;
+ Unix.it_value =float_of_int timeoutval});
+ let x = f() in
+ ignore(Unix.alarm 0);
+ x
+ end
+ else
+ 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
- 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
log "timeout (we abort)";
raise Timeout;
end
- | e ->
+ | 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 (...) ?
+ *
+ * robust?: and if alarm launched after the log (...) ?
* Maybe signals are disabled when process an exception handler ?
*)
- begin
+ begin
ignore(Unix.alarm 0);
(* log ("exn while in transaction (we abort too, even if ...) = " ^
- Printexc.to_string e);
+ Printexc.to_string e);
*)
log "exn while in timeout_function";
raise e
match timeoutvalopt with
| None -> f()
| Some x -> timeout_function x f
-
+
(* creation of tmp files, a la gcc *)
-let _temp_files_created = ref []
+let _temp_files_created = ref ([] : filename list)
(* ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c" *)
-let new_temp_file prefix suffix =
+let new_temp_file prefix suffix =
let processid = i_to_s (Unix.getpid ()) in
let tmp_file = Filename.temp_file (prefix ^ "-" ^ processid ^ "-") suffix in
push2 tmp_file _temp_files_created;
let save_tmp_files = ref false
-let erase_temp_files () =
+let erase_temp_files () =
if not !save_tmp_files then begin
- !_temp_files_created +> List.iter (fun s ->
+ !_temp_files_created +> List.iter (fun s ->
(* pr2 ("erasing: " ^ s); *)
command2 ("rm -f " ^ s)
);
_temp_files_created := []
end
+let erase_this_temp_file f =
+ if not !save_tmp_files then begin
+ _temp_files_created :=
+ List.filter (function x -> not (x =$= f)) !_temp_files_created;
+ command2 ("rm -f " ^ f)
+ end
+
+
(* now in prelude: exception UnixExit of int *)
-let exn_to_real_unixexit f =
- try f()
+let exn_to_real_unixexit f =
+ try f()
with UnixExit x -> exit x
-let uncat xs file =
- with_open_outfile file (fun (pr,_chan) ->
+let uncat xs file =
+ with_open_outfile file (fun (pr,_chan) ->
xs +> List.iter (fun s -> pr s; pr "\n");
)
let push l v =
l := v :: !l
-let rec zip xs ys =
+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 =
+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) ->
+let rec unzip zs =
+ List.fold_right (fun e (xs, ys) ->
(fst e::xs), (snd e::ys)) zs ([],[])
-let map_withkeep f xs =
+let map_withkeep f xs =
xs +> List.map (fun x -> f x, x)
(* now in prelude
- * let rec take n xs =
+ * let rec take n xs =
* match (n,xs) with
* | (0,_) -> []
* | (_,[]) -> failwith "take: not enough"
| x::xs -> if p x then drop_while p xs else x::xs
-let rec drop_until p xs =
+let rec drop_until p xs =
drop_while (fun x -> not (p x)) xs
let _ = example (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) =
+let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) =
fun p -> function
| [] -> ([], [])
- | x::xs ->
- if p x then
+ | x::xs ->
+ if p x then
let (l1, l2) = span p xs in
(x::l1, l2)
else ([], x::xs)
let rec groupBy eq l =
match l with
| [] -> []
- | x::xs ->
+ | x::xs ->
let (xs1,xs2) = List.partition (fun x' -> eq x x') xs in
(x::xs1)::(groupBy eq xs2)
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
+ | 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 (exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list)=
- fun f xs ->
+ fun f xs ->
let rec aux_filter acc = function
| [] -> [] (* drop what was accumulated because nothing to attach to *)
- | x::xs ->
- if f x
+ | x::xs ->
+ if f x
then aux_filter (x::acc) xs
else (x, List.rev acc)::aux_filter [] xs
in
[(1,[3;3]);(2,[3])])
let (group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list)=
- fun f xs ->
+ fun f xs ->
let rec aux_filter grouped_acc acc = function
- | [] ->
+ | [] ->
List.rev grouped_acc, List.rev acc
- | x::xs ->
- if f x
- then
+ | x::xs ->
+ if f x
+ then
aux_filter ((List.rev acc,x)::grouped_acc) [] xs
- else
+ else
aux_filter grouped_acc (x::acc) xs
in
aux_filter [] [] xs
let _ = example
- (group_by_post (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
+ (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 ->
+ 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 _ = example
- (group_by_pre (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*=
+ (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) =
+
+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
+ | x::xs ->
+ if p x then
+ [], x, xs
+ else
let (l1, a, l2) = split_when p xs in
(x::l1, a, l2)
-let _ = example (split_when (fun x -> x =|= 3)
+let _ = example (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 =
+let rec split_gen_when_aux f acc xs =
match xs with
- | [] ->
+ | [] ->
if null acc
then []
else [List.rev acc]
- | (x::xs) ->
+ | (x::xs) ->
(match f (x::xs) with
- | None ->
- split_gen_when_aux f (x::acc) xs
- | Some (rest) ->
+ | 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 =
+let split_gen_when f xs =
split_gen_when_aux f [] xs
(* 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 _ = example
- (skip_until (function 1::2::xs -> true | _ -> false)
+let _ = example
+ (skip_until (function 1::2::xs -> true | _ -> false)
[1;3;4;1;2;4;5] =*= [1;2;4;5])
let rec skipfirst e = function
*)
-let index_list xs =
+let index_list xs =
if null xs then [] (* enum 0 (-1) generate an exception *)
else zip xs (enum 0 ((List.length xs) -1))
-let index_list_and_total xs =
+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))
+ else zip xs (enum 0 ((List.length xs) -1))
+> List.map (fun (a,b) -> (a,b,total))
-let index_list_1 xs =
+let index_list_1 xs =
xs +> index_list +> List.map (fun (x,i) -> x, i+1)
let or_list = List.fold_left (||) false
let and_list = List.fold_left (&&) true
-let avg_list xs =
+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 =
+let head_middle_tail xs =
match xs with
- | x::y::xs ->
+ | x::y::xs ->
let head = x in
let reversed = List.rev (y::xs) in
let tail = List.hd reversed in
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 (++) = (@)
+(* 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 remove x xs =
let newxs = List.filter (fun y -> y <> x) xs in
assert (List.length newxs =|= List.length xs - 1);
newxs
-let exclude p xs =
+let exclude p xs =
List.filter (fun x -> not (p x)) xs
-(* now in prelude
+(* now in prelude
*)
-let fold_k f lastk acc xs =
+let fold_k f lastk acc xs =
let rec fold_k_aux acc = function
| [] -> lastk acc
- | x::xs ->
+ | x::xs ->
f acc x (fun acc -> fold_k_aux acc xs)
in
fold_k_aux acc xs
(* pixel *)
let do_withenv doit f env l =
let r_env = ref env in
- let l' = doit (fun e ->
+ 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:
+(* 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
let rec fpartition p l =
let rec part yes no = function
| [] -> (List.rev yes, List.rev no)
- | x :: l ->
+ | x :: l ->
(match p x with
| None -> part yes (x :: no) l
| Some v -> part (v :: yes) no l) in
(* 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
+ let rec map_eff_aux acc =
+ function
| [] -> acc
| x::xs -> map_eff_aux ((f x)::acc) xs
in
| [] -> []
| e::l -> if List.mem e l then uniq l else e :: uniq l
-let has_no_duplicate xs =
+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 =
+let rec get_duplicates xs =
match xs with
| [] -> []
- | x::xs ->
+ | 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
| [] -> raise Not_found
| x::xs -> (match p x with None -> return_when p xs | Some b -> b)
-let rec splitAt n xs =
+let rec splitAt n xs =
if n =|= 0 then ([],xs)
- else
+ else
(match xs with
| [] -> ([],[])
| (x::xs) -> let (a,b) = splitAt (n-1) xs in (x::a, b)
)
-let pack n xs =
+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
+ | 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
| e :: l ->
let rec min_with_ min_val min_elt = function
| [] -> min_elt
- | e::l ->
+ | e::l ->
let val_ = f e in
- if val_ < min_val
+ 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
| e1 :: e2 :: l ->
let rec min_with_ min_val min_elt min_val2 min_elt2 = function
| [] -> min_elt, min_elt2
- | e::l ->
+ | e::l ->
let val_ = f e in
- if val_ < min_val2
+ 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
+ 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
+ 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
in iter_with_previous_ e l
-let iter_with_before_after f xs =
- let rec aux before_rev after =
+let iter_with_before_after f xs =
+ let rec aux before_rev after =
match after with
| [] -> ()
| x::xs ->
| [] -> []
| [x] -> [[x]]
| x::xs -> List.flatten (List.map (insert_in x) (permutation xs))
-(* permutation [1;2;3] =
+(* permutation [1;2;3] =
* [[1; 2; 3]; [2; 1; 3]; [2; 3; 1]; [1; 3; 2]; [3; 1; 2]; [3; 2; 1]]
*)
| 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
+ 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 rec uncons_permut xs =
let indexed = index_list xs in
indexed +> List.map (fun (x, pos) -> (x, pos), remove_elem_pos pos xs)
-let _ =
- example
- (uncons_permut ['a';'b';'c'] =*=
+let _ =
+ example
+ (uncons_permut ['a';'b';'c'] =*=
[('a', 0), ['b';'c'];
('b', 1), ['a';'c'];
('c', 2), ['a';'b']
])
-let rec uncons_permut_lazy xs =
+let rec uncons_permut_lazy xs =
let indexed = index_list xs in
- indexed +> List.map (fun (x, pos) ->
- (x, pos),
+ 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
+ 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)
-let rec repeat e n =
+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
-let rec map2 f = function
+let rec map2 f = function
| [] -> []
| x::xs -> let r = f x in r::map2 f xs
-let rec map3 f l =
+let rec map3 f l =
let rec map3_aux acc = function
- | [] -> acc
+ | [] -> 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 id x = x
*)
-let pack_sorted same xs =
- let rec pack_s_aux acc xs =
+let pack_sorted same xs =
+ let rec pack_s_aux acc xs =
match (acc,xs) with
| ((cur,rest),[]) -> cur::rest
- | ((cur,rest), y::ys) ->
+ | ((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_sorted (=*=) [1;1;1;2;2;3;4]
-let rec keep_best f =
+let rec keep_best f =
let rec partition e = function
| [] -> e, []
| e' :: l ->
| Some e'' -> partition e'' l
in function
| [] -> []
- | e::l ->
+ | 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 ->
+ | 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 ->
+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"])
+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 =
+let sort_prof a b =
profile_code "Common.sort_by_xxx" (fun () -> List.sort a b)
-let sort_by_val_highfirst xs =
+let sort_by_val_highfirst xs =
sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs
-let sort_by_val_lowfirst xs =
+let sort_by_val_lowfirst xs =
sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs
-let sort_by_key_highfirst xs =
+let sort_by_key_highfirst xs =
sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
-let sort_by_key_lowfirst xs =
+let sort_by_key_lowfirst xs =
sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs
let _ = example (sort_by_key_lowfirst [4, (); 7,()] =*= [4,(); 7,()])
let _ = example (sort_by_key_highfirst [4,(); 7,()] =*= [7,(); 4,()])
-let sortgen_by_key_highfirst xs =
+let sortgen_by_key_highfirst xs =
sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs
-let sortgen_by_key_lowfirst 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 =
+let surEnsemble liste_el liste_liste_el =
List.filter
(function liste_elbis ->
List.for_all (function el -> List.mem el liste_elbis) liste_el
let rec realCombinaison = function
| [] -> []
| [a] -> [[a]]
- | a::l ->
+ | a::l ->
let res = realCombinaison l in
let res2 = List.map (function x -> a::x) res in
res2 ++ res ++ [[a]]
(* ces listes, on ne fait rien *)
let rec insere elem = function
| [] -> [[elem]]
- | a::l ->
+ | 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
+ | 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 ->
+ | 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
+ else
insereListeContenant a et2 l
else if List.mem et2 a then
insereListeContenant a et1 l
-type idx = Idx of int
+type idx = Idx of int
let next_idx (Idx i) = (Idx (i+1))
let int_of_idx (Idx i) = i
type 'a matrix = 'a array array
-let map_matrix f mat =
+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) =
+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 ->
+ 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 ->
+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 =
+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 Todo
-let (rows_of_matrix: 'a matrix -> 'a list list) = fun m ->
+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 (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 ->
+ (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 all_elems_matrix_by_row m =
+ rows_of_matrix m +> List.flatten
-let ex_matrix1 =
+let ex_matrix1 =
[|
[|0;1;2|];
[|3;4;5|];
[|6;7;8|];
|]
-let ex_rows1 =
+let ex_rows1 =
[
[0;1;2];
[3;4;5];
[6;7;8];
]
-let ex_columns1 =
+let ex_columns1 =
[
[0;3;6];
[1;4;7];
*)
-(* for the string_of auto generation of camlp4
+(* 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
(* 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
+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 =
+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
+let (set: 'a list -> 'a set) = fun xs ->
+ xs +> List.fold_left (flip insert_set) empty_set
let (exists_set: ('a -> bool) -> 'a set -> bool) = List.exists
let (forall_set: ('a -> bool) -> 'a set -> bool) = List.for_all
let (top_set: 'a set -> 'a) = List.hd
-let (inter_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
+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 ->
+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 ->
+let (minus_set: 'a set -> 'a set -> 'a set) = fun s1 s2 ->
s1 +> filter_set (fun x -> not (member_set x s2))
let (card_set: 'a set -> int) = List.length
-let (include_set: 'a set -> 'a set -> bool) = fun s1 s2 ->
+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 ->
+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 ($=$) = equal_set
(* as $+$ but do not check for memberness, allow to have set of func *)
-let ($@$) = fun a b -> a @ b
+let ($@$) = fun a b -> a @ b
let rec nub = function
[] -> []
(* Set as normal list *)
(*****************************************************************************)
(*
-let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 ->
+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]
let union_list = List.fold_left union []
-let uniq lis =
+let uniq lis =
List.fold_left (function acc -> function el -> union [el] acc) [] lis
(* pixel *)
let rec inclu lis1 lis2 =
List.for_all (function el -> List.mem el lis2) lis1
-let equivalent lis1 lis2 =
+let equivalent lis1 lis2 =
(inclu lis1 lis2) && (inclu lis2 lis1)
*)
(*
let rec insert x = function
| [] -> [x]
- | y::ys ->
+ | y::ys ->
if x = y then y::ys
else (if x < y then x::y::ys else y::(insert x ys))
match(x,y) with
| [], y -> []
| x, [] -> []
- | x::xs, y::ys ->
+ | x::xs, y::ys ->
if x = y then x::(intersect xs ys)
- else
+ else
(if x < y then intersect xs (y::ys)
else intersect (x::xs) ys
)
let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
- xs +> List.fold_left (fun acc (k, v) ->
- (fun k' ->
+ 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:
+(* simpler:
let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs ->
fun k -> List.assoc k xs
*)
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 apply_assoc key f xs =
let old = assoc key xs in
replace_assoc (key, f old) xs
(* 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 ->
+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)) =
+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
| [] -> 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 (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)
+ | (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 _ = example
+let _ = example
(lookup_list2 "c" [["a",1;"b",2];["a",1;"b",3];["a",1;"c",7]] =*= (7,2))
-let assoc_option k l =
+let assoc_option k l =
optionise (fun () -> List.assoc k l)
let assoc_with_err_msg k l =
- try List.assoc k l
- with Not_found ->
+ try List.assoc k l
+ with Not_found ->
pr2 (spf "pb assoc_with_err_msg: %s" (dump k));
raise Not_found
module IntMap = Map.Make
(struct
type t = int
- let compare = compare
+ 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
+ let compare = compare
end)
let intintmap_to_list m = IntIntMap.fold (fun id v acc -> (id, v) :: acc) m []
(*****************************************************************************)
(* il parait que better when choose a prime *)
-let hcreate () = Hashtbl.create 401
+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 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 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_to_list_unsorted h =
+ Hashtbl.fold (fun k v acc -> (k,v)::acc) h []
-let hash_of_list xs =
+let hash_of_list xs =
let h = Hashtbl.create 101 in
begin
xs +> List.iter (fun (k, v) -> Hashtbl.add h k v);
let _ =
let h = Hashtbl.create 101 in
- Hashtbl.add h "toto" 1;
+ 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 =
+
+let hfind_default key value_if_not_found h =
try Hashtbl.find h key
- with Not_found ->
+ 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 op value_if_not_found h =
+let hupdate_default key op value_if_not_found h =
let old = hfind_default key value_if_not_found h in
Hashtbl.replace h key (op old)
-
+
let hfind_option key h =
optionise (fun () -> Hashtbl.find h key)
(* Hash sets *)
(*****************************************************************************)
-type 'a hashset = ('a, bool) Hashtbl.t
+type 'a hashset = ('a, bool) Hashtbl.t
(* with sexp *)
-let hash_hashset_add k e h =
+let hash_hashset_add k e h =
match optionise (fun () -> Hashtbl.find h k) with
| Some hset -> Hashtbl.replace hset e true
- | None ->
+ | 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_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 =
+let hashset_of_list xs =
xs +> List.map (fun x -> x, true) +> hash_of_list
-let hkeys h =
+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 group_assoc_bykey_eff2 xs =
- let h = Hashtbl.create 101 in
+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 =
- profile_code2 "Common.group_assoc_bykey_eff" (fun () ->
+let group_assoc_bykey_eff xs =
+ profile_code2 "Common.group_assoc_bykey_eff" (fun () ->
group_assoc_bykey_eff2 xs)
-
-let test_group_assoc () =
+
+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
+ let ys = xs +> group_assoc_bykey_eff
in
pr2_gen ys
-let uniq_eff xs =
+let uniq_eff xs =
let h = Hashtbl.create 101 in
- xs +> List.iter (fun k ->
+ xs +> List.iter (fun k ->
Hashtbl.add h k true
);
hkeys h
-let diff_two_say_set_eff xs1 xs2 =
+let diff_two_say_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 _ ->
+
+ 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 _ ->
+ 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 honly_in_h1,
hashset_to_list honly_in_h2
-
+
(*****************************************************************************)
(* Stack *)
(*****************************************************************************)
| x::xs -> Some x
-
+
(* now in prelude:
* let push2 v l = l := v :: !l
*)
-let pop2 l =
+let pop2 l =
let v = List.hd !l in
begin
l := List.tl !l;
type 'a undo_stack = 'a list * 'a list (* redo *)
-let (empty_undo_stack: 'a undo_stack) =
+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 (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 (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) ->
+ List.hd undo
-let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
+let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) ->
match undo with
| [] -> failwith "empty undo stack"
- | x::xs ->
+ | x::xs ->
xs, x::redo
-let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, 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::xs ->
x::undo, xs
-let redo_undo x = undo_pop x
+let redo_undo x = undo_pop x
-let top_undo_option = fun (undo, redo) ->
+let top_undo_option = fun (undo, redo) ->
match undo with
| [] -> None
| x::xs -> Some x
type 'a tree = Tree of 'a * ('a tree) list
let rec (tree_iter: ('a -> unit) -> 'a tree -> unit) = fun f tree ->
- match tree with
- | Tree (node, xs) ->
+ match tree with
+ | Tree (node, xs) ->
f node;
xs +> List.iter (tree_iter f)
(* no empty tree, must have one root at list *)
-type 'a treeref =
- | NodeRef of 'a * 'a treeref list ref
+type 'a treeref =
+ | NodeRef of 'a * 'a treeref list ref
-let treeref_children_ref tree =
+let treeref_children_ref tree =
match tree with
| NodeRef (n, x) -> x
-let rec (treeref_node_iter:
-(* (('a * ('a, 'b) treeref list ref) -> unit) ->
+let rec (treeref_node_iter:
+(* (('a * ('a, 'b) treeref list ref) -> unit) ->
('a, 'b) treeref -> unit
-*) 'a)
- =
- fun f tree ->
+*) 'a)
+ =
+ fun f tree ->
match tree with
(* | LeafRef _ -> ()*)
- | NodeRef (n, xs) ->
+ | NodeRef (n, xs) ->
f (n, xs);
!xs +> List.iter (treeref_node_iter f)
-let find_treeref f tree =
+let find_treeref f tree =
let res = ref [] in
- tree +> treeref_node_iter (fun (n, xs) ->
+ tree +> treeref_node_iter (fun (n, xs) ->
if f (n,xs)
then push2 (n, xs) res;
);
| [] -> raise Not_found
| x::y::zs -> raise Multi_found
-let rec (treeref_node_iter_with_parents:
- (* (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) ->
- ('a, 'b) treeref -> unit)
+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 =
+ =
+ fun f tree ->
+ let rec aux acc tree =
match tree with
(* | LeafRef _ -> ()*)
- | NodeRef (n, xs) ->
+ | NodeRef (n, xs) ->
f (n, xs) acc ;
!xs +> List.iter (aux (n::acc))
in
(* ---------------------------------------------------------------------- *)
-(* Leaf can seem redundant, but sometimes want to directly see if
+(* 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
+type ('a, 'b) treeref2 =
+ | NodeRef2 of 'a * ('a, 'b) treeref2 list ref
| LeafRef2 of 'b
-let treeref2_children_ref tree =
+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 ->
+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) ->
+ | NodeRef2 (n, xs) ->
f (n, xs);
!xs +> List.iter (treeref_node_iter2 f)
-let find_treeref2 f tree =
+let find_treeref2 f tree =
let res = ref [] in
- tree +> treeref_node_iter2 (fun (n, xs) ->
+ tree +> treeref_node_iter2 (fun (n, xs) ->
if f (n,xs)
then push2 (n, xs) res;
);
-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 =
+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) ->
+ | NodeRef2 (n, xs) ->
f (n, xs) acc ;
!xs +> List.iter (aux (n::acc))
in
-let find_treeref_with_parents_some f tree =
+let find_treeref_with_parents_some f tree =
let res = ref [] in
- tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
+ tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
match f (n,xs) parents with
| Some v -> push2 v res;
| None -> ()
| [] -> raise Not_found
| x::y::zs -> raise Multi_found
-let find_multi_treeref_with_parents_some f tree =
+let find_multi_treeref_with_parents_some f tree =
let res = ref [] in
- tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
+ tree +> treeref_node_iter_with_parents (fun (n, xs) parents ->
match f (n,xs) parents with
| Some v -> push2 v res;
| None -> ()
match !res with
| [v] -> !res
| [] -> raise Not_found
- | x::y::zs -> !res
+ | x::y::zs -> !res
(*****************************************************************************)
(* Graph. Have a look too at Ograph_*.mli *)
(*****************************************************************************)
-(* todo: generalise to put in common (need 'edge (and 'c ?),
- * and take in param a display func, cos caml sux, no overloading of show :(
+(* todo: generalise to put in common (need 'edge (and 'c ?),
+ * and take in param a display func, cos caml sux, no overloading of show :(
* Simple impelemntation. Can do also matrix, or adjacent list, or pointer(ref)
* todo: do some check (dont exist already, ...)
*)
type 'node graph = ('node set) * (('node * 'node) set)
-let (add_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) ->
+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 (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) ->
+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) ->
+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) ->
+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) ->
+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 ->
+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)
+ | x::xs -> (f acc x)
+> (fun newacc -> fold_upward f (graph +> predecessors x) newacc graph)
- +> (fun newacc -> fold_upward f xs 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 ->
+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 ->
+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 (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 (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
let (get_free: 'a graph -> int) = function
(nodes, arcs) -> (maximum (List.map fst nodes))+1
-(* require no cycle !!
+(* 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 ->
+ (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 ->
+ (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
+ try
(* do 2 things, check same length and to assoc *)
- let conv = assoc_map nodes1 nodes2 in
- List.for_all (fun (i1,i2) ->
+ 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
+ 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 =
+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_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) ->
+ 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 " -> " ;
+ 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;
*)
(* todo: mettre diff(modulo = !!) en rouge *)
-let (display_dot2: 'a graph -> 'a graph -> ('a -> string) -> unit) =
+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 "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 "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";
- )
+ 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) ->
+ 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;
type color = vector (* color(0-1) *)
(* todo: factorise *)
-let (dotproduct: vector * vector -> float) =
+let (dotproduct: vector * vector -> float) =
fun ((x1,y1,z1),(x2,y2,z2)) -> (x1*.x2 +. y1*.y2 +. z1*.z2)
-let (vector_length: vector -> float) =
+let (vector_length: vector -> float) =
fun (x,y,z) -> sqrt (square x +. square y +. square z)
-let (minus_point: point * point -> vector) =
+let (minus_point: point * point -> vector) =
fun ((x1,y1,z1),(x2,y2,z2)) -> ((x1 -. x2),(y1 -. y2),(z1 -. z2))
-let (distance: point * point -> float) =
+let (distance: point * point -> float) =
fun (x1, x2) -> vector_length (minus_point (x2,x1))
-let (normalise: vector -> vector) =
- fun (x,y,z) ->
+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) =
+let (mult_coeff: vector -> float -> vector) =
fun (x,y,z) c -> (x *. c, y *. c, z *. c)
-let (add_vector: vector -> vector -> vector) =
+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) =
+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)
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 (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
+
+let test_ppm1 () = write_ppm 100 100
((generate (50*100) (1,45,100)) ++ (generate (50*100) (1,1,100)))
"img.ppm"
type diff = Match | BnotinA | AnotinB
let (diff: (int -> int -> diff -> unit)-> (string list * string list) -> unit)=
- fun f (xs,ys) ->
+ 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
+ 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 ->
+ 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 Impossible
)
-(*
-let _ =
- diff
+(*
+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")
+ [ "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) ->
+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 " ^
+ 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 ->
+ res +> List.iter (fun s ->
match s with
| "(" -> f !a !b Match; incr a; incr b;
| ">" -> f !a !b BnotinA; incr b;
(*****************************************************************************)
let parserCommon lexbuf parserer lexer =
- try
+ try
let result = parserer lexer lexbuf in
result
with Parsing.Parse_error ->
(* marche pas ca neuneu *)
(*
-let getDoubleParser parserer lexer string =
+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 =
+let getDoubleParser parserer lexer =
(
(function string ->
let lexbuf1 = Lexing.from_string string in
(*****************************************************************************)
(* cf parser_combinators.ml
- *
- * Could also use ocaml stream. but not backtrack and forced to do LL,
+ *
+ * Could also use ocaml stream. but not backtrack and forced to do LL,
* so combinators are better.
- *
+ *
*)
line: int;
column: int;
file: filename;
- }
+ }
(* with sexp *)
-let fake_parse_info = {
+let fake_parse_info = {
charpos = -1; str = "";
line = -1; column = -1; file = "";
}
-let string_of_parse_info x =
+let string_of_parse_info x =
spf "%s at %s:%d:%d" x.str x.file x.line x.column
-let string_of_parse_info_bis x =
+let string_of_parse_info_bis x =
spf "%s:%d:%d" x.file x.line x.column
-let (info_from_charpos2: int -> filename -> (int * int * string)) =
+let (info_from_charpos2: int -> filename -> (int * int * string)) =
fun charpos filename ->
(* Currently lexing.ml does not handle the line number position.
- * Even if there is some fields in the lexing structure, they are not
+ * Even if there is some fields in the lexing structure, they are not
* maintained by the lexing engine :( So the following code does not work:
- * let pos = Lexing.lexeme_end_p lexbuf in
- * sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum
- * (pos.pos_cnum - pos.pos_bol) in
+ * let pos = Lexing.lexeme_end_p lexbuf in
+ * sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum
+ * (pos.pos_cnum - pos.pos_bol) in
* Hence this function to overcome the previous limitation.
*)
let chan = open_in filename in
charpos_to_pos_aux !posl;
end
| None -> (!linen, charpos - !posl, "\n")
- in
+ in
let res = charpos_to_pos_aux 0 in
close_in chan;
res
-let info_from_charpos a b =
+let info_from_charpos a b =
profile_code "Common.info_from_charpos" (fun () -> info_from_charpos2 a b)
incr line;
(* '... +1 do' cos input_line dont return the trailing \n *)
- for i = 0 to (slength s - 1) + 1 do
+ for i = 0 to (slength s - 1) + 1 do
arr.(!charpos + i) <- (!line, i);
done;
charpos := !charpos + slength s + 1;
full_charpos_to_pos_aux();
-
- with End_of_file ->
+
+ with End_of_file ->
for i = !charpos to Array.length arr - 1 do
arr.(i) <- (!line, 0);
done;
();
- in
- begin
+ in
+ begin
full_charpos_to_pos_aux ();
close_in chan;
arr
end
let full_charpos_to_pos a =
profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a)
-
-let test_charpos file =
+
+let test_charpos file =
full_charpos_to_pos file +> dump +> pr2
-let complete_parse_info filename table x =
- { x with
+let complete_parse_info filename table x =
+ { x with
file = filename;
line = fst (table.(x.charpos));
column = snd (table.(x.charpos));
let size = (filesize filename + 2) in
(* old: let arr = Array.create size (0,0) in *)
- let arr1 = Bigarray.Array1.create
+ let arr1 = Bigarray.Array1.create
Bigarray.int Bigarray.c_layout size in
- let arr2 = Bigarray.Array1.create
+ let arr2 = Bigarray.Array1.create
Bigarray.int Bigarray.c_layout size in
Bigarray.Array1.fill arr1 0;
Bigarray.Array1.fill arr2 0;
let line = ref 0 in
let rec full_charpos_to_pos_aux () =
- try
let s = (input_line chan) in
incr line;
(* '... +1 do' cos input_line dont return the trailing \n *)
- for i = 0 to (slength s - 1) + 1 do
+ for i = 0 to (slength s - 1) + 1 do
(* old: arr.(!charpos + i) <- (!line, i); *)
arr1.{!charpos + i} <- (!line);
arr2.{!charpos + i} <- i;
done;
charpos := !charpos + slength s + 1;
- full_charpos_to_pos_aux();
-
- with End_of_file ->
- for i = !charpos to (* old: Array.length arr *)
- Bigarray.Array1.dim arr1 - 1 do
+ full_charpos_to_pos_aux() in
+ begin
+ (try
+ full_charpos_to_pos_aux ();
+ with End_of_file ->
+ for i = !charpos to (* old: Array.length arr *)
+ Bigarray.Array1.dim arr1 - 1 do
(* old: arr.(i) <- (!line, 0); *)
- arr1.{i} <- !line;
- arr2.{i} <- 0;
- done;
- ();
- in
- begin
- full_charpos_to_pos_aux ();
+ arr1.{i} <- !line;
+ arr2.{i} <- 0;
+ done;
+ ());
close_in chan;
(fun i -> arr1.{i}, arr2.{i})
end
let full_charpos_to_pos_large a =
- profile_code "Common.full_charpos_to_pos_large"
+ profile_code "Common.full_charpos_to_pos_large"
(fun () -> full_charpos_to_pos_large2 a)
-let complete_parse_info_large filename table x =
- { x with
+let complete_parse_info_large filename table x =
+ { x with
file = filename;
line = fst (table (x.charpos));
column = snd (table (x.charpos));
}
(*---------------------------------------------------------------------------*)
-(* Decalage is here to handle stuff such as cpp which include file and who
+(* Decalage is here to handle stuff such as cpp which include file and who
* can make shift.
*)
let (error_messagebis: filename -> (string * int) -> int -> string)=
fun filename (lexeme, lexstart) decalage ->
let charpos = lexstart + decalage in
- let tok = lexeme in
+ let tok = lexeme in
let (line, pos, linecontent) = info_from_charpos charpos filename in
sprintf "File \"%s\", line %d, column %d, charpos = %d
around = '%s', whole content = %s"
filename line pos charpos tok (chop linecontent)
-let error_message = fun filename (lexeme, lexstart) ->
- try error_messagebis filename (lexeme, lexstart) 0
+let error_message = fun filename (lexeme, lexstart) ->
+ try error_messagebis filename (lexeme, lexstart) 0
with
End_of_file ->
("PB in Common.error_message, position " ^ i_to_s lexstart ^
-let error_message_short = fun filename (lexeme, lexstart) ->
- try
+let error_message_short = fun filename (lexeme, lexstart) ->
+ try
let charpos = lexstart in
let (line, pos, linecontent) = info_from_charpos charpos filename in
sprintf "File \"%s\", line %d" filename line
- with End_of_file ->
+ with End_of_file ->
begin
("PB in Common.error_message, position " ^ i_to_s lexstart ^
" given out of file:" ^ filename);
end
-
+
(*****************************************************************************)
(* 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
+ * 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
+type score_result = Ok | Pb of string
(* with sexp *)
type score = (string (* usually a filename *), score_result) Hashtbl.t
(* with sexp *)
-let regression_testing_vs newscore bestscore =
+let regression_testing_vs newscore bestscore =
let newbestscore = empty_score () in
- let allres =
+ let allres =
(hash_to_list newscore +> List.map fst)
$+$
(hash_to_list bestscore +> List.map fst)
in
- begin
- allres +> List.iter (fun res ->
- match
+ begin
+ allres +> List.iter (fun res ->
+ match
optionise (fun () -> Hashtbl.find newscore res),
optionise (fun () -> Hashtbl.find bestscore res)
with
| None, None -> raise Impossible
- | Some x, None ->
+ | Some x, None ->
Printf.printf "new test file appeared: %s\n" res;
Hashtbl.add newbestscore res x;
- | None, Some x ->
+ | None, Some x ->
Printf.printf "old test file disappeared: %s\n" res;
- | Some newone, Some bestone ->
+ | Some newone, Some bestone ->
(match newone, bestone with
- | Ok, Ok ->
+ | Ok, Ok ->
Hashtbl.add newbestscore res Ok
- | Pb x, 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 ->
+ | Ok, Pb x ->
Printf.printf "Great: a test file now works: %s\n" res;
Hashtbl.add newbestscore res Ok
- | Pb x, Pb y ->
+ | Pb x, Pb y ->
Hashtbl.add newbestscore res (Pb x);
if not (x =$= y)
- then begin
+ then begin
Printf.printf
"Semipb: still error but not same error : %s\n" res;
Printf.printf "%s\n" (chop ("Old error: " ^ y));
newbestscore
end
-let regression_testing newscore best_score_file =
+let regression_testing newscore best_score_file =
pr2 ("regression file: "^ best_score_file);
- let (bestscore : score) =
+ let (bestscore : score) =
if not (Sys.file_exists best_score_file)
then write_value (empty_score()) best_score_file;
- get_value best_score_file
+ get_value best_score_file
in
let newbestscore = regression_testing_vs newscore bestscore in
write_value newbestscore (best_score_file ^ ".old");
-let string_of_score_result v =
- match v with
- | Ok -> "Ok"
+let string_of_score_result v =
+ match v with
+ | Ok -> "Ok"
| Pb s -> "Pb: " ^ s
-let total_scores score =
+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 =
+
+let print_total_score score =
pr2 "--------------------------------";
pr2 "total score";
pr2 "--------------------------------";
let (good, total) = total_scores score in
pr2 (sprintf "good = %d/%d" good total)
-let print_score score =
- score +> hash_to_list +> List.iter (fun (k, v) ->
+let print_score score =
+ score +> hash_to_list +> List.iter (fun (k, v) ->
pr2 (sprintf "% s --> %s" k (string_of_score_result v))
);
print_total_score score;
type ('a, 'b) scoped_env = ('a, 'b) assoc list
(*
-let rec lookup_env f env =
- match env with
+let rec lookup_env f env =
+ match env with
| [] -> raise Not_found
| []::zs -> lookup_env f zs
- | (x::xs)::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 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
+let rec lookup_env k env =
+ match env with
| [] -> raise Not_found
| []::zs -> lookup_env k zs
- | ((k',v)::xs)::zs ->
+ | ((k',v)::xs)::zs ->
if k =*= k'
- then v
+ then v
else lookup_env k (xs::zs)
-let member_env_key k env =
+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 =
+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
scoped_h = Hashtbl.create 101;
scoped_list = [[]];
}
-let clone_scoped_h_env x =
+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 rec lookup_h_env k env =
+ Hashtbl.find env.scoped_h k
-let member_h_env_key k env =
+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 =
+let new_scope_h scoped_env =
scoped_env := {!scoped_env with scoped_list = []::!scoped_env.scoped_list}
-let del_scope_h scoped_env =
+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 =
+ scoped_env := {!scoped_env with scoped_list =
List.tl !scoped_env.scoped_list
}
end
-let do_in_new_scope_h scoped_env f =
+let do_in_new_scope_h scoped_env f =
begin
new_scope_h scoped_env;
let res = f() in
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) =
+let add_in_scope_h x (k,v) =
begin
Hashtbl.add !x.scoped_h k v;
- x := { !x with scoped_list =
+ x := { !x with scoped_list =
((k,v)::(List.hd !x.scoped_list))::(List.tl !x.scoped_list);
};
end
(* let ansi_terminal = ref true *)
-let (_execute_and_show_progress_func: (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref)
- = ref
- (fun a b ->
+let (_execute_and_show_progress_func: (int (* length *) -> ((unit -> unit) -> unit) -> unit) ref)
+ = ref
+ (fun a b ->
failwith "no execute yet, have you included common_extra.cmo?"
)
-
+
let execute_and_show_progress len f =
!_execute_and_show_progress_func len f
let _init_random = Random.self_init ()
(*
-let random_insert i l =
+let random_insert i l =
let p = Random.int (length l +1)
- in let rec insert i p l =
+ 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
+let rec randomize_list = function
[] -> []
| a::l -> random_insert a (randomize_list l)
*)
-let random_list xs =
- List.nth xs (Random.int (length xs))
+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)
+ * 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)
+ * while (--n > 0)
* {
* int k = rng.nextInt(n + 1); // 0 <= k <= n (!)
* int temp = array[n];
* }
*)
-let randomize_list xs =
+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 h = Hashtbl.create 101 in
let cnt = ref num in
while !cnt > 0 do
let x = Random.int len in
(* Flags and actions *)
(*****************************************************************************)
-(* I put it inside a func as it can help to give a chance to
- * change the globals before getting the options as some
+(* 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 () =
+let cmdline_flags_devel () =
[
- "-debugger", Arg.Set debugger ,
+ "-debugger", Arg.Set debugger ,
" option to set if launched inside ocamldebug";
- "-profile", Arg.Unit (fun () -> profile := PALL),
+ "-profile", Arg.Unit (fun () -> profile := PALL),
" gather timing information about important functions";
]
let cmdline_flags_verbose () =
[
- "-verbose_level", Arg.Set_int verbose_level,
+ "-verbose_level", Arg.Set_int verbose_level,
" <int> guess what";
- "-disable_pr2_once", Arg.Set disable_pr2_once,
+ "-disable_pr2_once", Arg.Set disable_pr2_once,
" to print more messages";
- "-show_trace_profile", Arg.Set show_trace_profile,
+ "-show_trace_profile", Arg.Set show_trace_profile,
" show trace";
]
-let cmdline_flags_other () =
+let cmdline_flags_other () =
[
- "-nocheck_stack", Arg.Clear check_stack,
+ "-nocheck_stack", Arg.Clear check_stack,
" ";
"-batch_mode", Arg.Set _batch_mode,
" no interactivity"
]
(* potentially other common options but not yet integrated:
-
- "-timeout", Arg.Set_int timeout,
+
+ "-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 () ->
+ "-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 () ->
+ "-shorthelp", Arg.Unit (fun () ->
!short_usage_func();
raise (Common.UnixExit 0)
- ),
+ ),
" see short list of options";
- "-longhelp", Arg.Unit (fun () ->
+ "-longhelp", Arg.Unit (fun () ->
!long_usage_func();
raise (Common.UnixExit 0)
- ),
- "-help", Arg.Unit (fun () ->
+ ),
+ "-help", Arg.Unit (fun () ->
!long_usage_func();
raise (Common.UnixExit 0)
),
" ";
- "--help", Arg.Unit (fun () ->
+ "--help", Arg.Unit (fun () ->
!long_usage_func();
raise (Common.UnixExit 0)
),
*)
-let cmdline_actions () =
+let cmdline_actions () =
[
"-test_check_stack", " <limit>",
mk_action_1_arg test_check_stack_size;
(*****************************************************************************)
(* 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 (+>) = (+>)
end
-let main_boilerplate f =
- if not (!Sys.interactive) then
- exn_to_real_unixexit (fun () ->
+let main_boilerplate f =
+ if not (!Sys.interactive) then
+ exn_to_real_unixexit (fun () ->
- Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ ->
+ Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ ->
pr2 "C-c intercepted, will do some cleaning before exiting";
(* But if do some try ... with e -> and if do not reraise the exn,
* the bubble never goes at top and so I cant really C-c.
- *
+ *
* A solution would be to not raise, but do the erase_temp_file in the
* syshandler, here, and then exit.
* The current solution is to not do some wild try ... with e
));
(* The finalize below makes it tedious to go back to exn when use
- * 'back' in the debugger. Hence this special case. But the
- * Common.debugger will be set in main(), so too late, so
+ * 'back' in the debugger. Hence this special case. But the
+ * Common.debugger will be set in main(), so too late, so
* have to be quicker
*)
if Sys.argv +> Array.to_list +> List.exists (fun x -> x =$= "-debugger")
then debugger := true;
- finalize (fun ()->
- pp_do_in_zero_box (fun () ->
+ finalize (fun ()->
+ pp_do_in_zero_box (fun () ->
f(); (* <---- here it is *)
))
- (fun()->
- if !profile <> PNONE
+ (fun()->
+ if !profile <> PNONE
then pr2 (profile_diagnostic ());
erase_temp_files ();
)
(Filename.quote s)
in
match cmd_to_list com with
- | [s] ->
+ | [s] ->
(*pr2 s;*)
s
| _ -> failwith "md5sum_of_string wrong output"
-let with_pr2_to_string f =
+let with_pr2_to_string f =
let file = new_temp_file "pr2" "out" in
redirect_stdout_stderr file f;
cat file
(* Misc/test *)
(*****************************************************************************)
-let (generic_print: 'a -> string -> string) = fun v typ ->
+let (generic_print: 'a -> string -> string) = fun v typ ->
write_value v "/tmp/generic_print";
- command2
+ command2
("printf 'let (v:" ^ typ ^ ")= Common.get_value \"/tmp/generic_print\" " ^
" in v;;' " ^
- " | calc.top > /tmp/result_generic_print");
- cat "/tmp/result_generic_print"
+ " | 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
+ +> (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) =
val xs = ys
method view = xs
(* method fold f a = List.fold_left f a xs *)
- method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b =
+ 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 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
HCoop / bpt / coccinelle.git / blobdiff