From 16acf1fe899962a26f046c9d4e28ff7255b9f074 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sun, 14 Jul 2019 18:50:44 +0200 Subject: [PATCH] Removed core --- ocaml/.merlin | 2 +- ocaml/Block.ml | 77 +++++----- ocaml/Command_line.ml | 199 +++++++++++++++++++++++++ ocaml/Command_line.mli | 126 ++++++++++++++++ ocaml/Default.ml | 5 +- ocaml/Input.ml | 79 +++++----- ocaml/Launcher.ml | 25 ++-- ocaml/Makefile | 58 ++++++++ ocaml/QmcMd5.ml | 26 ++-- ocaml/Qmcchem_config.ml | 70 ++++----- ocaml/Qmcchem_edit.ml | 245 ++++++++++++++++++------------- ocaml/Qputils.ml | 17 +-- ocaml/Random_variable.ml | 94 ++++++------ ocaml/Sample.ml | 9 +- ocaml/Sample.mli | 2 - ocaml/Scheduler.ml | 10 +- ocaml/String_ext.ml | 160 ++++++++++++++++++++ ocaml/Watchdog.ml | 47 +++--- ocaml/_tags | 6 + ocaml/build.ninja | 84 ----------- ocaml/c_bindings.c | 70 +++++++++ ocaml/myocamlbuild.ml | 13 ++ ocaml/qptypes_generator.ml | 294 ++++++++++++++++++++----------------- 23 files changed, 1162 insertions(+), 556 deletions(-) create mode 100644 ocaml/Command_line.ml create mode 100644 ocaml/Command_line.mli create mode 100644 ocaml/Makefile create mode 100644 ocaml/String_ext.ml create mode 100644 ocaml/_tags delete mode 100644 ocaml/build.ninja create mode 100644 ocaml/c_bindings.c create mode 100644 ocaml/myocamlbuild.ml diff --git a/ocaml/.merlin b/ocaml/.merlin index 5f0f9d7..fd9db52 100644 --- a/ocaml/.merlin +++ b/ocaml/.merlin @@ -1,3 +1,3 @@ -PKG core cryptokit str zmq +PKG cryptokit str zmq S . diff --git a/ocaml/Block.ml b/ocaml/Block.ml index afb181c..1ab83f5 100644 --- a/ocaml/Block.ml +++ b/ocaml/Block.ml @@ -1,4 +1,3 @@ -open Core open Qptypes type t = @@ -6,7 +5,7 @@ type t = value : Sample.t ; weight : Weight.t ; compute_node : Compute_node.t ; - pid : Pid.t ; + pid : int ; block_id : Block_id.t ; } @@ -23,17 +22,17 @@ let of_string s = match lst with | b :: pid :: c:: p :: w :: v :: [] -> Some { property = Property.of_string p ; - value = Sample.of_float (Float.of_string v) ; - weight = Weight.of_float (Float.of_string w) ; + value = Sample.of_float (float_of_string v) ; + weight = Weight.of_float (float_of_string w) ; compute_node = Compute_node.of_string c; - pid = Pid.of_string pid; - block_id = Block_id.of_int (Int.of_string b) ; + pid = int_of_string pid; + block_id = Block_id.of_int (int_of_string b) ; } | b :: pid :: c:: p :: w :: v -> let v = List.rev v |> Array.of_list - |> Array.map ~f:Float.of_string + |> Array.map float_of_string in let dim = Array.length v @@ -41,10 +40,10 @@ let of_string s = Some { property = Property.of_string p ; value = Sample.of_float_array ~dim v ; - weight = Weight.of_float (Float.of_string w) ; + weight = Weight.of_float (float_of_string w) ; compute_node = Compute_node.of_string c; - pid = Pid.of_string pid; - block_id = Block_id.of_int (Int.of_string b) ; + pid = int_of_string pid; + block_id = Block_id.of_int (int_of_string b) ; } | _ -> None with @@ -55,10 +54,10 @@ let of_string s = let to_string b = Printf.sprintf "%s %s # %s %s %s %d" (Sample.to_string b.value ) - (Weight.to_float b.weight |> Float.to_string) + (Weight.to_float b.weight |> string_of_float) (Property.to_string b.property) (Compute_node.to_string b.compute_node) - (Pid.to_string b.pid) + (string_of_int b.pid) (Block_id.to_int b.block_id) @@ -70,8 +69,8 @@ let dir_name = lazy( let md5 = QmcMd5.hash () in - List.fold_right ~init:"" ~f:Filename.concat - [ ezfio_filename ; "blocks" ; md5 ; Filename.dir_sep ] + List.fold_right Filename.concat + [ ezfio_filename ; "blocks" ; md5 ; Filename.dir_sep ] "" ) @@ -87,29 +86,31 @@ let update_raw_data ?(locked=true) () = in let files = let result = - match Sys.is_directory dir_name with - | `Yes -> + if Sys.is_directory dir_name then begin Sys.readdir dir_name - |> Array.map ~f:(fun x -> dir_name^x) + |> Array.map (fun x -> dir_name^x) |> Array.to_list end - | _ -> [] + else [] in if locked then result else - List.filter result ~f:(fun x -> - match String.substr_index ~pattern:"locked" x with - | Some x -> false - | None -> true - ) + List.filter (fun x -> + try + let _ = + Str.search_backward (Str.regexp "locked") x ((String.length x) - 1) + in false + with + | Not_found -> true + ) result in let rec transform new_list = function | [] -> new_list | head :: tail -> - let head = String.strip head in + let head = String.trim head in let item = of_string head in match item with | None -> transform new_list tail @@ -117,14 +118,19 @@ let update_raw_data ?(locked=true) () = in let result = - List.map files ~f:(fun filename -> - In_channel.with_file filename ~f:(fun in_channel -> - In_channel.input_all in_channel) - ) - |> String.concat - |> String.split_lines - |> List.rev - |> transform [] + let rec aux ic accu = + try + aux ic ( (input_line ic)::accu ) + with + | End_of_file -> List.rev accu + in + List.map (fun filename -> + let ic = open_in filename in + let result = aux ic [] in + close_in ic; + result ) files + |> List.concat + |> transform [] in result @@ -141,10 +147,11 @@ let raw_data ?(locked=true) () = +module StringSet = Set.Make(String) + let properties = lazy ( - let set = Set.Poly.empty in - List.fold (raw_data ()) ~init:set ~f:(fun s x -> Set.add s x.property) - |> Set.to_list + List.fold_left (fun s x -> StringSet.add (Property.to_string x.property) s) StringSet.empty (raw_data ()) + |> StringSet.elements ) diff --git a/ocaml/Command_line.ml b/ocaml/Command_line.ml new file mode 100644 index 0000000..1dd5789 --- /dev/null +++ b/ocaml/Command_line.ml @@ -0,0 +1,199 @@ +type short_opt = char +type long_opt = string +type optional = Mandatory | Optional +type documentation = string +type argument = With_arg of string | Without_arg | With_opt_arg of string + +type description = { + short: short_opt ; + long : long_opt ; + opt : optional ; + doc : documentation ; + arg : argument ; + } + +let anon_args = ref [] +and header_doc = ref "" +and description_doc = ref "" +and footer_doc = ref "" +and specs = ref [] + +let set_header_doc s = header_doc := s +let set_description_doc s = description_doc := s +let set_footer_doc s = footer_doc := s + +(* Hash table containing all the options *) +let dict = Hashtbl.create 67 + +let get_bool x = Hashtbl.mem dict x + +let show_help () = get_bool "help" + +let get x = + try Some (Hashtbl.find dict x) + with Not_found -> None + +let anonymous name opt doc = + { short=' ' ; long=name; opt; doc; arg=Without_arg; } + +let output_text t = + Format.printf "@["; + begin + match Str.split (Str.regexp "\n") t with + | x :: [] -> Format.printf "@["; + Str.split (Str.regexp " ") x + |> List.iter (fun y -> Format.printf "@[%s@]@ " y) ; + Format.printf "@]" + | t -> List.iter (fun x -> + Format.printf "@["; + Str.split (Str.regexp " ") x + |> List.iter (fun y -> Format.printf "@[%s@]@ " y) ; + Format.printf "@]@;") t + end; + Format.printf "@]" +;; + + +let output_short x = + match x.short, x.opt, x.arg with + | ' ', Mandatory, _ -> Format.printf "@[%s@]" x.long + | ' ', Optional , _ -> Format.printf "@[[%s]@]" x.long + | _ , Mandatory, Without_arg -> Format.printf "@[-%c@]" x.short + | _ , Optional , Without_arg -> Format.printf "@[[-%c]@]" x.short + | _ , Mandatory, With_arg arg -> Format.printf "@[-%c %s@]" x.short arg + | _ , Optional , With_arg arg -> Format.printf "@[[-%c %s]@]" x.short arg + | _ , Mandatory, With_opt_arg arg -> Format.printf "@[-%c [%s]@]" x.short arg + | _ , Optional , With_opt_arg arg -> Format.printf "@[[-%c [%s]]@]" x.short arg + + +let output_long max_width x = + let arg = + match x.short, x.arg with + | ' ' , _ -> x.long + | _ , Without_arg -> x.long + | _ , With_arg arg -> Printf.sprintf "%s=%s" x.long arg + | _ , With_opt_arg arg -> Printf.sprintf "%s[=%s]" x.long arg + in + let long = + let l = String.length arg in + arg^(String.make (max_width-l) ' ') + in + Format.printf "@["; + begin + match x.short with + | ' ' -> Format.printf "@[%s @]" long + | short -> Format.printf "@[-%c --%s @]" short long + end; + Format.printf "@]"; + output_text x.doc + + +let help () = + + (* Print the header *) + output_text !header_doc; + Format.printf "@.@."; + + (* Find the anonymous arguments *) + let anon = + List.filter (fun x -> x.short = ' ') !specs + in + + (* Find the options *) + let options = + List.filter (fun x -> x.short <> ' ') !specs + |> List.sort (fun x y -> Char.compare x.short y.short) + in + + (* Find column lengths *) + let max_width = + List.map (fun x -> + ( match x.arg with + | Without_arg -> String.length x.long + | With_arg arg -> String.length x.long + String.length arg + | With_opt_arg arg -> String.length x.long + String.length arg + 2 + ) + + ( if x.opt = Optional then 2 else 0) + ) !specs + |> List.fold_left max 0 + in + + + (* Print usage *) + Format.printf "@[@[Usage:@,@,@[@[%s@]" Sys.argv.(0); + List.iter (fun x -> Format.printf "@ "; output_short x) options; + Format.printf "@ @[[--]@]"; + List.iter (fun x -> Format.printf "@ "; output_short x;) anon; + Format.printf "@]@,@]@,"; + + + (* Print arguments and doc *) + Format.printf "@[Arguments:@,"; + Format.printf "@[" ; + List.iter (fun x -> Format.printf "@ "; output_long max_width x) anon; + Format.printf "@]@,@]@,"; + + + (* Print options and doc *) + Format.printf "@[Options:@,"; + + Format.printf "@[" ; + List.iter (fun x -> Format.printf "@ "; output_long max_width x) options; + Format.printf "@]@,@]@,"; + + + (* Print footer *) + if !description_doc <> "" then + begin + Format.printf "@[Description:@,@,"; + output_text !description_doc; + Format.printf "@," + end; + + (* Print footer *) + output_text !footer_doc; + Format.printf "@." + + + +let set_specs specs_in = + specs := { short='h' ; + long ="help" ; + doc ="Prints the help message." ; + arg =Without_arg ; + opt =Optional ; + } :: specs_in; + + let cmd_specs = + List.filter (fun x -> x.short != ' ') !specs + |> List.map (fun { short ; long ; opt ; doc ; arg } -> + match arg with + | With_arg _ -> + (short, long, None, Some (fun x -> Hashtbl.replace dict long x) ) + | Without_arg -> + (short, long, Some (fun () -> Hashtbl.replace dict long ""), None) + | With_opt_arg _ -> + (short, long, Some (fun () -> Hashtbl.replace dict long ""), + Some (fun x -> Hashtbl.replace dict long x) ) + ) + in + + Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]); + + if show_help () then + (help () ; exit 0); + + (* Check that all mandatory arguments are set *) + List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs + |> List.iter (fun x -> + match get x.long with + | Some _ -> () + | None -> failwith ("Error: --"^x.long^" option is missing.") + ) +;; + + +let anon_args () = !anon_args + + + diff --git a/ocaml/Command_line.mli b/ocaml/Command_line.mli new file mode 100644 index 0000000..9f6e702 --- /dev/null +++ b/ocaml/Command_line.mli @@ -0,0 +1,126 @@ +(** Handles command-line arguments, using getopt. + +Example: + +let () = + + (* Command-line specs *) + let open Command_line in + begin + set_header_doc (Sys.argv.(0) ^ " - quantum_package command"); + set_description_doc + "Opens a text editor to edit the parameters of an EZFIO directory."; + + [ { short='c'; long="check"; opt=Optional; + doc="Checks the input data"; + arg=Without_arg; }; + + { short='n'; long="ndet"; opt=Optional; + doc="Truncate the wavefunction to the target number of determinants"; + arg=With_arg ""; }; + + { short='s'; long="state"; opt=Optional; + doc="Extract selected states, for example \"[1,3-5]\""; + arg=With_arg ""; }; + + anonymous "EZFIO_DIR" Mandatory "EZFIO directory"; + ] + |> set_specs ; + + end; + + + (* Handle options *) + let ndet = + match Command_line.get "ndet" with + | None -> None + | Some s -> (try Some (int_of_string s) + with _ -> failwith "[-n|--ndet] expects an integer") + in + let state = + match Command_line.get "state" with + | None -> None + | Some s -> (try Some (Range.of_string s) + with _ -> failwith "[-s|--state] expects a range") + in + + let c = Command_line.get_bool "check" in + + let filename = + match Command_line.anon_args () with + | [x] -> x + | _ -> (Command_line.help () ; failwith "EZFIO_DIR is missing") + in + + (* Run the program *) + run c ?ndet ?state filename + + +*) + + +type short_opt = char + +type long_opt = string + +type optional = Mandatory + | Optional + +type documentation = string + +type argument = With_arg of string + | Without_arg + | With_opt_arg of string + + +type description = +{ + short : short_opt; + long : long_opt; + opt : optional; + doc : documentation; + arg : argument; +} + + +(** Sets the header of the help message. *) +val set_header_doc : string -> unit + + +(** Sets the description of the help message. *) +val set_description_doc : string -> unit + +(** Sets the footer of the help message. *) +val set_footer_doc : string -> unit + + +(** Gets the value of an option. If the option is not set, returns [None]. If + the option is set, returns Some . *) +val get : string -> string option + + +(** Gets the value of an option with no argument. If the option is set, returns [true]. *) +val get_bool : string -> bool + + +(** True if the '-h' or "--help" option was found. *) +val show_help : unit -> bool + + +(** Creates a specification of an anonymous argument. *) +val anonymous : long_opt -> optional -> documentation -> description + + +(** Prints the help message *) +val help : unit -> unit + + +(** Sets the specification list as a list of tuples: + ( short option, long option, documentation, argument ) *) +val set_specs : description list -> unit + + +(** Returns the list of anonymous arguments *) +val anon_args : unit -> string list + + diff --git a/ocaml/Default.ml b/ocaml/Default.ml index c0c3dce..e29a885 100644 --- a/ocaml/Default.ml +++ b/ocaml/Default.ml @@ -1,6 +1,3 @@ -open Core - - let simulation_nucl_fitcusp_factor = lazy( let default = 1. @@ -26,7 +23,7 @@ let simulation_time_step = lazy ( 0.15 ) let simulation_srmc_projection_time = lazy ( 1. ) let reset_defaults () = - List.iter ~f:(fun x -> Sys.remove ( (Lazy.force Qputils.ezfio_filename) ^ x)) + List.iter (fun x -> Sys.remove ( (Lazy.force Qputils.ezfio_filename) ^ x)) [ "/electrons/elec_walk_num" ; "/electrons/elec_walk_num_tot" ; "/jastrow/jast_type" ; diff --git a/ocaml/Input.ml b/ocaml/Input.ml index 028acc2..ae0fd10 100644 --- a/ocaml/Input.ml +++ b/ocaml/Input.ml @@ -1,4 +1,3 @@ -open Core open Qptypes open Qputils @@ -38,13 +37,13 @@ end = struct let to_string t = to_bool t - |> Bool.to_string + |> string_of_bool let of_string t = try - String.lowercase t - |> Bool.of_string + String.lowercase_ascii t + |> bool_of_string |> of_bool with | Invalid_argument msg -> failwith msg @@ -119,12 +118,12 @@ Fit is done for r < r_c(f) where r_c(f) = (1s orbital radius) x f. Value of f" let to_string t = to_float t - |> Float.to_string + |> string_of_float let of_string t = try - Float.of_string t + float_of_string t |> of_float with | Invalid_argument msg -> failwith msg @@ -181,21 +180,21 @@ end = struct let to_string t = to_int t - |> Int.to_string + |> string_of_int let of_string t = - Int.of_string t + int_of_string t |> of_int let to_float t = to_int t - |> Float.of_int + |> float_of_int let of_float t = - Int.of_float t + int_of_float t |> of_int @@ -248,11 +247,11 @@ end = struct let to_string t = to_int t - |> Int.to_string + |> string_of_int let of_string t = - Int.of_string t + int_of_string t |> of_int @@ -305,11 +304,11 @@ end = struct let to_string t = to_int t - |> Int.to_string + |> string_of_int let of_string t = - Int.of_string t + int_of_string t |> of_int @@ -364,21 +363,21 @@ end = struct let to_string t = to_int t - |> Int.to_string + |> string_of_int let of_string t = - Int.of_string t + int_of_string t |> of_int let to_float t = to_int t - |> Float.of_int + |> float_of_int let of_float t = - Int.of_float t + int_of_float t |> of_int end @@ -456,7 +455,7 @@ end = struct let doc = "Sampling algorithm : [ Langevin | Brownian ]" let of_string s = - match String.capitalize (String.strip s) with + match String.capitalize_ascii (String.trim s) with | "Langevin" -> Langevin | "Brownian" -> Brownian | x -> failwith ("Sampling should be [ Brownian | Langevin ], not "^x^".") @@ -536,13 +535,13 @@ end = struct let of_string x = - Float.of_string x + float_of_string x |> of_float let to_string x = to_float x - |> Float.to_string + |> string_of_float end @@ -593,13 +592,13 @@ end = struct let of_string x = - Float.of_string x + float_of_string x |> of_float let to_string x = to_float x - |> Float.to_string + |> string_of_float end @@ -652,13 +651,13 @@ contribution to the norm less than t (au)" let of_string x = - Float.of_string x + float_of_string x |> of_float let to_string x = to_float x - |> Float.to_string + |> string_of_float end @@ -708,13 +707,13 @@ end = struct let of_string x = - Float.of_string x + float_of_string x |> of_float let to_string x = to_float x - |> Float.to_string + |> string_of_float end @@ -764,13 +763,13 @@ end = struct let of_string x = - Float.of_string x + float_of_string x |> of_float let to_string x = to_float x - |> Float.to_string + |> string_of_float end @@ -789,7 +788,7 @@ end = struct let doc = "Type of Jastrow factor [ None | Core | Simple ]" let of_string s = - match String.capitalize (String.strip s) with + match String.capitalize (String.trim s) with | "Core" -> Core | "Simple" -> Simple | "None" -> None @@ -841,31 +840,31 @@ end = struct let read () = - List.map Property.all ~f:(fun x -> (x, Property.calc x)) + List.map (fun x -> (x, Property.calc x)) Property.all let write l = - List.iter l ~f:(fun (x,b) -> Property.set_calc x b) + List.iter (fun (x,b) -> Property.set_calc x b) l let to_string l = - List.map l ~f:(fun (x,b) -> + List.map (fun (x,b) -> let ch = if b then "X" else " " in - Printf.sprintf "(%s) %s" ch (Property.to_string x)) - |> String.concat ~sep:"\n" + Printf.sprintf "(%s) %s" ch (Property.to_string x)) l + |> String.concat "\n" let of_string s = - String.split s ~on:'\n' - |> List.map ~f:(fun x -> + String.split_on_char '\n' s + |> List.map (fun x -> let (calc,prop) = - String.strip x - |> String.rsplit2_exn ~on:' ' + String.trim x + |> String_ext.rsplit2_exn ~on:' ' in let prop = - String.strip prop + String.trim prop |> Property.of_string and calc = match calc with diff --git a/ocaml/Launcher.ml b/ocaml/Launcher.ml index a06ff93..5e84d2b 100644 --- a/ocaml/Launcher.ml +++ b/ocaml/Launcher.ml @@ -1,5 +1,3 @@ -open Core - type t = | Srun | MPI @@ -50,19 +48,21 @@ let create_nodefile () = in let h = - String.Table.create ~size:1000 () + Hashtbl.create 1000 in let in_channel = Unix.open_process_in (launcher_command^" hostname -s") in - In_channel.input_lines in_channel - |> List.map ~f:String.strip - |> List.iter ~f:( fun host -> - Hashtbl.change h host (function - | Some x -> Some (x+1) - | None -> Some 1 - ) + String_ext.input_lines in_channel + |> List.map String.trim + |> List.iter ( fun host -> + let n = + match Hashtbl.find_opt h host with + | Some x -> x+1 + | None -> 1 + in + Hashtbl.replace h host n ); match Unix.close_process_in in_channel @@ -80,9 +80,8 @@ let create_nodefile () = fun (node, n) -> Printf.sprintf "%s %d\n" node n in - Hashtbl.to_alist h - |> List.map ~f - |> String.concat + Hashtbl.fold (fun k v a -> (f (k,v)) :: a) h [] + |> String.concat "\n" diff --git a/ocaml/Makefile b/ocaml/Makefile new file mode 100644 index 0000000..e299203 --- /dev/null +++ b/ocaml/Makefile @@ -0,0 +1,58 @@ +.NOPARALLEL: + +# Check if QMCCHEM_PATH is defined +ifndef QMCCHEM_PATH +$(info -------------------- Error --------------------) +$(info QMCCHEM_PATH undefined. Source the qmcchem.rc script) +$(info -----------------------------------------------) +$(error ) +endif + + +LIBS= +PKGS= +OCAMLCFLAGS="-g" +OCAMLOPTFLAGS="opt -O3 -remove-unused-arguments -rounds 16 -inline 100 -inline-max-unroll 100" +OCAMLBUILD=ocamlbuild -j 0 -cflags $(OCAMLCFLAGS) -lflags $(OCAMLCFLAGS) -ocamlopt $(OCAMLOPTFLAGS) +MLLFILES=$(wildcard *.mll) +MLFILES=$(wildcard *.ml) ezfio.ml Qptypes.ml +MLIFILES=$(wildcard *.mli) +ALL_TESTS=$(patsubst %.ml,%.byte,$(wildcard test_*.ml)) +ALL_EXE=$(patsubst %.ml,%.native,$(wildcard qp_*.ml)) qmcchem.native + +.PHONY: default + + +default: $(ALL_EXE) +tests: $(ALL_TESTS) + + +%.inferred.mli: $(MLFILES) + $(OCAMLBUILD) $*.inferred.mli -use-ocamlfind $(PKGS) + mv _build/$*.inferred.mli . + +%.byte: $(MLFILES) $(MLIFILES) + rm -f -- $* + $(OCAMLBUILD) $*.byte -use-ocamlfind $(PKGS) + ln -s $*.byte $* + +%.native: $(MLFILES) $(MLIFILES) + rm -f -- $* + $(OCAMLBUILD) $*.native -use-ocamlfind $(PKGS) + ln -s $*.native $* + +ezfio.ml: ${QMCCHEM_PATH}/EZFIO/Ocaml/ezfio.ml + cp ${QMCCHEM_PATH}/EZFIO/Ocaml/ezfio.ml . + +qptypes_generator.byte: qptypes_generator.ml + $(OCAMLBUILD) qptypes_generator.byte -use-ocamlfind + +Qptypes.ml: qptypes_generator.byte + ./qptypes_generator.byte > Qptypes.ml + +${QMCCHEM_PATH}/EZFIO/Ocaml/ezfio.ml: + ${MAKE) -C ${QMCCHEM_PATH}/EZFIO/ + +clean: + rm -rf _build Qptypes.ml $(ALL_EXE) $(ALL_TESTS) + diff --git a/ocaml/QmcMd5.ml b/ocaml/QmcMd5.ml index fa177f1..ab1fdd8 100644 --- a/ocaml/QmcMd5.ml +++ b/ocaml/QmcMd5.ml @@ -1,5 +1,3 @@ -open Core - (** Directory containing the list of input files. The directory is created is inexistant. *) let input_directory = lazy ( @@ -12,9 +10,8 @@ let input_directory = lazy ( in begin - match ( Sys.is_directory dirname ) with - | `No -> Unix.mkdir dirname - | _ -> () + if not (Sys.is_directory dirname) then + Unix.mkdir dirname 0o777 end ; dirname @@ -83,14 +80,17 @@ let files_to_track = [ (** Get an MD5 ke from the content of a file. *) let hash_file filename = - match Sys.is_file filename with - | `Yes -> + if Sys.file_exists filename then begin - In_channel.with_file filename ~f:(fun ic -> + let ic = open_in filename in + let result = Cryptokit.hash_channel (Cryptokit.Hash.md5 ()) ic - |> Cryptokit.transform_string (Cryptokit.Hexa.encode ()) ) + |> Cryptokit.transform_string (Cryptokit.Hexa.encode ()) + in + close_in ic; + result end - | _ -> "" + else "" (** Cache containing the current value of the MD5 hash. *) @@ -111,9 +111,9 @@ let hash () = in let md5_string = files_to_track - |> List.map ~f:(fun x -> Printf.sprintf "%s/%s" ezfio_filename x) - |> List.map ~f:hash_file - |> String.concat + |> List.map (fun x -> Printf.sprintf "%s/%s" ezfio_filename x) + |> List.map hash_file + |> String.concat "" in let new_md5 = diff --git a/ocaml/Qmcchem_config.ml b/ocaml/Qmcchem_config.ml index 3a82387..ac88031 100644 --- a/ocaml/Qmcchem_config.ml +++ b/ocaml/Qmcchem_config.ml @@ -1,22 +1,18 @@ -open Core - (** QMC=Chem installation directory *) let root = lazy ( - match ( Sys.getenv "QMCCHEM_PATH" ) with - | Some x -> x - | None -> failwith "QMCCHEM_PATH environment variable not set" + try Sys.getenv "QMCCHEM_PATH" with + | Not_found -> failwith "QMCCHEM_PATH environment variable not set" ) (* PATH environment variable as a list of strings *) let path = lazy ( let p = - match Sys.getenv "PATH" with - | None -> failwith "PATH environment variable is not set" - | Some p -> p + try Sys.getenv "PATH" with + | Not_found -> failwith "PATH environment variable is not set" in - String.split ~on:':' p + String.split_on_char ':' p ) @@ -30,9 +26,10 @@ let full_path exe = let fp = Filename.concat head exe in - match (Sys.is_file fp) with - | `Yes -> Some fp - | _ -> in_path_rec tail + if Sys.file_exists fp then + Some fp + else + in_path_rec tail end in Lazy.force path @@ -42,7 +39,7 @@ let full_path exe = (* True if an executable is in the PATH *) let in_path x = - match (full_path x) with + match full_path x with | Some _ -> true | None -> false @@ -51,13 +48,13 @@ let has_parallel = lazy( in_path "parallel" ) let has_mpirun = lazy( in_path "mpirun" ) let has_srun = lazy( in_path "parallel" ) let has_qmc = lazy( in_path "qmc" ) -let has_qmc_mic = lazy( in_path "qmc_mic" ) let mpirun = lazy ( - match Sys.getenv "QMCCHEM_MPIRUN" with - | None -> "mpirun" - | Some p -> p + try + Sys.getenv "QMCCHEM_MPIRUN" + with + | Not_found -> "mpirun" ) let qmcchem = lazy( @@ -69,9 +66,7 @@ and qmc = lazy( and qmcchem_info = lazy( Filename.concat (Lazy.force root) "bin/qmcchem_info" ) -and qmc_mic = lazy( - Filename.concat (Lazy.force root) "bin/qmc_mic" -) + and qmc_create_walkers = lazy( Filename.concat (Lazy.force root) "bin/qmc_create_walkers" ) @@ -87,28 +82,35 @@ let hostname = lazy ( ) +external get_ipv4_address_for_interface : string -> string = + "get_ipv4_address_for_interface" + + let ip_address = lazy ( - match Sys.getenv "QMCCHEM_NIC" with - | None -> + let interface = + try Some (Sys.getenv "QMCCHEM_NIC") + with Not_found -> None + in + match interface with + | None -> begin try - Lazy.force hostname - |> Unix.Inet_addr.of_string_or_getbyname - |> Unix.Inet_addr.to_string + let host = + Lazy.force hostname + |> Unix.gethostbyname + in + Unix.string_of_inet_addr host.h_addr_list.(0); with | Unix.Unix_error _ -> failwith "Unable to find IP address from host name." end | Some interface -> - begin - try - ok_exn Linux_ext.get_ipv4_address_for_interface interface - with - | Unix.Unix_error _ -> - Lazy.force hostname - |> Unix.Inet_addr.of_string_or_getbyname - |> Unix.Inet_addr.to_string - end + let result = get_ipv4_address_for_interface interface in + if String.sub result 0 5 = "error" then + Printf.sprintf "Unable to use network interface %s" interface + |> failwith + else + result ) diff --git a/ocaml/Qmcchem_edit.ml b/ocaml/Qmcchem_edit.ml index d3f9832..3820c57 100644 --- a/ocaml/Qmcchem_edit.ml +++ b/ocaml/Qmcchem_edit.ml @@ -1,5 +1,3 @@ -open Core - let file_header filename = Printf.sprintf " +----------------------------------------------------------------+ @@ -12,7 +10,7 @@ Editing file `%s` let make_header s = let l = String.length s in - "\n\n"^s^"\n"^(String.init l ~f:(fun _ -> '='))^"\n\n" + "\n\n"^s^"\n"^(String.init l (fun _ -> '='))^"\n\n" type field = @@ -84,11 +82,11 @@ let create_temp_file ?temp_filename ezfio_filename fields = | None -> Filename.temp_file "qmcchem_edit_" ".rst" | Some name -> name in - Out_channel.with_file filename ~f:(fun out_channel -> - (file_header ezfio_filename) :: (List.map ~f:get fields) - |> String.concat ~sep:"\n" - |> Out_channel.output_string out_channel - ) + let out_channel = open_out filename in + (file_header ezfio_filename) :: (List.map get fields) + |> String.concat "\n" + |> output_string out_channel + ; close_out out_channel ; filename @@ -104,7 +102,7 @@ let write_input_in_ezfio ezfio_filename fields = let input_filename = create_temp_file ~temp_filename ezfio_filename fields in - assert (Sys.file_exists_exn input_filename) + assert (Sys.file_exists input_filename) (** Run the edit command *) @@ -133,19 +131,19 @@ let run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_filename = in (); in - handle_option Input.Ref_energy.(of_float , write) e; - handle_option Input.Trial_wf_energy.(of_float , write) et; + handle_option Input.Ref_energy.(of_string, write) e; + handle_option Input.Trial_wf_energy.(of_string, write) et; handle_option Input.Jastrow_type.(of_string, write) j; - handle_option Input.Block_time.(of_int , write) l; + handle_option Input.Block_time.(of_string, write) l; handle_option Input.Method.(of_string, write) m; - handle_option Input.Stop_time.(of_int , write) t; + handle_option Input.Stop_time.(of_string, write) t; handle_option Input.Sampling.(of_string, write) s; - handle_option Input.Fitcusp_factor.(of_float , write) f; - handle_option Input.Time_step.(of_float , write) ts; - handle_option Input.Walk_num.(of_int , write) w; - handle_option Input.Walk_num_tot.(of_int , write) wt; - handle_option Input.CI_threshold.(of_float , write) n; - handle_option Input.SRMC_projection_time.(of_float , write) p; + handle_option Input.Fitcusp_factor.(of_string, write) f; + handle_option Input.Time_step.(of_string, write) ts; + handle_option Input.Walk_num.(of_string, write) w; + handle_option Input.Walk_num_tot.(of_string, write) wt; + handle_option Input.CI_threshold.(of_string, write) n; + handle_option Input.SRMC_projection_time.(of_string, write) p; let fields = @@ -179,21 +177,24 @@ let run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_filename = if (not !interactive) then failwith "Input file not allowed with command line arguments" else - begin + let rc = Printf.sprintf "cp %s %s" filename temp_filename - |> Sys.command_exn ; - end + |> Sys.command + in + assert (rc = 0) end | None -> begin (* Open the temp file with external editor *) let editor = - match Sys.getenv "EDITOR" with - | Some editor -> editor - | None -> "vi" + try Sys.getenv "EDITOR" with + | Not_found -> "vi" in - Printf.sprintf "%s %s ; tput sgr0 2> /dev/null" editor temp_filename - |> Sys.command_exn + let rc = + Printf.sprintf "%s %s ; tput sgr0 2> /dev/null" editor temp_filename + |> Sys.command + in + assert (rc = 0) end in @@ -203,18 +204,20 @@ let run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_filename = and re_prop = Str.regexp "([ xX]) .*$" and raw_data = - In_channel.with_file temp_filename ~f:In_channel.input_lines + let ic = open_in temp_filename in + let result = String_ext.input_lines ic in + close_in ic ; result in let data = - ( List.filter raw_data ~f:(fun x -> Str.string_match re_data x 0) - |> List.map ~f:String.strip ) @ + ( List.filter (fun x -> Str.string_match re_data x 0) raw_data + |> List.map String.trim ) @ [ - List.filter raw_data ~f:(fun x -> Str.string_match re_prop x 0) - |> List.map ~f:String.strip - |> String.concat ~sep:"\n" ] + List.filter (fun x -> Str.string_match re_prop x 0) raw_data + |> List.map String.trim + |> String.concat "\n" ] in let open Input in - List.iter2_exn data fields ~f:(fun s f -> + List.iter2 (fun s f -> try begin match f with @@ -235,7 +238,7 @@ let run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_filename = end with | Failure msg -> Printf.eprintf "%s\n" msg - ); + ) data fields ; (* Remove temp_file *) Sys.remove temp_filename; @@ -244,27 +247,26 @@ let run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_filename = ; if c then - begin - let dirname = - Filename.concat (Filename.concat ezfio_filename "blocks") (QmcMd5.hash ()) - in - let rec clean_dir y = - match Sys.is_directory y with - | `Yes -> - Sys.ls_dir y - |> List.map ~f:(Filename.concat y) - |> List.iter ~f:(function x -> - match ( Sys.is_directory x, Sys.is_file x ) with - | (`Yes, _) -> clean_dir x - | (_, `Yes) -> Sys.remove x - | (_,_) -> () - ); + begin + let dirname = + Filename.concat (Filename.concat ezfio_filename "blocks") (QmcMd5.hash ()) + in + let rec clean_dir y = + if Sys.is_directory y then + begin + Sys.readdir y + |> Array.map (fun x -> Filename.concat y x) + |> Array.iter (function x -> + if Sys.is_directory x then + clean_dir x + else + Sys.remove x + ); Unix.rmdir y - | `Unknown - | `No -> () - in clean_dir dirname; - Printf.printf "Blocks cleared\n" - end + end + in clean_dir dirname; + Printf.printf "Blocks cleared\n" + end ; Input.validate (); @@ -272,51 +274,96 @@ let run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_filename = write_input_in_ezfio ezfio_filename fields -let spec = - let open Command.Spec in - empty - +> flag "c" no_arg - ~doc:(" Clear blocks") - +> flag "f" (optional float) - ~doc:("float "^Input.Fitcusp_factor.doc) - +> flag "t" (optional int) - ~doc:("seconds "^Input.Stop_time.doc) - +> flag "l" (optional int) - ~doc:("seconds "^Input.Block_time.doc) - +> flag "m" (optional string) - ~doc:("method "^Input.Method.doc) - +> flag "e" (optional float) - ~doc:("energy "^Input.Ref_energy.doc) - +> flag "et" (optional float) - ~doc:("energy "^Input.Trial_wf_energy.doc) - +> flag "s" (optional string) - ~doc:("sampling "^Input.Sampling.doc) - +> flag "ts" (optional float) - ~doc:("time_step "^Input.Time_step.doc) - +> flag "w" (optional int) - ~doc:("walk_num "^Input.Walk_num.doc) - +> flag "wt" (optional int) - ~doc:("walk_num_tot "^Input.Walk_num_tot.doc) - +> flag "n" (optional float) - ~doc:("norm "^Input.CI_threshold.doc) - +> flag "j" (optional string) - ~doc:("jastrow_type "^Input.Jastrow_type.doc) - +> flag "p" (optional float) - ~doc:("projection_time "^Input.SRMC_projection_time.doc) - +> anon ("ezfio_file" %: string) - +> anon (maybe ("input" %: string)) -;; +let () = + let open Command_line in + begin + set_header_doc (Sys.argv.(0) ^ " - QMC=Chem command"); + set_description_doc "Edits input data"; -let command = - Command.basic_spec - ~summary: "Edit input data" - ~readme:(fun () -> - " -Edit input data - ") - spec - (fun c f t l m e et s ts w wt n j p ezfio_file input () -> - run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_file ) + [ { short='c' ; long="clear" ; opt=Optional ; + doc="Clears blocks" ; + arg=Without_arg ; }; + + { short='e' ; long="ref-energy" ; opt=Optional ; + doc=Input.Ref_energy.doc; + arg=With_arg ""; }; + + { short='f' ; long="fitcusp" ; opt=Optional ; + doc=Input.Fitcusp_factor.doc; + arg=With_arg ""; }; + + { short='i' ; long="time-step" ; opt=Optional ; + doc=Input.Time_step.doc; + arg=With_arg ""; }; + + { short='j' ; long="jastrow" ; opt=Optional ; + doc=Input.Jastrow_type.doc; + arg=With_arg ""; }; + + { short='l' ; long="block-time" ; opt=Optional ; + doc=Input.Block_time.doc; + arg=With_arg ""; }; + + { short='m' ; long="method" ; opt=Optional ; + doc=Input.Method.doc; + arg=With_arg ""; }; + + { short='n' ; long="norm" ; opt=Optional ; + doc=Input.CI_threshold.doc; + arg=With_arg ""; }; + + { short='p' ; long="projection-time" ; opt=Optional ; + doc=Input.SRMC_projection_time.doc; + arg=With_arg ""; }; + + { short='r' ; long="trial-energy" ; opt=Optional ; + doc=Input.Trial_wf_energy.doc; + arg=With_arg ""; }; + + { short='s' ; long="sampling" ; opt=Optional ; + doc=Input.Sampling.doc; + arg=With_arg ""; }; + + { short='t' ; long="stop-time" ; opt=Optional ; + doc=Input.Stop_time.doc; + arg=With_arg ""; }; + + { short='w' ; long="walk-num" ; opt=Optional ; + doc=Input.Walk_num.doc; + arg=With_arg ""; }; + + { short='x' ; long="walk-num-tot" ; opt=Optional ; + doc=Input.Walk_num_tot.doc; + arg=With_arg ""; }; + + anonymous "EZFIO_DIR" Mandatory "EZFIO directory"; + anonymous "FILE" Optional "Name of the input file"; + ] + |> set_specs ; + end; + + let c = Command_line.get_bool "clear" in + let f = Command_line.get "fitcusp" in + let t = Command_line.get "stop-time" in + let l = Command_line.get "block-time" in + let m = Command_line.get "method" in + let e = Command_line.get "ref-energy" in + let et = Command_line.get "trial-energy" in + let s = Command_line.get "stop-time" in + let ts = Command_line.get "time-step" in + let w = Command_line.get "walk-num" in + let wt = Command_line.get "walk-num-tot" in + let n = Command_line.get "norm" in + let j = Command_line.get "jastrow" in + let p = Command_line.get "projection-time" in + + let ezfio_file, input = + match Command_line.anon_args () with + | ezfio_file :: [] -> ezfio_file, None + | ezfio_file :: file :: [] -> ezfio_file, (Some file) + | _ -> (Command_line.help () ; failwith "Inconsistent command line") + in + run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_file diff --git a/ocaml/Qputils.ml b/ocaml/Qputils.ml index 7ae4ffa..d13a651 100644 --- a/ocaml/Qputils.ml +++ b/ocaml/Qputils.ml @@ -1,27 +1,26 @@ -open Core - let split_re = Str.regexp " +" let split s = - String.strip s + String.trim s |> Str.split split_re let set_ezfio_filename ezfio_filename = let () = - if (not (Sys.file_exists_exn ezfio_filename)) then + if (not (Sys.file_exists ezfio_filename)) then failwith (ezfio_filename^" does not exist") in let () = - match (Sys.is_directory ezfio_filename) with - | `Yes -> Ezfio.set_file ezfio_filename ; - | _ -> failwith ("Error : "^ezfio_filename^" is not a directory") + if Sys.is_directory ezfio_filename then + Ezfio.set_file ezfio_filename + else + failwith ("Error : "^ezfio_filename^" is not a directory") in let dir, result = - Filename.realpath ezfio_filename - |> Filename.split + Filename.dirname ezfio_filename, + Filename.basename ezfio_filename in Unix.chdir dir ; Ezfio.set_file result diff --git a/ocaml/Random_variable.ml b/ocaml/Random_variable.ml index 549838d..09e816a 100644 --- a/ocaml/Random_variable.ml +++ b/ocaml/Random_variable.ml @@ -1,4 +1,3 @@ -open Core open Qptypes type t = @@ -26,7 +25,7 @@ module Skewness: sig val to_string : t -> string end = struct type t = float - let to_string = Float.to_string + let to_string = string_of_float let to_float x = x let of_float x = x end @@ -38,7 +37,7 @@ module Kurtosis: sig val to_string : t -> string end = struct type t = float - let to_string = Float.to_string + let to_string = string_of_float let to_float x = x let of_float x = x end @@ -64,7 +63,7 @@ end = struct (x -. mu) *. ( x -. mu) /. sigma2 in let pi = - Float.acos (-1.) + acos (-1.) in let c = 1. /. (sqrt (sigma2 *. (pi +. pi))) @@ -79,15 +78,15 @@ end let of_raw_data ?(locked=true) ~range property = let data = Block.raw_data ~locked () - |> List.filter ~f:(fun x -> x.Block.property = property) + |> List.filter (fun x -> x.Block.property = property) in let data_in_range rmin rmax = let total_weight = - List.fold_left data ~init:0. ~f:(fun accu x -> - (Weight.to_float x.Block.weight) +. accu - ) + List.fold_left (fun accu x -> + (Weight.to_float x.Block.weight) +. accu + ) 0. data in let wmin, wmax = @@ -96,7 +95,7 @@ let of_raw_data ?(locked=true) ~range property = in let (_, new_data) = - List.fold_left data ~init:(0.,[]) ~f:(fun (wsum, l) x -> + List.fold_left (fun (wsum, l) x -> if (wsum > wmax) then (wsum,l) else @@ -109,7 +108,7 @@ let of_raw_data ?(locked=true) ~range property = else (wsum_new, l) end - ) + ) (0.,[]) data in List.rev new_data in @@ -127,13 +126,13 @@ let of_raw_data ?(locked=true) ~range property = let average { property ; data } = if Property.is_scalar property then let (num,denom) = - List.fold ~init:(0., 0.) ~f:(fun (an, ad) x -> + List.fold_left (fun (an, ad) x -> let num = (Weight.to_float x.Block.weight) *. (Sample.to_float x.Block.value) and den = (Weight.to_float x.Block.weight) in (an +. num, ad +. den) - ) data + ) (0., 0.) data in num /. denom |> Average.of_float @@ -144,20 +143,18 @@ let average { property ; data } = | x :: tl -> Sample.dimension x.Block.value in let (num,denom) = - List.fold ~init:(Array.create ~len:dim 0. , 0.) ~f:(fun (an, ad) x -> + List.fold_left (fun (an, ad) x -> let num = - Array.map (Sample.to_float_array x.Block.value) ~f:(fun y -> - (Weight.to_float x.Block.weight) *. y) + Array.map (fun y -> (Weight.to_float x.Block.weight) *. y) + (Sample.to_float_array x.Block.value) and den = (Weight.to_float x.Block.weight) - in ( - Array.mapi an ~f:(fun i y -> y +. num.(i)) , - ad +. den) - ) data + in ( Array.mapi (fun i y -> y +. num.(i)) an , ad +. den) + ) (Array.make dim 0. , 0.) data in let denom_inv = 1. /. denom in - Array.map num ~f:(fun x -> x *. denom_inv) + Array.map (fun x -> x *. denom_inv) num |> Average.of_float_array ~dim @@ -166,10 +163,10 @@ let average { property ; data } = (** Compute sum (for CPU/Wall time) *) let sum { property ; data } = - List.fold data ~init:0. ~f:(fun accu x -> + List.fold_left (fun accu x -> let num = (Weight.to_float x.Block.weight) *. (Sample.to_float x.Block.value) in accu +. num - ) + ) 0. data @@ -181,7 +178,7 @@ let ave_error { property ; data } = begin if (n > 0.) then ( Average.of_float (sum /. ansum), - Some (Error.of_float (sqrt ( Float.abs ( avsq /.( ansum *. n)))) )) + Some (Error.of_float (sqrt ( abs_float ( avsq /.( ansum *. n)))) )) else ( Average.of_float (sum /. ansum), None) end @@ -220,10 +217,10 @@ let ave_error { property ; data } = in if (Property.is_scalar property) then - List.map data ~f:(fun x -> + List.map (fun x -> (Sample.to_float x.Block.value, Weight.to_float x.Block.weight) - ) + ) data |> ave_error_scalar else match data with @@ -234,22 +231,22 @@ let ave_error { property ; data } = |> Sample.dimension in let result = - Array.init dim ~f:(fun idx -> - List.map list_of_samples ~f:(fun x -> + Array.init dim (fun idx -> + List.map (fun x -> (Sample.to_float ~idx x.Block.value, Weight.to_float x.Block.weight) - ) + ) list_of_samples |> ave_error_scalar ) in - ( Array.map result ~f:(fun (x,_) -> Average.to_float x) + ( Array.map (fun (x,_) -> Average.to_float x) result |> Average.of_float_array ~dim , if (Array.length result < 2) then None else - Some (Array.map result ~f:(function + Some (Array.map (function | (_,Some y) -> Error.to_float y - | (_,None) -> 0.) + | (_,None) -> 0.) result |> Average.of_float_array ~dim) ) @@ -258,14 +255,17 @@ let ave_error { property ; data } = (** Fold function for block values *) let fold_blocks ~f { property ; data } = - let init = match List.hd data with - | None -> 0. - | Some block -> Sample.to_float block.Block.value + let init = + try + let block = List.hd data in + Sample.to_float block.Block.value + with + | Failure "hd" -> 0. in - List.fold_left data ~init:init ~f:(fun accu block -> + List.fold_left (fun accu block -> let x = Sample.to_float block.Block.value in f accu x - ) + ) init data @@ -288,7 +288,7 @@ let convergence { property ; data } = in let accu = if (n > 0.) then - (sum /. ansum, sqrt ( Float.abs ( avsq /.( ansum *. n))))::accu + (sum /. ansum, sqrt ( abs_float ( avsq /.( ansum *. n))))::accu else (sum /. ansum, 0.)::accu in @@ -478,7 +478,7 @@ let error_x_over_y = function n := !n +. 1. ); let arg = - Float.abs (!avsq /.(!ansum *. (!n -. 1.))) + abs_float (!avsq /.(!ansum *. (!n -. 1.))) in let error = sqrt arg @@ -720,11 +720,11 @@ let autocovariance { property ; data } = in let f i = let denom = - if (i > 1) then (Float.of_int i) else 1. + if (i > 1) then (float_of_int i) else 1. in let r = Array.sub ~pos:0 ~len:i x_t - |> Array.fold ~init:0. ~f:(fun accu x -> + |> Array.fold_left ~init:0. ~f:(fun accu x -> accu +. x *. x_t.(i)) in r /. denom @@ -749,7 +749,7 @@ let centered_cumulants { property ; data } = in let var = let (num, denom) = - List.fold ~init:(0., 0.) ~f:(fun (a2, ad) (w,x) -> + List.fold_left ~init:(0., 0.) ~f:(fun (a2, ad) (w,x) -> let x2 = x *. x in let var = w *. x2 @@ -770,7 +770,7 @@ let centered_cumulants { property ; data } = in let (cum3,cum4) = let (cum3, cum4, denom) = - List.fold ~init:(0., 0., 0.) ~f:(fun (a3, a4, ad) (w,x) -> + List.fold_left ~init:(0., 0., 0.) ~f:(fun (a3, a4, ad) (w,x) -> let x2 = x *. x in let cum3 = w *. x2 *. x @@ -796,13 +796,13 @@ let histogram { property ; data } = max -. min and n = List.length data - |> Float.of_int + |> float_of_int |> sqrt in let delta_x = length /. (n-.1.) and result = - Array.init ~f:(fun _ -> 0.) (Int.of_float (n +. 1.)) + Array.init ~f:(fun _ -> 0.) (int_of_float (n +. 1.)) in List.iter ~f:(fun x -> let w = @@ -812,17 +812,17 @@ let histogram { property ; data } = in let i = (x -. min) /. delta_x +. 0.5 - |> Float.to_int + |> int_of_float in result.(i) <- result.(i) +. w ) data ; let norm = 1. /. ( delta_x *. ( - Array.fold ~init:0. ~f:(fun accu x -> accu +. x) result + Array.fold_left ~init:0. ~f:(fun accu x -> accu +. x) result ) ) in - Array.mapi ~f:(fun i x -> (min +. (Float.of_int i)*.delta_x, x *. norm) ) result + Array.mapi ~f:(fun i x -> (min +. (float_of_int i)*.delta_x, x *. norm) ) result |> Array.to_list diff --git a/ocaml/Sample.ml b/ocaml/Sample.ml index 8f6818f..6987388 100644 --- a/ocaml/Sample.ml +++ b/ocaml/Sample.ml @@ -1,5 +1,3 @@ -open Core - type t = | One_dimensional of float | Multidimensional of (float array * int) @@ -38,9 +36,10 @@ let of_float_array ~dim x = | _ -> Multidimensional (x, dim) let to_string = function - | One_dimensional x -> Float.to_string x + | One_dimensional x -> string_of_float x | Multidimensional (x,_) -> - Array.map x ~f:Float.to_string - |> String.concat_array ~sep:" " + Array.map string_of_float x + |> Array.to_list + |> String.concat " " |> Printf.sprintf "%s" diff --git a/ocaml/Sample.mli b/ocaml/Sample.mli index afa2308..031c715 100644 --- a/ocaml/Sample.mli +++ b/ocaml/Sample.mli @@ -1,5 +1,3 @@ -open Core - type t [@@ deriving sexp] val to_float : ?idx:int -> t -> float val to_float_array : t -> float array diff --git a/ocaml/Scheduler.ml b/ocaml/Scheduler.ml index f20b184..7e9ae2d 100644 --- a/ocaml/Scheduler.ml +++ b/ocaml/Scheduler.ml @@ -1,5 +1,3 @@ -open Core - type t = | SGE | PBS @@ -18,12 +16,10 @@ let to_string = function let find () = let scheduler = [ "SLURM_NODELIST" ; "PE_HOSTFILE" ; "PBS_NODEFILE" ] - |> List.map ~f:(function x -> - match (Sys.getenv x) with - | Some _ -> x - | None -> "" + |> List.map (function x -> + try Some (Sys.getenv x) with + | Not_found -> None ) - |> List.filter ~f:(function x -> x <> "") |> List.hd in let result = diff --git a/ocaml/String_ext.ml b/ocaml/String_ext.ml new file mode 100644 index 0000000..6ccecc1 --- /dev/null +++ b/ocaml/String_ext.ml @@ -0,0 +1,160 @@ +include String + +(** Split a string on a given character *) +let split ?(on=' ') str = + split_on_char on str + + +(** Strip blanks on the left of a string *) +let ltrim s = + let rec do_work s l = + match s.[0] with + | '\n' + | ' ' -> do_work (sub s 1 (l-1)) (l-1) + | _ -> s + in + let l = + length s + in + if (l > 0) then + do_work s l + else + s + +(** Strip blanks on the right of a string *) +let rtrim s = + let rec do_work s l = + let newl = + l-1 + in + match s.[newl] with + | '\n' + | ' ' -> do_work (sub s 0 (newl)) (newl) + | _ -> s + in + let l = + length s + in + if (l > 0) then + do_work s l + else + s + + +(** Strip blanks on the right and left of a string *) +let strip = String.trim + + +(** Split a string in two pieces when a character is found the 1st time from the left *) +let lsplit2_exn ?(on=' ') s = + let length = + String.length s + in + let rec do_work i = + if (i = length) then + begin + raise Not_found + end + else if (s.[i] = on) then + ( String.sub s 0 i, + String.sub s (i+1) (length-i-1) ) + else + do_work (i+1) + in + do_work 0 + + +(** Split a string in two pieces when a character is found the 1st time from the right *) +let rsplit2_exn ?(on=' ') s = + let length = + String.length s + in + let rec do_work i = + if (i = -1) then + begin + raise Not_found + end + else if (s.[i] = on) then + ( String.sub s 0 i, + String.sub s (i+1) (length-i-1) ) + else + do_work (i-1) + in + do_work (length-1) + + +let lsplit2 ?(on=' ') s = + try + Some (lsplit2_exn ~on s) + with + | Not_found -> None + + +let rsplit2 ?(on=' ') s = + try + Some (rsplit2_exn ~on s) + with + | Not_found -> None + + +let to_list s = + Array.init (String.length s) (fun i -> s.[i]) + |> Array.to_list + + +let of_list l = + let a = Array.of_list l in + String.init (Array.length a) (fun i -> a.(i)) + +let rev s = + to_list s + |> List.rev + |> of_list + +let fold ~init ~f s = + to_list s + |> List.fold_left f init + + +let is_prefix ~prefix s = + let len = + String.length prefix + in + if len > String.length s then + false + else + prefix = String.sub s 0 len + + +let of_char c = + String.make 1 c + +let tr ~target ~replacement s = + String.map (fun c -> if c = target then replacement else c) s + + +let substr_index ?(pos=0) ~pattern s = + try + let regexp = + Str.regexp pattern + in + Some (Str.search_forward regexp s pos) + with Not_found -> None + + +let substr_replace_all ~pattern ~with_ s = + let regexp = + Str.regexp pattern + in + Str.global_replace regexp with_ s + + +let input_lines ic = + let rec aux ic accu = + try + aux ic ((input_line ic)::accu) + with + | End_of_file -> List.rev accu + in + aux ic [] + diff --git a/ocaml/Watchdog.ml b/ocaml/Watchdog.ml index d0e92b8..819737b 100644 --- a/ocaml/Watchdog.ml +++ b/ocaml/Watchdog.ml @@ -1,5 +1,3 @@ -open Core - let _list = ref [] ;; let _running = ref false;; let _threads = ref [] ;; @@ -7,10 +5,10 @@ let _threads = ref [] ;; (** Kill the current process and all children *) let kill () = let kill pid = - Signal.send_i Signal.int (`Pid pid); - Printf.printf "Killed %d\n%!" (Pid.to_int pid) + Unix.kill pid Sys.sigint; + Printf.printf "Killed %d\n%!" pid in - List.iter ~f:kill (!_list); + List.iter kill (!_list); exit 1 ;; @@ -25,14 +23,11 @@ let start () = _running := true; let pause () = - Time.Span.of_sec 1. - |> Time.pause + Unix.sleep 1 in let pid_is_running pid = - match (Sys.file_exists ("/proc/"^(Pid.to_string pid)^"/stat")) with - | `No | `Unknown -> false - | `Yes -> true + Sys.file_exists ("/proc/"^(string_of_int pid)^"/stat") in let f () = @@ -41,13 +36,13 @@ let start () = pause () ; (*DEBUG - List.iter (!_list) ~f:(fun x -> Printf.printf "%d\n%!" (Pid.to_int x)); + List.iter (fun x -> Printf.printf "%d\n%!" x) (!_list) ; *) let continue () = - List.fold_left (!_list) ~init:true ~f:( - fun accu x -> accu && (pid_is_running x) - ) + List.fold_left + ( fun accu x -> accu && (pid_is_running x)) + true (!_list) in if ( not (continue ()) ) then kill () @@ -90,24 +85,24 @@ let del pid = ;; (** Fork and exec a new process *) -let fork_exec ~prog ~argv () = +let fork_exec ~prog ~args () = let pid = - Unix.fork_exec ~prog ~argv () + match Unix.fork () with + | 0 -> (* Chile process *) + let _ = Unix.execv prog args in 0 + | pid -> pid in let f () = add pid; let success = - match (Unix.waitpid pid) with - | Core_kernel.Std.Result.Ok () -> true - | Core_kernel.Std.Result.Error (`Exit_non_zero n) -> - ( Printf.printf "PID %d exited with code %d\n%!" - (Pid.to_int pid) n ; + match (Unix.waitpid [] pid) with + | pid , Unix.WEXITED n -> true + | pid , Unix.WSIGNALED n -> + ( Printf.printf "PID %d killed with signal %d\n%!" pid n; false ) - | Core_kernel.Std.Result.Error (`Signal n) -> - ( Printf.printf "PID %d killed with signal %d (%s)\n%!" - (Pid.to_int pid) (Signal.to_system_int n) - (Signal.to_string n) ; + | pid , Unix.WSTOPPED n -> + ( Printf.printf "PID %d stopped with signal %d\n%!" pid n; false ) in del pid ; @@ -121,6 +116,6 @@ let fork_exec ~prog ~argv () = (** Wait for threads to finish *) let join () = (* if (!_running) then stop (); *) - List.iter ~f:Thread.join (!_threads); + List.iter Thread.join (!_threads); assert (not !_running) ;; diff --git a/ocaml/_tags b/ocaml/_tags new file mode 100644 index 0000000..8c354c8 --- /dev/null +++ b/ocaml/_tags @@ -0,0 +1,6 @@ +true: package(cryptokit,zmq,str,sexplib,ppx_sexp_conv,ppx_deriving,getopt) +true: thread +false: profile +<*byte> : linkdep(c_bindings.o), custom +<*.native>: linkdep(c_bindings.o) + diff --git a/ocaml/build.ninja b/ocaml/build.ninja deleted file mode 100644 index 4e384a7..0000000 --- a/ocaml/build.ninja +++ /dev/null @@ -1,84 +0,0 @@ -MAIN=qmcchem -# Main program to build - -PACKAGES=-package core,cryptokit,str,zmq -#,ppx_sexp_conv -# Required opam packages, for example: -# PACKAGES=-package core,sexplib.syntax - -THREAD=-thread -# If you need threding support, use: -# THREAD=-thread - -SYNTAX= -# If you need pre-processing, use: -# SYNTAX=-syntax camlp4o - -OCAMLC_FLAGS=-g -warn-error A -# Flags to give to ocamlc, for example: -# OCAMLC_FLAGS=-g -warn-error A - -LINK_FLAGS= -# Flags to give to the linker, for example: -# LINK_FLAGS=-cclib '-Wl,-rpath=../lib,--enable-new-dtags' - -GENERATED_NINJA=generated.ninja -# Name of the auto-generated ninja file - -rule run_ninja - command = ../scripts/compile_ocaml.sh $target - description = Compiling OCaml executables - pool = console - -rule run_ninja_ocaml - command = ../scripts/compile_ocaml_dep.sh - description = Finding dependencies in OCaml files - -rule run_clean - command = ninja -f $GENERATED_NINJA -t clean ; rm -f $GENERATED_NINJA rm -f *.cmx *.cmi *.o .ls_md5 ; ninja -t clean - pool = console - description = Cleaning directory - -rule ocamlc - command = ocamlfind ocamlc -c $OCAMLC_FLAGS $THREAD $PACKAGES $SYNTAX -o $out $in - description = Compiling $in (bytecode) - -rule ocamlopt - command = ocamlfind ocamlopt -c $OCAMLC_FLAGS $THREAD $PACKAGES $SYNTAX -o $out $in - description = Compiling $in (native) - -rule ocamlc_link - command = ocamlfind ocamlc $OCAMLC_FLAGS $THREAD $LINK_FLAGS $PACKAGES $SYNTAX -o $out $in - description = Compiling $out (bytecode) - -rule ocamlopt_link - command = ocamlfind ocamlopt $OCAMLC_FLAGS $THREAD -linkpkg $PACKAGES $PACKAGES $SYNTAX -o $out $in - description = Compiling $out (native) - -rule create_qptypes - command = ./$in - description = Creating $out - -rule copy - command = cp $in $out - description = Copying $in to $out - -build always: phony -build $GENERATED_NINJA: run_ninja_ocaml | Qptypes.ml ezfio.ml always -build ezfio.ml: copy ../EZFIO/Ocaml/ezfio.ml -build Qptypes.ml: create_qptypes qptypes_generator | ezfio.ml -build qptypes_generator.o qptypes_generator.cmx: ocamlopt qptypes_generator.ml | ezfio.ml -build qptypes_generator: ocamlopt_link qptypes_generator.cmx - -build clean: run_clean - -build $MAIN: run_ninja | ezfio.ml Qptypes.ml $GENERATED_NINJA - target = $MAIN - -build all: run_ninja | ezfio.ml Qptypes.ml $GENERATED_NINJA - target = - -default $MAIN - - - diff --git a/ocaml/c_bindings.c b/ocaml/c_bindings.c new file mode 100644 index 0000000..50f35e3 --- /dev/null +++ b/ocaml/c_bindings.c @@ -0,0 +1,70 @@ +#include +#include +#include +#include +#include + +#include + + + +/* Adapted from + https://github.com/monadbobo/ocaml-core/blob/master/base/core/lib/linux_ext_stubs.c +*/ + +#include +#include +#include +#include +#include +#include + +CAMLprim value get_ipv4_address_for_interface(value v_interface) +{ + CAMLparam1(v_interface); + struct ifreq ifr; + int fd = -1; + value res; + char* error = NULL; + + memset(&ifr, 0, sizeof(ifr)); + ifr.ifr_addr.sa_family = AF_INET; + /* [ifr] is already initialized to zero, so it doesn't matter if the + incoming string is too long, and [strncpy] fails to add a \0. */ + strncpy(ifr.ifr_name, String_val(v_interface), IFNAMSIZ - 1); + + caml_enter_blocking_section(); + fd = socket(AF_INET, SOCK_DGRAM, 0); + + if (fd == -1) + error = "error: couldn't allocate socket"; + else { + if (ioctl(fd, SIOCGIFADDR, &ifr) < 0) + error = "error: ioctl(fd, SIOCGIFADDR, ...) failed"; + + (void) close(fd); + } + + caml_leave_blocking_section(); + + if (error == NULL) { + /* This is weird but doing the usual casting causes errors when using + * the new gcc on CentOS 6. This solution was picked up on Red Hat's + * bugzilla or something. It also works to memcpy a sockaddr into + * a sockaddr_in. This is faster hopefully. + */ + union { + struct sockaddr sa; + struct sockaddr_in sain; + } u; + u.sa = ifr.ifr_addr; + res = caml_copy_string(inet_ntoa(u.sain.sin_addr)); + } + else + res = caml_copy_string(error); + CAMLreturn(res); + +} + + + diff --git a/ocaml/myocamlbuild.ml b/ocaml/myocamlbuild.ml new file mode 100644 index 0000000..d0909c4 --- /dev/null +++ b/ocaml/myocamlbuild.ml @@ -0,0 +1,13 @@ +open Ocamlbuild_plugin;; + +dispatch begin function + | Before_rules -> + begin + end + | After_rules -> + begin + flag ["ocaml";"compile";"native";"gprof"] (S [ A "-p"]); + pdep ["link"] "linkdep" (fun param -> [param]); + end + | _ -> () +end diff --git a/ocaml/qptypes_generator.ml b/ocaml/qptypes_generator.ml index 9889b92..04691f8 100644 --- a/ocaml/qptypes_generator.ml +++ b/ocaml/qptypes_generator.ml @@ -1,85 +1,98 @@ -open Core +let global_replace x = + x + |> Str.global_replace (Str.regexp "Float.to_string") "string_of_float" + |> Str.global_replace (Str.regexp "Float.of_string") "float_of_string" + |> Str.global_replace (Str.regexp "Int.to_string") "string_of_int" + |> Str.global_replace (Str.regexp "Int.of_string") "int_of_string" + |> Str.global_replace (Str.regexp "String.\\(to\\|of\\)_string") "" let input_data = " -* Positive_float : float - assert (x >= 0.) ; +* Positive_float : float + if not (x >= 0.) then + raise (Invalid_argument (Printf.sprintf \"Positive_float : (x >= 0.) : x=%f\" x)); -* Strictly_positive_float : float - assert (x > 0.) ; +* Strictly_positive_float : float + if not (x > 0.) then + raise (Invalid_argument (Printf.sprintf \"Strictly_positive_float : (x > 0.) : x=%f\" x)); -* Negative_float : float - assert (x <= 0.) ; +* Negative_float : float + if not (x <= 0.) then + raise (Invalid_argument (Printf.sprintf \"Negative_float : (x <= 0.) : x=%f\" x)); -* Strictly_negative_float : float - assert (x < 0.) ; +* Strictly_negative_float : float + if not (x < 0.) then + raise (Invalid_argument (Printf.sprintf \"Strictly_negative_float : (x < 0.) : x=%f\" x)); -* Positive_int : int - assert (x >= 0) ; +* Positive_int64 : int64 + if not (x >= 0L) then + raise (Invalid_argument (Printf.sprintf \"Positive_int64 : (x >= 0L) : x=%s\" (Int64.to_string x))); -* Strictly_positive_int : int - assert (x > 0) ; +* Positive_int : int + if not (x >= 0) then + raise (Invalid_argument (Printf.sprintf \"Positive_int : (x >= 0) : x=%d\" x)); -* Negative_int : int +* Strictly_positive_int : int + if not (x > 0) then + raise (Invalid_argument (Printf.sprintf \"Strictly_positive_int : (x > 0) : x=%d\" x)); + +* Negative_int : int + if not (x <= 0) then + raise (Invalid_argument (Printf.sprintf \"Negative_int : (x <= 0) : x=%d\" x)); assert (x <= 0) ; * Det_coef : float - assert (x >= -1.) ; - assert (x <= 1.) ; + if (x < -1.) || (x > 1.) then + raise (Invalid_argument (Printf.sprintf \"Det_coef : (-1. <= x <= 1.) : x=%f\" x)); * Normalized_float : float - assert (x <= 1.) ; - assert (x >= 0.) ; + if (x < 0.) || (x > 1.) then + raise (Invalid_argument (Printf.sprintf \"Normalized_float : (0. <= x <= 1.) : x=%f\" x)); -* Strictly_negative_int : int - assert (x < 0) ; +* Strictly_negative_int : int + if not (x < 0) then + raise (Invalid_argument (Printf.sprintf \"Strictly_negative_int : (x < 0) : x=%d\" x)); * Non_empty_string : string - assert (x <> \"\") ; + if (x = \"\") then + raise (Invalid_argument \"Non_empty_string\"); -* Det_number_max : int - assert (x > 0) ; - if (x > 100000000) then +* Det_number_max : int + assert (x > 0) ; + if (x > 100_000_000) then warning \"More than 100 million determinants\"; -"^ -(* -" -* States_number : int - assert (x > 0) ; - if (x > 100) then - warning \"More than 100 states\"; - if (Ezfio.has_determinants_n_states_diag ()) then - assert (x <= (Ezfio.get_determinants_n_states_diag ())) - else if (Ezfio.has_determinants_n_states ()) then - assert (x <= (Ezfio.get_determinants_n_states ())); -* Bit_kind_size : int +* States_number : int + assert (x > 0) ; + if (x > 1000) then + warning \"More than 1000 states\"; + +* Bit_kind_size : int begin match x with | 8 | 16 | 32 | 64 -> () - | _ -> raise (Failure \"Bit_kind_size should be (8|16|32|64).\") + | _ -> raise (Invalid_argument \"Bit_kind_size should be (8|16|32|64).\") end; -* Bit_kind : int +* Bit_kind : int begin match x with | 1 | 2 | 4 | 8 -> () - | _ -> raise (Failure \"Bit_kind should be (1|2|4|8).\") + | _ -> raise (Invalid_argument \"Bit_kind should be (1|2|4|8).\") end; * Bitmask_number : int assert (x > 0) ; -"^ -*) -" * MO_coef : float * MO_occ : float - assert (x >= 0.); + if x < 0. then 0. else + if x > 2. then 2. else * AO_coef : float -* AO_expo : float - assert (x >= 0.) ; +* AO_expo : float + if (x < 0.) then + raise (Invalid_argument (Printf.sprintf \"AO_expo : (x >= 0.) : x=%f\" x)); * AO_prim_number : int assert (x > 0) ; @@ -102,6 +115,12 @@ let input_data = " * MD5 : string assert ((String.length x) = 32); + assert ( + let a = + Array.init (String.length x) (fun i -> x.[i]) + in + Array.fold_left (fun accu x -> accu && (x < 'g')) true a + ); * Rst_string : string @@ -116,96 +135,96 @@ let input_data = " assert (x <> \"\") ; " -;; + let input_ezfio = " * MO_number : int mo_basis_mo_tot_num - 1 : 10000 - More than 10000 MOs + 1 : 10_000 + More than 10_000 MOs * AO_number : int ao_basis_ao_num - 1 : 10000 - More than 10000 AOs + 1 : 10_000 + More than 10_000 AOs * Nucl_number : int nuclei_nucl_num - 1 : 10000 - More than 10000 nuclei + 1 : 10_000 + More than 10_000 nuclei -"^ -(* -" * N_int_number : int - determinants_n_int + spindeterminants_n_int 1 : 30 N_int > 30 * Det_number : int - determinants_n_det - 1 : 100000000 + spindeterminants_n_det + 1 : 100_000_000 More than 100 million determinants -" -*) -"" -;; + +" + let untouched = " " let template = format_of_string " module %s : sig - type t [@@ deriving sexp] + type t [@@deriving sexp] val to_%s : t -> %s val of_%s : %s %s -> t val to_string : t -> string end = struct - type t = %s [@@ deriving sexp] + type t = %s [@@deriving sexp] let to_%s x = x let of_%s %s x = ( %s x ) let to_string x = %s.to_string x end " -;; + + let parse_input input= + print_string "open Sexplib.Std\nlet warning = print_string\n" ; let rec parse result = function | [] -> result | ( "" , "" )::tail -> parse result tail - | ( t , text )::tail -> - let name,typ,params,params_val = - match String.split ~on:':' t with + | ( t , text )::tail -> + let name,typ,params,params_val = + match String.split_on_char ':' t with | [name;typ] -> (name,typ,"","") | name::typ::params::params_val -> (name,typ,params, - (String.concat params_val ~sep:":") ) + (String.concat ":" params_val) ) | _ -> assert false in - let typ = String.strip typ - and name = String.strip name in - let typ_cap = String.capitalize typ in - let newstring = Printf.sprintf template name typ typ typ params_val typ typ - typ typ params ( String.strip text ) typ_cap + let typ = String_ext.strip typ + and name = String_ext.strip name in + let typ_cap = String.capitalize_ascii typ in + let newstring = Printf.sprintf template name typ typ typ params_val typ typ + typ typ params ( String_ext.strip text ) typ_cap in List.rev (parse (newstring::result) tail ) in - String.split ~on:'*' input - |> List.map ~f:(String.lsplit2_exn ~on:'\n') + String_ext.split ~on:'*' input + |> List.map (String_ext.lsplit2_exn ~on:'\n') |> parse [] - |> String.concat -;; + |> String.concat "" + |> global_replace + |> print_string + let ezfio_template = format_of_string " module %s : sig - type t [@@ deriving sexp] + type t [@@deriving sexp] val to_%s : t -> %s val get_max : unit -> %s val of_%s : ?min:%s -> ?max:%s -> %s -> t val to_string : t -> string end = struct - type t = %s [@@ deriving sexp] + type t = %s [@@deriving sexp] let to_string x = %s.to_string x let get_max () = if (Ezfio.has_%s ()) then @@ -215,7 +234,7 @@ end = struct let get_min () = %s let to_%s x = x - let of_%s ?(min=get_min ()) ?(max=get_max ()) x = + let of_%s ?(min=get_min ()) ?(max=get_max ()) x = begin assert (x >= min) ; if (x > %s) then @@ -223,7 +242,9 @@ end = struct begin match max with | %s -> () - | i -> assert ( x <= i ) + | i -> + if ( x > i ) then + raise (Invalid_argument (Printf.sprintf \"%s: %%s\" (%s.to_string x) )) end ; x end @@ -232,104 +253,103 @@ end let parse_input_ezfio input= - let parse s = + let parse s = match ( - String.split s ~on:'\n' - |> List.filter ~f:(fun x -> (String.strip x) <> "") + String_ext.split s ~on:'\n' + |> List.filter (fun x -> (String_ext.strip x) <> "") ) with | [] -> "" | a :: b :: c :: d :: [] -> begin - let (name,typ) = String.lsplit2_exn ~on:':' a + let (name,typ) = String_ext.lsplit2_exn ~on:':' a and ezfio_func = b - and (min, max) = String.lsplit2_exn ~on:':' c + and (min, max) = String_ext.lsplit2_exn ~on:':' c and msg = d - in - let (name, typ, ezfio_func, min, max, msg) = - match (List.map [ name ; typ ; ezfio_func ; min ; max ; msg ] ~f:String.strip) with + in + let (name, typ, ezfio_func, min, max, msg) = + match List.map String_ext.strip [ name ; typ ; ezfio_func ; min ; max ; msg ] with | [ name ; typ ; ezfio_func ; min ; max ; msg ] -> (name, typ, ezfio_func, min, max, msg) | _ -> assert false in - Printf.sprintf ezfio_template - name typ typ typ typ typ typ typ typ (String.capitalize typ) - ezfio_func ezfio_func max min typ typ max msg min + Printf.sprintf ezfio_template + name typ typ typ typ typ typ typ typ (String.capitalize_ascii typ) + ezfio_func ezfio_func max min typ typ max msg min name (String.capitalize_ascii typ) end | _ -> failwith "Error in input_ezfio" in - String.split ~on:'*' input - |> List.map ~f:parse - |> String.concat + String_ext.split ~on:'*' input + |> List.map parse + |> String.concat "" + |> global_replace + |> print_string + (** EZFIO *) +let input_lines filename = + let ic = open_in filename in + let result = String_ext.input_lines ic in + close_in ic; + result + + let create_ezfio_handler () = let lines = - In_channel.with_file "ezfio.ml" ~f:In_channel.input_lines - |> List.filteri ~f:(fun i _ -> i > 470) + input_lines "ezfio.ml" + |> List.mapi (fun i l -> if i > 470 then Some l else None) + |> List.filter (fun x -> x <> None) + |> List.map (fun x -> + match x with + | Some x -> x + | None -> assert false) in let functions = - List.map lines ~f:(fun x -> - match String.split x ~on:' ' with + List.map (fun x -> + match String.split_on_char ' ' x with | _ :: x :: "()" :: "=" :: f :: dir :: item :: _-> (x, f, dir, item) | _ :: x :: "=" :: f :: dir :: item :: _-> (x, f, dir, item) | _ -> ("","","","") - ) + ) lines in let has_functions = - List.filter functions ~f:(fun (x,_,_,_) -> String.is_prefix ~prefix:"has_" x) + List.filter (fun (x,_,_,_) -> String.sub x 0 4 = "has_") functions and get_functions = - List.filter functions ~f:(fun (x,_,_,_) -> String.is_prefix ~prefix:"get_" x) + List.filter (fun (x,_,_,_) -> String.sub x 0 4 = "get_") functions in + let chop s = + match (Str.split_delim (Str.regexp ";;") s) with + | x :: _ -> x + | _ -> assert false + in + let result = [ "let decode_ezfio_message msg = match msg with " ] @ ( - List.map get_functions ~f:(fun (x,f,d,i) -> - let i = - match (String.chop_suffix i ~suffix:";;") with - | Some x -> x - | None -> i - in - if (String.is_suffix f ~suffix:"_array") then + List.map (fun (x,f,d,i) -> + let i = chop i in + if (String.sub f ((String.length f)-6) 6 = "_array") then Printf.sprintf " | \"%s\" -> Ezfio.read_string_array %s %s |> Ezfio.flattened_ezfio |> Array.to_list - |> String.concat ~sep:\" \"" x d i + |> String.concat \" \"" x d i else Printf.sprintf " | \"%s\" -> Ezfio.read_string %s %s" x d i - ) + ) get_functions ) @ ( - List.map has_functions ~f:(fun (x,_,_,_) -> + List.map (fun (x,_,_,_) -> Printf.sprintf " | \"%s\" -> if (Ezfio.%s ()) then \"T\" else \"F\"" x x - ) + ) has_functions ) @ [" | x -> failwith (x^\" : Unknown EZFIO function\")\n;;"] in - String.concat result ~sep:"\n" + String.concat "\n" result (** Main *) - -let () = - let input = - String.concat ~sep:"\n" - [ "open Core\nlet warning = print_string\n\n" ; - parse_input input_data ; - parse_input_ezfio input_ezfio ; - create_ezfio_handler (); - untouched ] - - and old_input = - let filename = - "Qptypes.ml" - in - match Sys.file_exists filename with - | `Yes -> In_channel.read_all "Qptypes.ml" - | `No | `Unknown -> "empty" - - in - - if input <> old_input then - Out_channel.write_all "Qptypes.ml" ~data:input +let () = + parse_input input_data ; + parse_input_ezfio input_ezfio; + print_endline untouched