LCPQ/qmcchem
10
1
Fork 1
mirror of https://gitlab.com/scemama/qmcchem.git synced 2024-12-22 04:13:31 +01:00
Code Releases Activity

Removed core

Browse Source
This commit is contained in:
Anthony Scemama 2019-07-14 18:50:44 +02:00
parent 5befb6dfe9
commit 16acf1fe89
23 changed files with 1162 additions and 556 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ocaml/.merlin
View File

@ -1,3 +1,3 @@
PKG core cryptokit str zmq PKG cryptokit str zmq
S . S .

77
ocaml/Block.ml
View File

@ -1,4 +1,3 @@
open Core
open Qptypes open Qptypes
type t = type t =
@ -6,7 +5,7 @@ type t =
value : Sample.t ; value : Sample.t ;
weight : Weight.t ; weight : Weight.t ;
compute_node : Compute_node.t ; compute_node : Compute_node.t ;
pid : Pid.t ; pid : int ;
block_id : Block_id.t ; block_id : Block_id.t ;
} }
@ -23,17 +22,17 @@ let of_string s =
match lst with match lst with
| b :: pid :: c:: p :: w :: v :: [] -> Some | b :: pid :: c:: p :: w :: v :: [] -> Some
{ property = Property.of_string p ; { property = Property.of_string p ;
value = Sample.of_float (Float.of_string v) ; value = Sample.of_float (float_of_string v) ;
weight = Weight.of_float (Float.of_string w) ; weight = Weight.of_float (float_of_string w) ;
compute_node = Compute_node.of_string c; compute_node = Compute_node.of_string c;
pid = Pid.of_string pid; pid = int_of_string pid;
block_id = Block_id.of_int (Int.of_string b) ; block_id = Block_id.of_int (int_of_string b) ;
} }
| b :: pid :: c:: p :: w :: v -> | b :: pid :: c:: p :: w :: v ->
let v = let v =
List.rev v List.rev v
|> Array.of_list |> Array.of_list
|> Array.map ~f:Float.of_string |> Array.map float_of_string
in in
let dim = let dim =
Array.length v Array.length v
@ -41,10 +40,10 @@ let of_string s =
Some Some
{ property = Property.of_string p ; { property = Property.of_string p ;
value = Sample.of_float_array ~dim v ; 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; compute_node = Compute_node.of_string c;
pid = Pid.of_string pid; pid = int_of_string pid;
block_id = Block_id.of_int (Int.of_string b) ; block_id = Block_id.of_int (int_of_string b) ;
} }
| _ -> None | _ -> None
with with
@ -55,10 +54,10 @@ let of_string s =
let to_string b = let to_string b =
Printf.sprintf "%s %s # %s %s %s %d" Printf.sprintf "%s %s # %s %s %s %d"
(Sample.to_string b.value ) (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) (Property.to_string b.property)
(Compute_node.to_string b.compute_node) (Compute_node.to_string b.compute_node)
(Pid.to_string b.pid) (string_of_int b.pid)
(Block_id.to_int b.block_id) (Block_id.to_int b.block_id)
@ -70,8 +69,8 @@ let dir_name = lazy(
let md5 = let md5 =
QmcMd5.hash () QmcMd5.hash ()
in in
List.fold_right ~init:"" ~f:Filename.concat List.fold_right Filename.concat
[ ezfio_filename ; "blocks" ; md5 ; Filename.dir_sep ] [ ezfio_filename ; "blocks" ; md5 ; Filename.dir_sep ] ""
) )
@ -87,29 +86,31 @@ let update_raw_data ?(locked=true) () =
in in
let files = let files =
let result = let result =
match Sys.is_directory dir_name with if Sys.is_directory dir_name then
| `Yes ->
begin begin
Sys.readdir dir_name Sys.readdir dir_name
|> Array.map ~f:(fun x -> dir_name^x) |> Array.map (fun x -> dir_name^x)
|> Array.to_list |> Array.to_list
end end
| _ -> [] else []
in in
if locked then if locked then
result result
else else
List.filter result ~f:(fun x -> List.filter (fun x ->
match String.substr_index ~pattern:"locked" x with try
| Some x -> false let _ =
| None -> true Str.search_backward (Str.regexp "locked") x ((String.length x) - 1)
) in false
with
| Not_found -> true
) result
in in
let rec transform new_list = function let rec transform new_list = function
| [] -> new_list | [] -> new_list
| head :: tail -> | head :: tail ->
let head = String.strip head in let head = String.trim head in
let item = of_string head in let item = of_string head in
match item with match item with
| None -> transform new_list tail | None -> transform new_list tail
@ -117,14 +118,19 @@ let update_raw_data ?(locked=true) () =
in in
let result = let result =
List.map files ~f:(fun filename -> let rec aux ic accu =
In_channel.with_file filename ~f:(fun in_channel -> try
In_channel.input_all in_channel) aux ic ( (input_line ic)::accu )
) with
|> String.concat | End_of_file -> List.rev accu
|> String.split_lines in
|> List.rev List.map (fun filename ->
|> transform [] let ic = open_in filename in
let result = aux ic [] in
close_in ic;
result ) files
|> List.concat
|> transform []
in in
result result
@ -141,10 +147,11 @@ let raw_data ?(locked=true) () =
module StringSet = Set.Make(String)
let properties = lazy ( let properties = lazy (
let set = Set.Poly.empty in List.fold_left (fun s x -> StringSet.add (Property.to_string x.property) s) StringSet.empty (raw_data ())
List.fold (raw_data ()) ~init:set ~f:(fun s x -> Set.add s x.property) |> StringSet.elements
|> Set.to_list
) )

199
ocaml/Command_line.ml Normal file
View File

@ -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 "@[<v 0>";
begin
match Str.split (Str.regexp "\n") t with
| x :: [] -> Format.printf "@[<hov 0>";
Str.split (Str.regexp " ") x
|> List.iter (fun y -> Format.printf "@[%s@]@ " y) ;
Format.printf "@]"
| t -> List.iter (fun x ->
Format.printf "@[<hov 0>";
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 "@[<v 0>";
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 "@[<v>@[<v 2>Usage:@,@,@[<hov 4>@[%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 "@[<v 2>Arguments:@,";
Format.printf "@[<v 0>" ;
List.iter (fun x -> Format.printf "@ "; output_long max_width x) anon;
Format.printf "@]@,@]@,";
(* Print options and doc *)
Format.printf "@[<v 2>Options:@,";
Format.printf "@[<v 0>" ;
List.iter (fun x -> Format.printf "@ "; output_long max_width x) options;
Format.printf "@]@,@]@,";
(* Print footer *)
if !description_doc <> "" then
begin
Format.printf "@[<v 2>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

126
ocaml/Command_line.mli Normal file
View File

@ -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 "<int>"; };
{ short='s'; long="state"; opt=Optional;
doc="Extract selected states, for example \"[1,3-5]\"";
arg=With_arg "<range>"; };
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 <string>. *)
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

5
ocaml/Default.ml
View File

@ -1,6 +1,3 @@
open Core
let simulation_nucl_fitcusp_factor = lazy( let simulation_nucl_fitcusp_factor = lazy(
let default = let default =
1. 1.
@ -26,7 +23,7 @@ let simulation_time_step = lazy ( 0.15 )
let simulation_srmc_projection_time = lazy ( 1. ) let simulation_srmc_projection_time = lazy ( 1. )
let reset_defaults () = 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" ;
"/electrons/elec_walk_num_tot" ; "/electrons/elec_walk_num_tot" ;
"/jastrow/jast_type" ; "/jastrow/jast_type" ;

79
ocaml/Input.ml
View File

@ -1,4 +1,3 @@
open Core
open Qptypes open Qptypes
open Qputils open Qputils
@ -38,13 +37,13 @@ end = struct
let to_string t = let to_string t =
to_bool t to_bool t
|> Bool.to_string |> string_of_bool
let of_string t = let of_string t =
try try
String.lowercase t String.lowercase_ascii t
|> Bool.of_string |> bool_of_string
|> of_bool |> of_bool
with with
| Invalid_argument msg -> failwith msg | 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 = let to_string t =
to_float t to_float t
|> Float.to_string |> string_of_float
let of_string t = let of_string t =
try try
Float.of_string t float_of_string t
|> of_float |> of_float
with with
| Invalid_argument msg -> failwith msg | Invalid_argument msg -> failwith msg
@ -181,21 +180,21 @@ end = struct
let to_string t = let to_string t =
to_int t to_int t
|> Int.to_string |> string_of_int
let of_string t = let of_string t =
Int.of_string t int_of_string t
|> of_int |> of_int
let to_float t = let to_float t =
to_int t to_int t
|> Float.of_int |> float_of_int
let of_float t = let of_float t =
Int.of_float t int_of_float t
|> of_int |> of_int
@ -248,11 +247,11 @@ end = struct
let to_string t = let to_string t =
to_int t to_int t
|> Int.to_string |> string_of_int
let of_string t = let of_string t =
Int.of_string t int_of_string t
|> of_int |> of_int
@ -305,11 +304,11 @@ end = struct
let to_string t = let to_string t =
to_int t to_int t
|> Int.to_string |> string_of_int
let of_string t = let of_string t =
Int.of_string t int_of_string t
|> of_int |> of_int
@ -364,21 +363,21 @@ end = struct
let to_string t = let to_string t =
to_int t to_int t
|> Int.to_string |> string_of_int
let of_string t = let of_string t =
Int.of_string t int_of_string t
|> of_int |> of_int
let to_float t = let to_float t =
to_int t to_int t
|> Float.of_int |> float_of_int
let of_float t = let of_float t =
Int.of_float t int_of_float t
|> of_int |> of_int
end end
@ -456,7 +455,7 @@ end = struct
let doc = "Sampling algorithm : [ Langevin | Brownian ]" let doc = "Sampling algorithm : [ Langevin | Brownian ]"
let of_string s = let of_string s =
match String.capitalize (String.strip s) with match String.capitalize_ascii (String.trim s) with
| "Langevin" -> Langevin | "Langevin" -> Langevin
| "Brownian" -> Brownian | "Brownian" -> Brownian
| x -> failwith ("Sampling should be [ Brownian | Langevin ], not "^x^".") | x -> failwith ("Sampling should be [ Brownian | Langevin ], not "^x^".")
@ -536,13 +535,13 @@ end = struct
let of_string x = let of_string x =
Float.of_string x float_of_string x
|> of_float |> of_float
let to_string x = let to_string x =
to_float x to_float x
|> Float.to_string |> string_of_float
end end
@ -593,13 +592,13 @@ end = struct
let of_string x = let of_string x =
Float.of_string x float_of_string x
|> of_float |> of_float
let to_string x = let to_string x =
to_float x to_float x
|> Float.to_string |> string_of_float
end end
@ -652,13 +651,13 @@ contribution to the norm less than t (au)"
let of_string x = let of_string x =
Float.of_string x float_of_string x
|> of_float |> of_float
let to_string x = let to_string x =
to_float x to_float x
|> Float.to_string |> string_of_float
end end
@ -708,13 +707,13 @@ end = struct
let of_string x = let of_string x =
Float.of_string x float_of_string x
|> of_float |> of_float
let to_string x = let to_string x =
to_float x to_float x
|> Float.to_string |> string_of_float
end end
@ -764,13 +763,13 @@ end = struct
let of_string x = let of_string x =
Float.of_string x float_of_string x
|> of_float |> of_float
let to_string x = let to_string x =
to_float x to_float x
|> Float.to_string |> string_of_float
end end
@ -789,7 +788,7 @@ end = struct
let doc = "Type of Jastrow factor [ None | Core | Simple ]" let doc = "Type of Jastrow factor [ None | Core | Simple ]"
let of_string s = let of_string s =
match String.capitalize (String.strip s) with match String.capitalize (String.trim s) with
| "Core" -> Core | "Core" -> Core
| "Simple" -> Simple | "Simple" -> Simple
| "None" -> None | "None" -> None
@ -841,31 +840,31 @@ end = struct
let read () = 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 = 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 = let to_string l =
List.map l ~f:(fun (x,b) -> List.map (fun (x,b) ->
let ch = let ch =
if b then "X" else " " if b then "X" else " "
in in
Printf.sprintf "(%s) %s" ch (Property.to_string x)) Printf.sprintf "(%s) %s" ch (Property.to_string x)) l
|> String.concat ~sep:"\n" |> String.concat "\n"
let of_string s = let of_string s =
String.split s ~on:'\n' String.split_on_char '\n' s
|> List.map ~f:(fun x -> |> List.map (fun x ->
let (calc,prop) = let (calc,prop) =
String.strip x String.trim x
|> String.rsplit2_exn ~on:' ' |> String_ext.rsplit2_exn ~on:' '
in in
let prop = let prop =
String.strip prop String.trim prop
|> Property.of_string |> Property.of_string
and calc = and calc =
match calc with match calc with

25
ocaml/Launcher.ml
View File

@ -1,5 +1,3 @@
open Core
type t = type t =
| Srun | Srun
| MPI | MPI
@ -50,19 +48,21 @@ let create_nodefile () =
in in
let h = let h =
String.Table.create ~size:1000 () Hashtbl.create 1000
in in
let in_channel = let in_channel =
Unix.open_process_in (launcher_command^" hostname -s") Unix.open_process_in (launcher_command^" hostname -s")
in in
In_channel.input_lines in_channel String_ext.input_lines in_channel
|> List.map ~f:String.strip |> List.map String.trim
|> List.iter ~f:( fun host -> |> List.iter ( fun host ->
Hashtbl.change h host (function let n =
| Some x -> Some (x+1) match Hashtbl.find_opt h host with
| None -> Some 1 | Some x -> x+1
) | None -> 1
in
Hashtbl.replace h host n
); );
match match
Unix.close_process_in in_channel Unix.close_process_in in_channel
@ -80,9 +80,8 @@ let create_nodefile () =
fun (node, n) -> fun (node, n) ->
Printf.sprintf "%s %d\n" node n Printf.sprintf "%s %d\n" node n
in in
Hashtbl.to_alist h Hashtbl.fold (fun k v a -> (f (k,v)) :: a) h []
|> List.map ~f |> String.concat "\n"
|> String.concat

58
ocaml/Makefile Normal file
View File

@ -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)

26
ocaml/QmcMd5.ml
View File

@ -1,5 +1,3 @@
open Core
(** Directory containing the list of input files. The directory is created is inexistant. *) (** Directory containing the list of input files. The directory is created is inexistant. *)
let input_directory = lazy ( let input_directory = lazy (
@ -12,9 +10,8 @@ let input_directory = lazy (
in in
begin begin
match ( Sys.is_directory dirname ) with if not (Sys.is_directory dirname) then
| `No -> Unix.mkdir dirname Unix.mkdir dirname 0o777
| _ -> ()
end ; end ;
dirname dirname
@ -83,14 +80,17 @@ let files_to_track = [
(** Get an MD5 ke from the content of a file. *) (** Get an MD5 ke from the content of a file. *)
let hash_file filename = let hash_file filename =
match Sys.is_file filename with if Sys.file_exists filename then
| `Yes ->
begin 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.hash_channel (Cryptokit.Hash.md5 ()) ic
|> Cryptokit.transform_string (Cryptokit.Hexa.encode ()) ) |> Cryptokit.transform_string (Cryptokit.Hexa.encode ())
in
close_in ic;
result
end end
| _ -> "" else ""
(** Cache containing the current value of the MD5 hash. *) (** Cache containing the current value of the MD5 hash. *)
@ -111,9 +111,9 @@ let hash () =
in in
let md5_string = let md5_string =
files_to_track files_to_track
|> List.map ~f:(fun x -> Printf.sprintf "%s/%s" ezfio_filename x) |> List.map (fun x -> Printf.sprintf "%s/%s" ezfio_filename x)
|> List.map ~f:hash_file |> List.map hash_file
|> String.concat |> String.concat ""
in in
let new_md5 = let new_md5 =

70
ocaml/Qmcchem_config.ml
View File

@ -1,22 +1,18 @@
open Core
(** QMC=Chem installation directory *) (** QMC=Chem installation directory *)
let root = lazy ( let root = lazy (
match ( Sys.getenv "QMCCHEM_PATH" ) with try Sys.getenv "QMCCHEM_PATH" with
| Some x -> x | Not_found -> failwith "QMCCHEM_PATH environment variable not set"
| None -> failwith "QMCCHEM_PATH environment variable not set"
) )
(* PATH environment variable as a list of strings *) (* PATH environment variable as a list of strings *)
let path = lazy ( let path = lazy (
let p = let p =
match Sys.getenv "PATH" with try Sys.getenv "PATH" with
| None -> failwith "PATH environment variable is not set" | Not_found -> failwith "PATH environment variable is not set"
| Some p -> p
in in
String.split ~on:':' p String.split_on_char ':' p
) )
@ -30,9 +26,10 @@ let full_path exe =
let fp = let fp =
Filename.concat head exe Filename.concat head exe
in in
match (Sys.is_file fp) with if Sys.file_exists fp then
| `Yes -> Some fp Some fp
| _ -> in_path_rec tail else
in_path_rec tail
end end
in in
Lazy.force path Lazy.force path
@ -42,7 +39,7 @@ let full_path exe =
(* True if an executable is in the PATH *) (* True if an executable is in the PATH *)
let in_path x = let in_path x =
match (full_path x) with match full_path x with
| Some _ -> true | Some _ -> true
| None -> false | None -> false
@ -51,13 +48,13 @@ let has_parallel = lazy( in_path "parallel" )
let has_mpirun = lazy( in_path "mpirun" ) let has_mpirun = lazy( in_path "mpirun" )
let has_srun = lazy( in_path "parallel" ) let has_srun = lazy( in_path "parallel" )
let has_qmc = lazy( in_path "qmc" ) let has_qmc = lazy( in_path "qmc" )
let has_qmc_mic = lazy( in_path "qmc_mic" )
let mpirun = lazy ( let mpirun = lazy (
match Sys.getenv "QMCCHEM_MPIRUN" with try
| None -> "mpirun" Sys.getenv "QMCCHEM_MPIRUN"
| Some p -> p with
| Not_found -> "mpirun"
) )
let qmcchem = lazy( let qmcchem = lazy(
@ -69,9 +66,7 @@ and qmc = lazy(
and qmcchem_info = lazy( and qmcchem_info = lazy(
Filename.concat (Lazy.force root) "bin/qmcchem_info" 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( and qmc_create_walkers = lazy(
Filename.concat (Lazy.force root) "bin/qmc_create_walkers" 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 ( let ip_address = lazy (
match Sys.getenv "QMCCHEM_NIC" with let interface =
| None -> try Some (Sys.getenv "QMCCHEM_NIC")
with Not_found -> None
in
match interface with
| None ->
begin begin
try try
Lazy.force hostname let host =
|> Unix.Inet_addr.of_string_or_getbyname Lazy.force hostname
|> Unix.Inet_addr.to_string |> Unix.gethostbyname
in
Unix.string_of_inet_addr host.h_addr_list.(0);
with with
| Unix.Unix_error _ -> | Unix.Unix_error _ ->
failwith "Unable to find IP address from host name." failwith "Unable to find IP address from host name."
end end
| Some interface -> | Some interface ->
begin let result = get_ipv4_address_for_interface interface in
try if String.sub result 0 5 = "error" then
ok_exn Linux_ext.get_ipv4_address_for_interface interface Printf.sprintf "Unable to use network interface %s" interface
with |> failwith
| Unix.Unix_error _ -> else
Lazy.force hostname result
|> Unix.Inet_addr.of_string_or_getbyname
|> Unix.Inet_addr.to_string
end
) )

245
ocaml/Qmcchem_edit.ml
View File

@ -1,5 +1,3 @@
open Core
let file_header filename = Printf.sprintf let file_header filename = Printf.sprintf
" "
+----------------------------------------------------------------+ +----------------------------------------------------------------+
@ -12,7 +10,7 @@ Editing file `%s`
let make_header s = let make_header s =
let l = String.length s in 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 = type field =
@ -84,11 +82,11 @@ let create_temp_file ?temp_filename ezfio_filename fields =
| None -> Filename.temp_file "qmcchem_edit_" ".rst" | None -> Filename.temp_file "qmcchem_edit_" ".rst"
| Some name -> name | Some name -> name
in in
Out_channel.with_file filename ~f:(fun out_channel -> let out_channel = open_out filename in
(file_header ezfio_filename) :: (List.map ~f:get fields) (file_header ezfio_filename) :: (List.map get fields)
|> String.concat ~sep:"\n" |> String.concat "\n"
|> Out_channel.output_string out_channel |> output_string out_channel
) ; close_out out_channel
; filename ; filename
@ -104,7 +102,7 @@ let write_input_in_ezfio ezfio_filename fields =
let input_filename = let input_filename =
create_temp_file ~temp_filename ezfio_filename fields create_temp_file ~temp_filename ezfio_filename fields
in in
assert (Sys.file_exists_exn input_filename) assert (Sys.file_exists input_filename)
(** Run the edit command *) (** 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 ();
in in
handle_option Input.Ref_energy.(of_float , write) e; handle_option Input.Ref_energy.(of_string, write) e;
handle_option Input.Trial_wf_energy.(of_float , write) et; handle_option Input.Trial_wf_energy.(of_string, write) et;
handle_option Input.Jastrow_type.(of_string, write) j; 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.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.Sampling.(of_string, write) s;
handle_option Input.Fitcusp_factor.(of_float , write) f; handle_option Input.Fitcusp_factor.(of_string, write) f;
handle_option Input.Time_step.(of_float , write) ts; handle_option Input.Time_step.(of_string, write) ts;
handle_option Input.Walk_num.(of_int , write) w; handle_option Input.Walk_num.(of_string, write) w;
handle_option Input.Walk_num_tot.(of_int , write) wt; handle_option Input.Walk_num_tot.(of_string, write) wt;
handle_option Input.CI_threshold.(of_float , write) n; handle_option Input.CI_threshold.(of_string, write) n;
handle_option Input.SRMC_projection_time.(of_float , write) p; handle_option Input.SRMC_projection_time.(of_string, write) p;
let fields = 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 if (not !interactive) then
failwith "Input file not allowed with command line arguments" failwith "Input file not allowed with command line arguments"
else else
begin let rc =
Printf.sprintf "cp %s %s" filename temp_filename Printf.sprintf "cp %s %s" filename temp_filename
|> Sys.command_exn ; |> Sys.command
end in
assert (rc = 0)
end end
| None -> | None ->
begin begin
(* Open the temp file with external editor *) (* Open the temp file with external editor *)
let editor = let editor =
match Sys.getenv "EDITOR" with try Sys.getenv "EDITOR" with
| Some editor -> editor | Not_found -> "vi"
| None -> "vi"
in in
Printf.sprintf "%s %s ; tput sgr0 2> /dev/null" editor temp_filename let rc =
|> Sys.command_exn Printf.sprintf "%s %s ; tput sgr0 2> /dev/null" editor temp_filename
|> Sys.command
in
assert (rc = 0)
end end
in 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 = and re_prop =
Str.regexp "([ xX]) .*$" Str.regexp "([ xX]) .*$"
and raw_data = 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 in
let data = let data =
( List.filter raw_data ~f:(fun x -> Str.string_match re_data x 0) ( List.filter (fun x -> Str.string_match re_data x 0) raw_data
|> List.map ~f:String.strip ) @ |> List.map String.trim ) @
[ [
List.filter raw_data ~f:(fun x -> Str.string_match re_prop x 0) List.filter (fun x -> Str.string_match re_prop x 0) raw_data
|> List.map ~f:String.strip |> List.map String.trim
|> String.concat ~sep:"\n" ] |> String.concat "\n" ]
in in
let open Input in let open Input in
List.iter2_exn data fields ~f:(fun s f -> List.iter2 (fun s f ->
try try
begin begin
match f with 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 end
with with
| Failure msg -> Printf.eprintf "%s\n" msg | Failure msg -> Printf.eprintf "%s\n" msg
); ) data fields ;
(* Remove temp_file *) (* Remove temp_file *)
Sys.remove temp_filename; 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 if c then
begin begin
let dirname = let dirname =
Filename.concat (Filename.concat ezfio_filename "blocks") (QmcMd5.hash ()) Filename.concat (Filename.concat ezfio_filename "blocks") (QmcMd5.hash ())
in in
let rec clean_dir y = let rec clean_dir y =
match Sys.is_directory y with if Sys.is_directory y then
| `Yes -> begin
Sys.ls_dir y Sys.readdir y
|> List.map ~f:(Filename.concat y) |> Array.map (fun x -> Filename.concat y x)
|> List.iter ~f:(function x -> |> Array.iter (function x ->
match ( Sys.is_directory x, Sys.is_file x ) with if Sys.is_directory x then
| (`Yes, _) -> clean_dir x clean_dir x
| (_, `Yes) -> Sys.remove x else
| (_,_) -> () Sys.remove x
); );
Unix.rmdir y Unix.rmdir y
| `Unknown end
| `No -> () in clean_dir dirname;
in clean_dir dirname; Printf.printf "Blocks cleared\n"
Printf.printf "Blocks cleared\n" end
end
; ;
Input.validate (); 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 write_input_in_ezfio ezfio_filename fields
let spec = let () =
let open Command.Spec in let open Command_line in
empty begin
+> flag "c" no_arg set_header_doc (Sys.argv.(0) ^ " - QMC=Chem command");
~doc:(" Clear blocks") set_description_doc "Edits input data";
+> 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 command = [ { short='c' ; long="clear" ; opt=Optional ;
Command.basic_spec doc="Clears blocks" ;
~summary: "Edit input data" arg=Without_arg ; };
~readme:(fun () ->
" { short='e' ; long="ref-energy" ; opt=Optional ;
Edit input data doc=Input.Ref_energy.doc;
") arg=With_arg "<float>"; };
spec
(fun c f t l m e et s ts w wt n j p ezfio_file input () -> { short='f' ; long="fitcusp" ; opt=Optional ;
run ~c ?f ?t ?l ?m ?e ?et ?s ?ts ?w ?wt ?n ?j ?p ?input ezfio_file ) doc=Input.Fitcusp_factor.doc;
arg=With_arg "<float>"; };
{ short='i' ; long="time-step" ; opt=Optional ;
doc=Input.Time_step.doc;
arg=With_arg "<float>"; };
{ short='j' ; long="jastrow" ; opt=Optional ;
doc=Input.Jastrow_type.doc;
arg=With_arg "<string>"; };
{ short='l' ; long="block-time" ; opt=Optional ;
doc=Input.Block_time.doc;
arg=With_arg "<int>"; };
{ short='m' ; long="method" ; opt=Optional ;
doc=Input.Method.doc;
arg=With_arg "<string>"; };
{ short='n' ; long="norm" ; opt=Optional ;
doc=Input.CI_threshold.doc;
arg=With_arg "<float>"; };
{ short='p' ; long="projection-time" ; opt=Optional ;
doc=Input.SRMC_projection_time.doc;
arg=With_arg "<float>"; };
{ short='r' ; long="trial-energy" ; opt=Optional ;
doc=Input.Trial_wf_energy.doc;
arg=With_arg "<float>"; };
{ short='s' ; long="sampling" ; opt=Optional ;
doc=Input.Sampling.doc;
arg=With_arg "<string>"; };
{ short='t' ; long="stop-time" ; opt=Optional ;
doc=Input.Stop_time.doc;
arg=With_arg "<int>"; };
{ short='w' ; long="walk-num" ; opt=Optional ;
doc=Input.Walk_num.doc;
arg=With_arg "<int>"; };
{ short='x' ; long="walk-num-tot" ; opt=Optional ;
doc=Input.Walk_num_tot.doc;
arg=With_arg "<int>"; };
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

17
ocaml/Qputils.ml
View File

@ -1,27 +1,26 @@
open Core
let split_re = let split_re =
Str.regexp " +" Str.regexp " +"
let split s = let split s =
String.strip s String.trim s
|> Str.split split_re |> Str.split split_re
let set_ezfio_filename ezfio_filename = let set_ezfio_filename ezfio_filename =
let () = let () =
if (not (Sys.file_exists_exn ezfio_filename)) then if (not (Sys.file_exists ezfio_filename)) then
failwith (ezfio_filename^" does not exist") failwith (ezfio_filename^" does not exist")
in in
let () = let () =
match (Sys.is_directory ezfio_filename) with if Sys.is_directory ezfio_filename then
| `Yes -> Ezfio.set_file ezfio_filename ; Ezfio.set_file ezfio_filename
| _ -> failwith ("Error : "^ezfio_filename^" is not a directory") else
failwith ("Error : "^ezfio_filename^" is not a directory")
in in
let dir, result = let dir, result =
Filename.realpath ezfio_filename Filename.dirname ezfio_filename,
|> Filename.split Filename.basename ezfio_filename
in in
Unix.chdir dir ; Unix.chdir dir ;
Ezfio.set_file result Ezfio.set_file result

94
ocaml/Random_variable.ml
View File

@ -1,4 +1,3 @@
open Core
open Qptypes open Qptypes
type t = type t =
@ -26,7 +25,7 @@ module Skewness: sig
val to_string : t -> string val to_string : t -> string
end = struct end = struct
type t = float type t = float
let to_string = Float.to_string let to_string = string_of_float
let to_float x = x let to_float x = x
let of_float x = x let of_float x = x
end end
@ -38,7 +37,7 @@ module Kurtosis: sig
val to_string : t -> string val to_string : t -> string
end = struct end = struct
type t = float type t = float
let to_string = Float.to_string let to_string = string_of_float
let to_float x = x let to_float x = x
let of_float x = x let of_float x = x
end end
@ -64,7 +63,7 @@ end = struct
(x -. mu) *. ( x -. mu) /. sigma2 (x -. mu) *. ( x -. mu) /. sigma2
in in
let pi = let pi =
Float.acos (-1.) acos (-1.)
in in
let c = let c =
1. /. (sqrt (sigma2 *. (pi +. pi))) 1. /. (sqrt (sigma2 *. (pi +. pi)))
@ -79,15 +78,15 @@ end
let of_raw_data ?(locked=true) ~range property = let of_raw_data ?(locked=true) ~range property =
let data = let data =
Block.raw_data ~locked () Block.raw_data ~locked ()
|> List.filter ~f:(fun x -> x.Block.property = property) |> List.filter (fun x -> x.Block.property = property)
in in
let data_in_range rmin rmax = let data_in_range rmin rmax =
let total_weight = let total_weight =
List.fold_left data ~init:0. ~f:(fun accu x -> List.fold_left (fun accu x ->
(Weight.to_float x.Block.weight) +. accu (Weight.to_float x.Block.weight) +. accu
) ) 0. data
in in
let wmin, wmax = let wmin, wmax =
@ -96,7 +95,7 @@ let of_raw_data ?(locked=true) ~range property =
in in
let (_, new_data) = 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 if (wsum > wmax) then
(wsum,l) (wsum,l)
else else
@ -109,7 +108,7 @@ let of_raw_data ?(locked=true) ~range property =
else else
(wsum_new, l) (wsum_new, l)
end end
) ) (0.,[]) data
in in
List.rev new_data List.rev new_data
in in
@ -127,13 +126,13 @@ let of_raw_data ?(locked=true) ~range property =
let average { property ; data } = let average { property ; data } =
if Property.is_scalar property then if Property.is_scalar property then
let (num,denom) = let (num,denom) =
List.fold ~init:(0., 0.) ~f:(fun (an, ad) x -> List.fold_left (fun (an, ad) x ->
let num = let num =
(Weight.to_float x.Block.weight) *. (Sample.to_float x.Block.value) (Weight.to_float x.Block.weight) *. (Sample.to_float x.Block.value)
and den = and den =
(Weight.to_float x.Block.weight) (Weight.to_float x.Block.weight)
in (an +. num, ad +. den) in (an +. num, ad +. den)
) data ) (0., 0.) data
in in
num /. denom num /. denom
|> Average.of_float |> Average.of_float
@ -144,20 +143,18 @@ let average { property ; data } =
| x :: tl -> Sample.dimension x.Block.value | x :: tl -> Sample.dimension x.Block.value
in in
let (num,denom) = 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 = let num =
Array.map (Sample.to_float_array x.Block.value) ~f:(fun y -> Array.map (fun y -> (Weight.to_float x.Block.weight) *. y)
(Weight.to_float x.Block.weight) *. y) (Sample.to_float_array x.Block.value)
and den = (Weight.to_float x.Block.weight) and den = (Weight.to_float x.Block.weight)
in ( in ( Array.mapi (fun i y -> y +. num.(i)) an , ad +. den)
Array.mapi an ~f:(fun i y -> y +. num.(i)) , ) (Array.make dim 0. , 0.) data
ad +. den)
) data
in in
let denom_inv = let denom_inv =
1. /. denom 1. /. denom
in in
Array.map num ~f:(fun x -> x *. denom_inv) Array.map (fun x -> x *. denom_inv) num
|> Average.of_float_array ~dim |> Average.of_float_array ~dim
@ -166,10 +163,10 @@ let average { property ; data } =
(** Compute sum (for CPU/Wall time) *) (** Compute sum (for CPU/Wall time) *)
let sum { property ; data } = 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) let num = (Weight.to_float x.Block.weight) *. (Sample.to_float x.Block.value)
in accu +. num in accu +. num
) ) 0. data
@ -181,7 +178,7 @@ let ave_error { property ; data } =
begin begin
if (n > 0.) then if (n > 0.) then
( Average.of_float (sum /. ansum), ( 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 else
( Average.of_float (sum /. ansum), None) ( Average.of_float (sum /. ansum), None)
end end
@ -220,10 +217,10 @@ let ave_error { property ; data } =
in in
if (Property.is_scalar property) then if (Property.is_scalar property) then
List.map data ~f:(fun x -> List.map (fun x ->
(Sample.to_float x.Block.value, (Sample.to_float x.Block.value,
Weight.to_float x.Block.weight) Weight.to_float x.Block.weight)
) ) data
|> ave_error_scalar |> ave_error_scalar
else else
match data with match data with
@ -234,22 +231,22 @@ let ave_error { property ; data } =
|> Sample.dimension |> Sample.dimension
in in
let result = let result =
Array.init dim ~f:(fun idx -> Array.init dim (fun idx ->
List.map list_of_samples ~f:(fun x -> List.map (fun x ->
(Sample.to_float ~idx x.Block.value, (Sample.to_float ~idx x.Block.value,
Weight.to_float x.Block.weight) Weight.to_float x.Block.weight)
) ) list_of_samples
|> ave_error_scalar |> ave_error_scalar
) )
in 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 , |> Average.of_float_array ~dim ,
if (Array.length result < 2) then if (Array.length result < 2) then
None None
else else
Some (Array.map result ~f:(function Some (Array.map (function
| (_,Some y) -> Error.to_float y | (_,Some y) -> Error.to_float y
| (_,None) -> 0.) | (_,None) -> 0.) result
|> Average.of_float_array ~dim) |> Average.of_float_array ~dim)
) )
@ -258,14 +255,17 @@ let ave_error { property ; data } =
(** Fold function for block values *) (** Fold function for block values *)
let fold_blocks ~f { property ; data } = let fold_blocks ~f { property ; data } =
let init = match List.hd data with let init =
| None -> 0. try
| Some block -> Sample.to_float block.Block.value let block = List.hd data in
Sample.to_float block.Block.value
with
| Failure "hd" -> 0.
in 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 let x = Sample.to_float block.Block.value
in f accu x in f accu x
) ) init data
@ -288,7 +288,7 @@ let convergence { property ; data } =
in in
let accu = let accu =
if (n > 0.) then if (n > 0.) then
(sum /. ansum, sqrt ( Float.abs ( avsq /.( ansum *. n))))::accu (sum /. ansum, sqrt ( abs_float ( avsq /.( ansum *. n))))::accu
else else
(sum /. ansum, 0.)::accu (sum /. ansum, 0.)::accu
in in
@ -478,7 +478,7 @@ let error_x_over_y = function
n := !n +. 1. n := !n +. 1.
); );
let arg = let arg =
Float.abs (!avsq /.(!ansum *. (!n -. 1.))) abs_float (!avsq /.(!ansum *. (!n -. 1.)))
in in
let error = let error =
sqrt arg sqrt arg
@ -720,11 +720,11 @@ let autocovariance { property ; data } =
in in
let f i = let f i =
let denom = let denom =
if (i > 1) then (Float.of_int i) else 1. if (i > 1) then (float_of_int i) else 1.
in in
let r = let r =
Array.sub ~pos:0 ~len:i x_t 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)) accu +. x *. x_t.(i))
in in
r /. denom r /. denom
@ -749,7 +749,7 @@ let centered_cumulants { property ; data } =
in in
let var = let var =
let (num, denom) = 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 let x2 = x *. x
in in
let var = w *. x2 let var = w *. x2
@ -770,7 +770,7 @@ let centered_cumulants { property ; data } =
in in
let (cum3,cum4) = let (cum3,cum4) =
let (cum3, cum4, denom) = 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 let x2 = x *. x
in in
let cum3 = w *. x2 *. x let cum3 = w *. x2 *. x
@ -796,13 +796,13 @@ let histogram { property ; data } =
max -. min max -. min
and n = and n =
List.length data List.length data
|> Float.of_int |> float_of_int
|> sqrt |> sqrt
in in
let delta_x = let delta_x =
length /. (n-.1.) length /. (n-.1.)
and result = and result =
Array.init ~f:(fun _ -> 0.) (Int.of_float (n +. 1.)) Array.init ~f:(fun _ -> 0.) (int_of_float (n +. 1.))
in in
List.iter ~f:(fun x -> List.iter ~f:(fun x ->
let w = let w =
@ -812,17 +812,17 @@ let histogram { property ; data } =
in in
let i = let i =
(x -. min) /. delta_x +. 0.5 (x -. min) /. delta_x +. 0.5
|> Float.to_int |> int_of_float
in in
result.(i) <- result.(i) +. w result.(i) <- result.(i) +. w
) data ) data
; ;
let norm = let norm =
1. /. ( delta_x *. ( 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 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 |> Array.to_list

9
ocaml/Sample.ml
View File

@ -1,5 +1,3 @@
open Core
type t = type t =
| One_dimensional of float | One_dimensional of float
| Multidimensional of (float array * int) | Multidimensional of (float array * int)
@ -38,9 +36,10 @@ let of_float_array ~dim x =
| _ -> Multidimensional (x, dim) | _ -> Multidimensional (x, dim)
let to_string = function let to_string = function
| One_dimensional x -> Float.to_string x | One_dimensional x -> string_of_float x
| Multidimensional (x,_) -> | Multidimensional (x,_) ->
Array.map x ~f:Float.to_string Array.map string_of_float x
|> String.concat_array ~sep:" " |> Array.to_list
|> String.concat " "
|> Printf.sprintf "%s" |> Printf.sprintf "%s"

2
ocaml/Sample.mli
View File

@ -1,5 +1,3 @@
open Core
type t [@@ deriving sexp] type t [@@ deriving sexp]
val to_float : ?idx:int -> t -> float val to_float : ?idx:int -> t -> float
val to_float_array : t -> float array val to_float_array : t -> float array

10
ocaml/Scheduler.ml
View File

@ -1,5 +1,3 @@
open Core
type t = type t =
| SGE | SGE
| PBS | PBS
@ -18,12 +16,10 @@ let to_string = function
let find () = let find () =
let scheduler = let scheduler =
[ "SLURM_NODELIST" ; "PE_HOSTFILE" ; "PBS_NODEFILE" ] [ "SLURM_NODELIST" ; "PE_HOSTFILE" ; "PBS_NODEFILE" ]
|> List.map ~f:(function x -> |> List.map (function x ->
match (Sys.getenv x) with try Some (Sys.getenv x) with
| Some _ -> x | Not_found -> None
| None -> ""
) )
|> List.filter ~f:(function x -> x <> "")
|> List.hd |> List.hd
in in
let result = let result =

160
ocaml/String_ext.ml Normal file
View File

@ -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 []

47
ocaml/Watchdog.ml
View File

@ -1,5 +1,3 @@
open Core
let _list = ref [] ;; let _list = ref [] ;;
let _running = ref false;; let _running = ref false;;
let _threads = ref [] ;; let _threads = ref [] ;;
@ -7,10 +5,10 @@ let _threads = ref [] ;;
(** Kill the current process and all children *) (** Kill the current process and all children *)
let kill () = let kill () =
let kill pid = let kill pid =
Signal.send_i Signal.int (`Pid pid); Unix.kill pid Sys.sigint;
Printf.printf "Killed %d\n%!" (Pid.to_int pid) Printf.printf "Killed %d\n%!" pid
in in
List.iter ~f:kill (!_list); List.iter kill (!_list);
exit 1 exit 1
;; ;;
@ -25,14 +23,11 @@ let start () =
_running := true; _running := true;
let pause () = let pause () =
Time.Span.of_sec 1. Unix.sleep 1
|> Time.pause
in in
let pid_is_running pid = let pid_is_running pid =
match (Sys.file_exists ("/proc/"^(Pid.to_string pid)^"/stat")) with Sys.file_exists ("/proc/"^(string_of_int pid)^"/stat")
| `No | `Unknown -> false
| `Yes -> true
in in
let f () = let f () =
@ -41,13 +36,13 @@ let start () =
pause () ; pause () ;
(*DEBUG (*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 () = let continue () =
List.fold_left (!_list) ~init:true ~f:( List.fold_left
fun accu x -> accu && (pid_is_running x) ( fun accu x -> accu && (pid_is_running x))
) true (!_list)
in in
if ( not (continue ()) ) then if ( not (continue ()) ) then
kill () kill ()
@ -90,24 +85,24 @@ let del pid =
;; ;;
(** Fork and exec a new process *) (** Fork and exec a new process *)
let fork_exec ~prog ~argv () = let fork_exec ~prog ~args () =
let pid = let pid =
Unix.fork_exec ~prog ~argv () match Unix.fork () with
| 0 -> (* Chile process *)
let _ = Unix.execv prog args in 0
| pid -> pid
in in
let f () = let f () =
add pid; add pid;
let success = let success =
match (Unix.waitpid pid) with match (Unix.waitpid [] pid) with
| Core_kernel.Std.Result.Ok () -> true | pid , Unix.WEXITED n -> true
| Core_kernel.Std.Result.Error (`Exit_non_zero n) -> | pid , Unix.WSIGNALED n ->
( Printf.printf "PID %d exited with code %d\n%!" ( Printf.printf "PID %d killed with signal %d\n%!" pid n;
(Pid.to_int pid) n ;
false ) false )
| Core_kernel.Std.Result.Error (`Signal n) -> | pid , Unix.WSTOPPED n ->
( Printf.printf "PID %d killed with signal %d (%s)\n%!" ( Printf.printf "PID %d stopped with signal %d\n%!" pid n;
(Pid.to_int pid) (Signal.to_system_int n)
(Signal.to_string n) ;
false ) false )
in in
del pid ; del pid ;
@ -121,6 +116,6 @@ let fork_exec ~prog ~argv () =
(** Wait for threads to finish *) (** Wait for threads to finish *)
let join () = let join () =
(* if (!_running) then stop (); *) (* if (!_running) then stop (); *)
List.iter ~f:Thread.join (!_threads); List.iter Thread.join (!_threads);
assert (not !_running) assert (not !_running)
;; ;;

6
ocaml/_tags Normal file
View File

@ -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)

84
ocaml/build.ninja
View File

@ -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

70
ocaml/c_bindings.c Normal file
View File

@ -0,0 +1,70 @@
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/custom.h>
#include <caml/threads.h>
#include <string.h>
/* Adapted from
https://github.com/monadbobo/ocaml-core/blob/master/base/core/lib/linux_ext_stubs.c
*/
#include <unistd.h>
#include <sys/ioctl.h>
#include <net/if.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <arpa/inet.h>
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);
}

13
ocaml/myocamlbuild.ml Normal file
View File

@ -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

294
ocaml/qptypes_generator.ml
View File

@ -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 = " let input_data = "
* Positive_float : float * Positive_float : float
assert (x >= 0.) ; if not (x >= 0.) then
raise (Invalid_argument (Printf.sprintf \"Positive_float : (x >= 0.) : x=%f\" x));
* Strictly_positive_float : float * Strictly_positive_float : float
assert (x > 0.) ; if not (x > 0.) then
raise (Invalid_argument (Printf.sprintf \"Strictly_positive_float : (x > 0.) : x=%f\" x));
* Negative_float : float * Negative_float : float
assert (x <= 0.) ; if not (x <= 0.) then
raise (Invalid_argument (Printf.sprintf \"Negative_float : (x <= 0.) : x=%f\" x));
* Strictly_negative_float : float * Strictly_negative_float : float
assert (x < 0.) ; if not (x < 0.) then
raise (Invalid_argument (Printf.sprintf \"Strictly_negative_float : (x < 0.) : x=%f\" x));
* Positive_int : int * Positive_int64 : int64
assert (x >= 0) ; if not (x >= 0L) then
raise (Invalid_argument (Printf.sprintf \"Positive_int64 : (x >= 0L) : x=%s\" (Int64.to_string x)));
* Strictly_positive_int : int * Positive_int : int
assert (x > 0) ; 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) ; assert (x <= 0) ;
* Det_coef : float * Det_coef : float
assert (x >= -1.) ; if (x < -1.) || (x > 1.) then
assert (x <= 1.) ; raise (Invalid_argument (Printf.sprintf \"Det_coef : (-1. <= x <= 1.) : x=%f\" x));
* Normalized_float : float * Normalized_float : float
assert (x <= 1.) ; if (x < 0.) || (x > 1.) then
assert (x >= 0.) ; raise (Invalid_argument (Printf.sprintf \"Normalized_float : (0. <= x <= 1.) : x=%f\" x));
* Strictly_negative_int : int * Strictly_negative_int : int
assert (x < 0) ; if not (x < 0) then
raise (Invalid_argument (Printf.sprintf \"Strictly_negative_int : (x < 0) : x=%d\" x));
* Non_empty_string : string * Non_empty_string : string
assert (x <> \"\") ; if (x = \"\") then
raise (Invalid_argument \"Non_empty_string\");
* Det_number_max : int * Det_number_max : int
assert (x > 0) ; assert (x > 0) ;
if (x > 100000000) then if (x > 100_000_000) then
warning \"More than 100 million determinants\"; 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 begin match x with
| 8 | 16 | 32 | 64 -> () | 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; end;
* Bit_kind : int * Bit_kind : int
begin match x with begin match x with
| 1 | 2 | 4 | 8 -> () | 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; end;
* Bitmask_number : int * Bitmask_number : int
assert (x > 0) ; assert (x > 0) ;
"^
*)
"
* MO_coef : float * MO_coef : float
* MO_occ : float * MO_occ : float
assert (x >= 0.); if x < 0. then 0. else
if x > 2. then 2. else
* AO_coef : float * AO_coef : float
* AO_expo : float * AO_expo : float
assert (x >= 0.) ; if (x < 0.) then
raise (Invalid_argument (Printf.sprintf \"AO_expo : (x >= 0.) : x=%f\" x));
* AO_prim_number : int * AO_prim_number : int
assert (x > 0) ; assert (x > 0) ;
@ -102,6 +115,12 @@ let input_data = "
* MD5 : string * MD5 : string
assert ((String.length x) = 32); 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 * Rst_string : string
@ -116,96 +135,96 @@ let input_data = "
assert (x <> \"\") ; assert (x <> \"\") ;
" "
;;
let input_ezfio = " let input_ezfio = "
* MO_number : int * MO_number : int
mo_basis_mo_tot_num mo_basis_mo_tot_num
1 : 10000 1 : 10_000
More than 10000 MOs More than 10_000 MOs
* AO_number : int * AO_number : int
ao_basis_ao_num ao_basis_ao_num
1 : 10000 1 : 10_000
More than 10000 AOs More than 10_000 AOs
* Nucl_number : int * Nucl_number : int
nuclei_nucl_num nuclei_nucl_num
1 : 10000 1 : 10_000
More than 10000 nuclei More than 10_000 nuclei
"^
(*
"
* N_int_number : int * N_int_number : int
determinants_n_int spindeterminants_n_int
1 : 30 1 : 30
N_int > 30 N_int > 30
* Det_number : int * Det_number : int
determinants_n_det spindeterminants_n_det
1 : 100000000 1 : 100_000_000
More than 100 million determinants More than 100 million determinants
"
*) "
""
;;
let untouched = " let untouched = "
" "
let template = format_of_string " let template = format_of_string "
module %s : sig module %s : sig
type t [@@ deriving sexp] type t [@@deriving sexp]
val to_%s : t -> %s val to_%s : t -> %s
val of_%s : %s %s -> t val of_%s : %s %s -> t
val to_string : t -> string val to_string : t -> string
end = struct end = struct
type t = %s [@@ deriving sexp] type t = %s [@@deriving sexp]
let to_%s x = x let to_%s x = x
let of_%s %s x = ( %s x ) let of_%s %s x = ( %s x )
let to_string x = %s.to_string x let to_string x = %s.to_string x
end end
" "
;;
let parse_input input= let parse_input input=
print_string "open Sexplib.Std\nlet warning = print_string\n" ;
let rec parse result = function let rec parse result = function
| [] -> result | [] -> result
| ( "" , "" )::tail -> parse result tail | ( "" , "" )::tail -> parse result tail
| ( t , text )::tail -> | ( t , text )::tail ->
let name,typ,params,params_val = let name,typ,params,params_val =
match String.split ~on:':' t with match String.split_on_char ':' t with
| [name;typ] -> (name,typ,"","") | [name;typ] -> (name,typ,"","")
| name::typ::params::params_val -> (name,typ,params, | name::typ::params::params_val -> (name,typ,params,
(String.concat params_val ~sep:":") ) (String.concat ":" params_val) )
| _ -> assert false | _ -> assert false
in in
let typ = String.strip typ let typ = String_ext.strip typ
and name = String.strip name in and name = String_ext.strip name in
let typ_cap = String.capitalize typ in let typ_cap = String.capitalize_ascii typ in
let newstring = Printf.sprintf template name typ typ typ params_val typ typ let newstring = Printf.sprintf template name typ typ typ params_val typ typ
typ typ params ( String.strip text ) typ_cap typ typ params ( String_ext.strip text ) typ_cap
in in
List.rev (parse (newstring::result) tail ) List.rev (parse (newstring::result) tail )
in in
String.split ~on:'*' input String_ext.split ~on:'*' input
|> List.map ~f:(String.lsplit2_exn ~on:'\n') |> List.map (String_ext.lsplit2_exn ~on:'\n')
|> parse [] |> parse []
|> String.concat |> String.concat ""
;; |> global_replace
|> print_string
let ezfio_template = format_of_string " let ezfio_template = format_of_string "
module %s : sig module %s : sig
type t [@@ deriving sexp] type t [@@deriving sexp]
val to_%s : t -> %s val to_%s : t -> %s
val get_max : unit -> %s val get_max : unit -> %s
val of_%s : ?min:%s -> ?max:%s -> %s -> t val of_%s : ?min:%s -> ?max:%s -> %s -> t
val to_string : t -> string val to_string : t -> string
end = struct end = struct
type t = %s [@@ deriving sexp] type t = %s [@@deriving sexp]
let to_string x = %s.to_string x let to_string x = %s.to_string x
let get_max () = let get_max () =
if (Ezfio.has_%s ()) then if (Ezfio.has_%s ()) then
@ -215,7 +234,7 @@ end = struct
let get_min () = let get_min () =
%s %s
let to_%s x = x 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 begin
assert (x >= min) ; assert (x >= min) ;
if (x > %s) then if (x > %s) then
@ -223,7 +242,9 @@ end = struct
begin begin
match max with match max with
| %s -> () | %s -> ()
| i -> assert ( x <= i ) | i ->
if ( x > i ) then
raise (Invalid_argument (Printf.sprintf \"%s: %%s\" (%s.to_string x) ))
end ; end ;
x x
end end
@ -232,104 +253,103 @@ end
let parse_input_ezfio input= let parse_input_ezfio input=
let parse s = let parse s =
match ( match (
String.split s ~on:'\n' String_ext.split s ~on:'\n'
|> List.filter ~f:(fun x -> (String.strip x) <> "") |> List.filter (fun x -> (String_ext.strip x) <> "")
) with ) with
| [] -> "" | [] -> ""
| a :: b :: c :: d :: [] -> | a :: b :: c :: d :: [] ->
begin begin
let (name,typ) = String.lsplit2_exn ~on:':' a let (name,typ) = String_ext.lsplit2_exn ~on:':' a
and ezfio_func = b and ezfio_func = b
and (min, max) = String.lsplit2_exn ~on:':' c and (min, max) = String_ext.lsplit2_exn ~on:':' c
and msg = d and msg = d
in in
let (name, typ, ezfio_func, min, max, msg) = let (name, typ, ezfio_func, min, max, msg) =
match (List.map [ name ; typ ; ezfio_func ; min ; max ; msg ] ~f:String.strip) with 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) | [ name ; typ ; ezfio_func ; min ; max ; msg ] -> (name, typ, ezfio_func, min, max, msg)
| _ -> assert false | _ -> assert false
in in
Printf.sprintf ezfio_template Printf.sprintf ezfio_template
name typ typ typ typ typ typ typ typ (String.capitalize typ) name typ typ typ typ typ typ typ typ (String.capitalize_ascii typ)
ezfio_func ezfio_func max min typ typ max msg min ezfio_func ezfio_func max min typ typ max msg min name (String.capitalize_ascii typ)
end end
| _ -> failwith "Error in input_ezfio" | _ -> failwith "Error in input_ezfio"
in in
String.split ~on:'*' input String_ext.split ~on:'*' input
|> List.map ~f:parse |> List.map parse
|> String.concat |> String.concat ""
|> global_replace
|> print_string
(** EZFIO *) (** 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 create_ezfio_handler () =
let lines = let lines =
In_channel.with_file "ezfio.ml" ~f:In_channel.input_lines input_lines "ezfio.ml"
|> List.filteri ~f:(fun i _ -> i > 470) |> 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 in
let functions = let functions =
List.map lines ~f:(fun x -> List.map (fun x ->
match String.split x ~on:' ' with match String.split_on_char ' ' x with
| _ :: x :: "()" :: "=" :: f :: dir :: item :: _-> (x, f, dir, item) | _ :: x :: "()" :: "=" :: f :: dir :: item :: _-> (x, f, dir, item)
| _ :: x :: "=" :: f :: dir :: item :: _-> (x, f, dir, item) | _ :: x :: "=" :: f :: dir :: item :: _-> (x, f, dir, item)
| _ -> ("","","","") | _ -> ("","","","")
) ) lines
in in
let has_functions = 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 = 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 in
let chop s =
match (Str.split_delim (Str.regexp ";;") s) with
| x :: _ -> x
| _ -> assert false
in
let result = let result =
[ "let decode_ezfio_message msg = [ "let decode_ezfio_message msg =
match msg with " ] @ match msg with " ] @
( (
List.map get_functions ~f:(fun (x,f,d,i) -> List.map (fun (x,f,d,i) ->
let i = let i = chop i in
match (String.chop_suffix i ~suffix:";;") with if (String.sub f ((String.length f)-6) 6 = "_array") then
| Some x -> x
| None -> i
in
if (String.is_suffix f ~suffix:"_array") then
Printf.sprintf " | \"%s\" -> Printf.sprintf " | \"%s\" ->
Ezfio.read_string_array %s %s Ezfio.read_string_array %s %s
|> Ezfio.flattened_ezfio |> Ezfio.flattened_ezfio
|> Array.to_list |> Array.to_list
|> String.concat ~sep:\" \"" x d i |> String.concat \" \"" x d i
else else
Printf.sprintf " | \"%s\" -> Ezfio.read_string %s %s" x d i 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 Printf.sprintf " | \"%s\" -> if (Ezfio.%s ()) then \"T\" else \"F\"" x x
) ) has_functions
) @ [" | x -> failwith (x^\" : Unknown EZFIO function\")\n;;"] ) @ [" | x -> failwith (x^\" : Unknown EZFIO function\")\n;;"]
in in
String.concat result ~sep:"\n" String.concat "\n" result
(** Main *) (** Main *)
let () =
let () = parse_input input_data ;
let input = parse_input_ezfio input_ezfio;
String.concat ~sep:"\n" print_endline untouched
[ "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