Index: trunk/circe2/src/events.mli =================================================================== --- trunk/circe2/src/events.mli (revision 8809) +++ trunk/circe2/src/events.mli (revision 8810) @@ -1,56 +1,55 @@ (* circe2/events.mli -- *) (* Copyright (C) 2001-2022 by Thorsten Ohl Circe2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Circe2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* We're dealing with Fortran style \texttt{DOUBLE PRECISION} arrays exclusively. *) type t = (float, Bigarray.float64_elt, Bigarray.fortran_layout) Bigarray.Array2.t (* Read an ASCII representation of a big array from a channel or a file. The array is read in pieces of [chunk] columns each; the default value for [chunk] is 100000. The number of rows is given by the integer argument, while the number of columns is determined by the number of lines in the file. If the [file] argument is present the resulting bigarray is mapped to a file. *) val of_ascii_channel : ?file:string -> ?chunk:int -> int -> in_channel -> t val of_ascii_file : ?file:string -> ?chunk:int -> int -> string -> t (* Map a file containing a binary representation of a big array. The number of rows is again given by the argument and the number of columns is determined by the size of the file. The first version does a read-only (or rather copy-on-write) map, while the second version allows modifications. *) val of_binary_file : int -> string -> t val shared_map_binary_file : int -> string -> t (* Selfexplaining, hopefully \ldots *) val to_ascii_channel : out_channel -> t -> unit val to_ascii_file : string -> t -> unit val to_binary_file : string -> t -> unit (* Rescale the entries. *) val rescale : float -> float -> t -> unit (* Utilities for reading ASCII representations. *) -val lexer : char Stream.t -> Genlex.token Stream.t -val next_float : Genlex.token Stream.t -> float +val next_float : Lexing.lexbuf -> float (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/circe2/src/Makefile.sources =================================================================== --- trunk/circe2/src/Makefile.sources (revision 8809) +++ trunk/circe2/src/Makefile.sources (revision 8810) @@ -1,75 +1,75 @@ # Makefile.sources -- Makefile component for O'Mega ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## ## We define the source files in a separate file so that they can be ## include by Makefiles in multiple directories. ## ######################################################################## ######################################################################## # # O'Caml sources # ######################################################################## CIRCE2_ML_SRC_1 = \ OUnit.ml OUnitDiff.ml thoArray.ml thoMatrix.ml \ float.ml diffmap.ml diffmaps.ml filter.ml division.ml grid.ml \ - events.ml syntax.ml -CIRCE2_LEXER = lexer.mll + syntax.ml +CIRCE2_LEXER = lexer.mll events_lexer.mll CIRCE2_PARSER = parser.mly -CIRCE2_ML_SRC_2 = commands.ml histogram.ml +CIRCE2_ML_SRC_2 = events.ml commands.ml histogram.ml CIRCE2_ML_SRC = $(CIRCE2_ML_SRC_1) $(CIRCE2_ML_SRC_2) CIRCE2_MLI_SRC = $(CIRCE2_ML_SRC:.ml=.mli) CIRCE2_ML_DERIVED = $(CIRCE2_LEXER:.mll=.ml) $(CIRCE2_PARSER:.mly=.ml) CIRCE2_MLI_DERIVED = $(CIRCE2_ML_DERIVED:.ml=.mli) CIRCE2_SRC = $(CIRCE2_ML_SRC) $(CIRCE2_MLI_SRC) $(CIRCE2_LEXER) $(CIRCE2_PARSER) CIRCE2_DERIVED = $(CIRCE2_ML_DERIVED) $(CIRCE2_MLI_DERIVED) CIRCE2_ML = $(CIRCE2_ML_SRC_1) $(CIRCE2_ML_DERIVED) $(CIRCE2_ML_SRC_2) CIRCE2_MLI = $(CIRCE2_ML:.ml=.mli) CIRCE2_CMO = bigarray_compat.cmo $(CIRCE2_ML:.ml=.cmo) CIRCE2_CMX = bigarray_compat.cmx $(CIRCE2_ML:.ml=.cmx) CIRCE2_CMI = bigarray_compat.cmi $(CIRCE2_ML:.ml=.cmi) CIRCE2_INTERFACE = $(CIRCE2_ML:.ml=.interface) CIRCE2_IMPLEMENTATION = $(CIRCE2_ML:.ml=.implementation) CIRCE2TOOL_ML = circe2_tool.ml CIRCE2TOOL_SRC = $(CIRCE2TOOL_ML) CIRCE2TOOL_CMO = $(CIRCE2TOOL_ML:.ml=.cmo) CIRCE2TOOL_CMX = $(CIRCE2TOOL_ML:.ml=.cmx) CIRCE2TOOL_IMPLEMENTATION = $(CIRCE2TOOL_ML:.ml=.implementation) CIRCE2_BYTECODE = $(CIRCE2TOOL_ML:.ml=$(OCAML_BYTECODE_EXT)) CIRCE2_NATIVE = $(CIRCE2TOOL_ML:.ml=$(OCAML_NATIVE_EXT)) CIRCE2_CAML = $(CIRCE2_SRC) $(CIRCE2_DERIVED) $(CIRCE2TOOL_SRC) Index: trunk/circe2/src/histogram.ml =================================================================== --- trunk/circe2/src/histogram.ml (revision 8809) +++ trunk/circe2/src/histogram.ml (revision 8810) @@ -1,223 +1,223 @@ (* circe2/histogram.ml -- *) (* Copyright (C) 2001-2022 by Thorsten Ohl Circe2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Circe2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Printf type t = { n_bins : int; n_bins_float : float; x_min : float; x_max : float; x_min_eps : float; x_max_eps : float; mutable n_underflow : int; mutable underflow : float; mutable underflow2 : float; mutable n_overflow : int; mutable overflow : float; mutable overflow2 : float; n : int array; w : float array; w2 : float array } let create n_bins x_min x_max = let eps = 100. *. Float.Double.epsilon *. abs_float (x_max -. x_min) in { n_bins = n_bins; n_bins_float = float n_bins; x_min = x_min; x_max = x_max; x_min_eps = x_min -. eps; x_max_eps = x_max +. eps; n_underflow = 0; underflow = 0.0; underflow2 = 0.0; n_overflow = 0; overflow = 0.0; overflow2 = 0.0; n = Array.make n_bins 0; w = Array.make n_bins 0.0; w2 = Array.make n_bins 0.0 } let record h x f = let i = truncate (floor (h.n_bins_float *. (x -. h.x_min) /. (h.x_max -. h.x_min))) in let i = if i < 0 && x > h.x_min_eps then 0 else if i >= h.n_bins - 1 && x < h.x_max_eps then h.n_bins - 1 else i in if i < 0 then begin h.n_underflow <- h.n_underflow + 1; h.underflow <- h.underflow +. f; h.underflow2 <- h.underflow2 +. f *. f end else if i >= h.n_bins then begin h.n_overflow <- h.n_overflow + 1; h.overflow <- h.overflow +. f; h.overflow2 <- h.overflow2 +. f *. f end else begin h.n.(i) <- h.n.(i) + 1; h.w.(i) <- h.w.(i) +. f; h.w2.(i) <- h.w2.(i) +. f *. f end let normalize h = let sum_w = Array.fold_left (+.) (h.underflow +. h.overflow) h.w in let sum_w2 = sum_w *. sum_w in { n_bins = h.n_bins; n_bins_float = h.n_bins_float; x_min = h.x_min; x_max = h.x_max; x_min_eps = h.x_min_eps; x_max_eps = h.x_max_eps; n_underflow = h.n_underflow; underflow = h.underflow /. sum_w; underflow2 = h.underflow2 /. sum_w2; n_overflow = h.n_overflow; overflow = h.overflow /. sum_w; overflow2 = h.overflow2 /. sum_w2; n = Array.copy h.n; w = Array.map (fun w' -> w' /. sum_w) h.w; w2 = Array.map (fun w2' -> w2' /. sum_w2) h.w2 } let to_channel oc h = for i = 0 to h.n_bins - 1 do let x_mid = h.x_min +. (h.x_max -. h.x_min) *. (float i +. 0.5) /. h.n_bins_float in if h.n.(i) > 1 then let n = float h.n.(i) in - let var1 = (h.w2.(i) /. n -. (h.w.(i) /. n) ** 2.0) /. (n -. 1.0) - and var2 = h.w.(i) ** 2.0 /. (n *. (n -. 1.0)) in + (* [let var1 = (h.w2.(i) /. n -. (h.w.(i) /. n) ** 2.0) /. (n -. 1.0)] *) + let var2 = h.w.(i) ** 2.0 /. (n *. (n -. 1.0)) in let var = var2 in fprintf oc " %.17E %.17E %.17E\n" x_mid h.w.(i) (sqrt var) else if h.n.(i) = 1 then fprintf oc " %.17E %.17E %.17E\n" x_mid h.w.(i) h.w.(i) else fprintf oc " %.17E %.17E\n" x_mid h.w.(i) done let as_bins_to_channel oc h = for i = 0 to h.n_bins - 1 do let x_min = h.x_min +. (h.x_max -. h.x_min) *. (float i) /. h.n_bins_float and x_max = h.x_min +. (h.x_max -. h.x_min) *. (float i +. 1.0) /. h.n_bins_float in fprintf oc " %.17e %.17e\n" x_min h.w.(i); fprintf oc " %.17e %.17e\n" x_max h.w.(i) done (*i let to_channel oc h = for i = 0 to h.n_bins - 1 do let x_min = h.x_min +. (h.x_max -. h.x_min) *. (float i) /. h.n_bins_float and x_max = h.x_min +. (h.x_max -. h.x_min) *. (float i +. 1.0) /. h.n_bins_float in fprintf oc " %.17E 0\n" x_min; fprintf oc " %.17E %.17E\n" x_min h.w.(i); fprintf oc " %.17E %.17E\n" x_max h.w.(i); fprintf oc " %.17E 0\n" x_max done i*) let to_file name h = let oc = open_out name in to_channel oc h; close_out oc let as_bins_to_file name h = let oc = open_out name in as_bins_to_channel oc h; close_out oc (* \subsection{Naive Linear Regression} *) type regression_moments = { mutable n : int; mutable x : float; mutable y : float; mutable xx : float; mutable xy : float } let init_regression_moments = { n = 0; x = 0.0; y = 0.0; xx = 0.0; xy = 0.0 } let record_regression m x y = m.n <- m.n + 1; m.x <- m.x +. x; m.y <- m.y +. y; m.xx <- m.xx +. x *. x; m.xy <- m.xy +. x *. y (* Minimize \begin{equation} f(a,b) = \sum_{i} w_{i} (ax_{i}+b-y_{i})^2 = \langle(ax+b-y)^2\rangle \end{equation} i.\,e. \begin{subequations} \begin{align} \frac{1}{2}\frac{\partial f}{\partial a}(a,b) &= \langle x(ax+b-y) \rangle = a\langle x^2 \rangle + b\langle x \rangle - \langle xy \rangle = 0 \\ \frac{1}{2}\frac{\partial f}{\partial b}(a,b) &= \langle ax+b-y \rangle = a\langle x \rangle + b - \langle y \rangle = 0 \end{align} \end{subequations} and \begin{subequations} \begin{align} a &= \frac{\langle xy \rangle - \langle x \rangle \langle y \rangle}% {\langle x^2 \rangle - \langle x \rangle^2} \\ b &= \langle y \rangle - a\langle x \rangle \end{align} \end{subequations} *) let linear_regression m = let n = float m.n in let x = m.x /. n and y = m.y /. n and xx = m.xx /. n and xy = m.xy /. n in let a = (xy -. x *. y) /. (xx -. x *. x) in let b = y -. a *. x in (a, b) let regression h chi fx fy = let m = init_regression_moments in for i = 0 to h.n_bins - 1 do let x_mid = h.x_min +. (h.x_max -. h.x_min) *. (float i +. 0.5) /. h.n_bins_float in if chi x_mid then record_regression m (fx x_mid) (fy h.w.(i)) done; linear_regression m (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/circe2/src/events.ml =================================================================== --- trunk/circe2/src/events.ml (revision 8809) +++ trunk/circe2/src/events.ml (revision 8810) @@ -1,211 +1,202 @@ (* circe2/events.ml -- *) (* Copyright (C) 2001-2022 by Thorsten Ohl Circe2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Circe2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \subsubsection{Reading Bigarrays} *) (* Reading big arrays efficiently is not trivial, if we don't know the size of the arrays beforehand. Here we use the brute force approach of reading a list of not-so-big arrays and blitting them into the resulting array later. This avoids a second reading of the file, but temporarily needs twice the memory. *) open Bigarray open Printf let map_array2 = Bigarray_compat.map_array2 type t = (float, float64_elt, fortran_layout) Array2.t exception Incomplete of int * t (* Read lines from a channel into the columns of a bigarray. If the file turns out to be short, the exception [Incomplete (i2, array)] is raised with the number of columns actually read. *) let read_lines ic reader array i2_first i2_last = let i2 = ref i2_first in try while !i2 <= i2_last do let line = input_line ic in if line <> "" then begin reader array !i2 line; incr i2 end done with | End_of_file -> raise (Incomplete (pred !i2, array)) +let next_float lexbuf = + match Events_lexer.token lexbuf with + | None -> invalid_arg ("Events.next_float: expected float") + | Some x -> x + (* Decode a line of floating point numbers into a column of a bigarray. *) -(* Fortran allows ['d'] and ['D'] as exponent starter, but - O'Caml's [Genlex] doesn't accept it. *) - -let normalize_ascii_floats orig = - let normalized = Bytes.of_string orig in - for i = 0 to Bytes.length normalized - 1 do - let c = Bytes.get normalized i in - if c = 'd' || c = 'D' then - Bytes.set normalized i 'E' - done; - Bytes.to_string normalized - -let lexer = Genlex.make_lexer [] - -let next_float s = - match Stream.next s with - | Genlex.Int n -> float n - | Genlex.Float x -> x - | _ -> invalid_arg "Events.int_as_float" - let read_floats array i2 line = - let tokens = lexer (Stream.of_string (normalize_ascii_floats line)) in - for i1 = 1 to Array2.dim1 array do - Array2.set array i1 i2 (next_float tokens) - done + let lexbuf = Lexing.from_string line in + try + for i1 = 1 to Array2.dim1 array do + match Events_lexer.token lexbuf with + | None -> invalid_arg ("not enough floats in \"" ^ line ^ "\"") + | Some x -> Array2.set array i1 i2 x + done + with + | Failure t -> + invalid_arg ("invalid token '" ^ t ^ "' in \"" ^ line ^ "\"") (*i let read_floats array i2 line = let tokens = lexer (Stream.of_string (normalize_ascii_floats line)) in for i1 = 1 to Array2.dim1 array do array.{i1,i2} <- next_float tokens done i*) (* Try to read the columns of a bigarray from a channel. If the file turns out to be short, the exception~[Incomplete (dim2, array)] is raised with the number of columns actually read. *) let try_of_ascii_channel dim1 dim2 ic = let array = Array2.create float64 fortran_layout dim1 dim2 in read_lines ic read_floats array 1 dim2; (dim2, array) (* Read a~[dim1] floating point numbers per line into the columns of a reverted list of bigarrays, each with a maximum of~[chunk] columns. *) let rev_list_of_ascii_channel chunk dim1 ic = let rec rev_list_of_ascii_channel' acc = let continue = try let acc' = try_of_ascii_channel dim1 chunk ic :: acc in fun () -> rev_list_of_ascii_channel' acc' with | Incomplete (len, a) -> fun () -> (len, a) :: acc in continue () in rev_list_of_ascii_channel' [] (* Concatenate a list of bigarrays~$[(l_n,a_n);\ldots;(l_2,a_2);(l_1,a_1)]$ in reverse order~$a_1a_2\ldots a_n$. Of each array~$a_i$, only the first~$l_i$ columns are used. If the optional [file] name is present, map the corresponding file to the bigarray. We can close the file descriptor immediately, since \verb+close(2)+ does \emph{not} \verb+munmap(2)+. *) let create_array ?file dim1 dim2 = match file with | None -> Array2.create float64 fortran_layout dim1 dim2 | Some name -> let fd = Unix.openfile name [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o644 in let a = map_array2 fd float64 fortran_layout true dim1 dim2 in Unix.close fd; a let rev_concat ?file arrays = let sum_dim2 = List.fold_left (fun sum (dim2, _) -> sum + dim2) 0 arrays in if sum_dim2 <= 0 then invalid_arg "Events.rev_concat"; let dim1 = Array2.dim1 (snd (List.hd arrays)) in let array = create_array ?file dim1 sum_dim2 in let _ = List.fold_right (fun (dim2, a) ofs -> Array2.blit (Array2.sub_right a 1 dim2) (Array2.sub_right array ofs dim2); ofs + dim2) arrays 1 in array let of_ascii_channel ?file ?(chunk = 100000) dim1 ic = rev_concat ?file (rev_list_of_ascii_channel chunk dim1 ic) let of_ascii_file ?file ?chunk dim1 name = let ic = open_in name in let a = of_ascii_channel ?file ?chunk dim1 ic in close_in ic; a (* We can close the file descriptor immediately, since \verb+close(2)+ does \emph{not} \verb+munmap(2)+. *) let of_binary_file dim1 file = let fd = Unix.openfile file [Unix.O_RDONLY] 0o644 in let a = map_array2 fd float64 fortran_layout false dim1 (-1) in Unix.close fd; a let shared_map_binary_file dim1 file = let fd = Unix.openfile file [Unix.O_RDWR] 0o644 in let a = map_array2 fd float64 fortran_layout false dim1 (-1) in Unix.close fd; a let to_ascii_channel oc a = let dim1 = Array2.dim1 a and dim2 = Array2.dim2 a in for i2 = 1 to dim2 do for i1 = 1 to dim1 do fprintf oc " %.17E" (Array2.get a i1 i2) done; fprintf oc "\n" done (*i let to_ascii_channel oc a = let dim1 = Array2.dim1 a and dim2 = Array2.dim2 a in for i2 = 1 to dim2 do for i1 = 1 to dim1 do fprintf oc " %.17E" a.{i1,i2} done; fprintf oc "\n" done i*) let to_ascii_file name a = let oc = open_out name in to_ascii_channel oc a; close_out oc let to_binary_file file a = let fd = Unix.openfile file [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o644 in let a' = map_array2 fd float64 fortran_layout true (Array2.dim1 a) (Array2.dim2 a) in Unix.close fd; Array2.blit a a' let rescale scale1 scale2 data = for i2 = 1 to Array2.dim2 data do Array2.set data 1 i2 (Array2.get data 1 i2 /. scale1); Array2.set data 2 i2 (Array2.get data 2 i2 /. scale2) done (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/circe2/src/OUnit.mli =================================================================== --- trunk/circe2/src/OUnit.mli (revision 8809) +++ trunk/circe2/src/OUnit.mli (revision 8810) @@ -1,283 +1,278 @@ -(* circe2/oUnit.mli -- *) +(* oUnit.mli -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) (** Unit test building blocks @author Maas-Maarten Zeeman @author Sylvain Le Gall *) (** {2 Assertions} Assertions are the basic building blocks of unittests. *) (** Signals a failure. This will raise an exception with the specified string. @raise Failure signal a failure *) val assert_failure : string -> 'a (** Signals a failure when bool is false. The string identifies the failure. @raise Failure signal a failure *) val assert_bool : string -> bool -> unit (** Shorthand for assert_bool @raise Failure to signal a failure *) val ( @? ) : string -> bool -> unit (** Signals a failure when the string is non-empty. The string identifies the failure. @raise Failure signal a failure *) val assert_string : string -> unit (** [assert_command prg args] Run the command provided. @param exit_code expected exit code - @param sinput provide this [char Stream.t] as input of the process - @param foutput run this function on output, it can contains an - [assert_equal] to check it @param use_stderr redirect [stderr] to [stdout] @param env Unix environment @param verbose if a failure arise, dump stdout/stderr of the process to stderr @since 1.1.0 *) val assert_command : ?exit_code:Unix.process_status -> - ?sinput:char Stream.t -> - ?foutput:(char Stream.t -> unit) -> ?use_stderr:bool -> ?env:string array -> ?verbose:bool -> string -> string list -> unit (** [assert_equal expected real] Compares two values, when they are not equal a failure is signaled. @param cmp customize function to compare, default is [=] @param printer value printer, don't print value otherwise @param pp_diff if not equal, ask a custom display of the difference using [diff fmt exp real] where [fmt] is the formatter to use @param msg custom message to identify the failure @raise Failure signal a failure @version 1.1.0 *) val assert_equal : ?cmp:('a -> 'a -> bool) -> ?printer:('a -> string) -> ?pp_diff:(Format.formatter -> ('a * 'a) -> unit) -> ?msg:string -> 'a -> 'a -> unit (** Asserts if the expected exception was raised. @param msg identify the failure @raise Failure description *) val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit (** {2 Skipping tests } In certain condition test can be written but there is no point running it, because they are not significant (missing OS features for example). In this case this is not a failure nor a success. Following functions allow you to escape test, just as assertion but without the same error status. A test skipped is counted as success. A test todo is counted as failure. *) (** [skip cond msg] If [cond] is true, skip the test for the reason explain in [msg]. For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on windows"]. @since 1.0.3 *) val skip_if : bool -> string -> unit (** The associated test is still to be done, for the reason given. @since 1.0.3 *) val todo : string -> unit (** {2 Compare Functions} *) (** Compare floats up to a given relative error. @param epsilon if the difference is smaller [epsilon] values are equal *) val cmp_float : ?epsilon:float -> float -> float -> bool (** {2 Bracket} A bracket is a functional implementation of the commonly used setUp and tearDown feature in unittests. It can be used like this: ["MyTestCase" >:: (bracket test_set_up test_fun test_tear_down)] *) (** [bracket set_up test tear_down] The [set_up] function runs first, then the [test] function runs and at the end [tear_down] runs. The [tear_down] function runs even if the [test] failed and help to clean the environment. *) val bracket: (unit -> 'a) -> ('a -> unit) -> ('a -> unit) -> unit -> unit (** [bracket_tmpfile test] The [test] function takes a temporary filename and matching output channel as arguments. The temporary file is created before the test and removed after the test. @param prefix see [Filename.open_temp_file] @param suffix see [Filename.open_temp_file] @param mode see [Filename.open_temp_file] @since 1.1.0 *) val bracket_tmpfile: ?prefix:string -> ?suffix:string -> ?mode:open_flag list -> ((string * out_channel) -> unit) -> unit -> unit (** {2 Constructing Tests} *) (** The type of test function *) type test_fun = unit -> unit (** The type of tests *) type test = TestCase of test_fun | TestList of test list | TestLabel of string * test (** Create a TestLabel for a test *) val (>:) : string -> test -> test (** Create a TestLabel for a TestCase *) val (>::) : string -> test_fun -> test (** Create a TestLabel for a TestList *) val (>:::) : string -> test list -> test (** Some shorthands which allows easy test construction. Examples: - ["test1" >: TestCase((fun _ -> ()))] => [TestLabel("test2", TestCase((fun _ -> ())))] - ["test2" >:: (fun _ -> ())] => [TestLabel("test2", TestCase((fun _ -> ())))] - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => [TestLabel("test-suite", TestSuite([TestLabel("test2", TestCase((fun _ -> ())))]))] *) (** [test_decorate g tst] Apply [g] to test function contains in [tst] tree. @since 1.0.3 *) val test_decorate : (test_fun -> test_fun) -> test -> test (** [test_filter paths tst] Filter test based on their path string representation. @param skip] if set, just use [skip_if] for the matching tests. @since 1.0.3 *) val test_filter : ?skip:bool -> string list -> test -> test option (** {2 Retrieve Information from Tests} *) (** Returns the number of available test cases *) val test_case_count : test -> int (** Types which represent the path of a test *) type node = ListItem of int | Label of string type path = node list (** The path to the test (in reverse order). *) (** Make a string from a node *) val string_of_node : node -> string (** Make a string from a path. The path will be reversed before it is tranlated into a string *) val string_of_path : path -> string (** Returns a list with paths of the test *) val test_case_paths : test -> path list (** {2 Performing Tests} *) (** The possible results of a test *) type test_result = RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string (** Events which occur during a test run *) type test_event = EStart of path | EEnd of path | EResult of test_result (** Perform the test, allows you to build your own test runner *) val perform_test : (test_event -> 'a) -> test -> test_result list (** A simple text based test runner. It prints out information during the test. @param verbose print verbose message *) val run_test_tt : ?verbose:bool -> test -> test_result list (** Main version of the text based test runner. It reads the supplied command line arguments to set the verbose level and limit the number of test to run. @param arg_specs add extra command line arguments @param set_verbose call a function to set verbosity @version 1.1.0 *) val run_test_tt_main : ?arg_specs:(Arg.key * Arg.spec * Arg.doc) list -> ?set_verbose:(bool -> unit) -> test -> test_result list Index: trunk/circe2/src/events_lexer.mli =================================================================== --- trunk/circe2/src/events_lexer.mli (revision 0) +++ trunk/circe2/src/events_lexer.mli (revision 8810) @@ -0,0 +1,15 @@ +(* events_lexer.mli -- *) +(* Copyright (C) 2022 by Thorsten Ohl + Circe2 is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + Circe2 is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +val token : Lexing.lexbuf -> float option Index: trunk/circe2/src/events_lexer.mll =================================================================== --- trunk/circe2/src/events_lexer.mll (revision 0) +++ trunk/circe2/src/events_lexer.mll (revision 8810) @@ -0,0 +1,73 @@ +(* events_lexer.mll -- *) +(* Copyright (C) 2022 by Thorsten Ohl + Circe2 is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + Circe2 is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +{ + (* Fortran allows ['d'] and ['D'] as exponent starter, but + O'Caml's [float_of_string] doesn't accept it. *) + + let normalize_ascii_floats orig = + let normalized = Bytes.of_string orig in + for i = 0 to Bytes.length normalized - 1 do + let c = Bytes.get normalized i in + if c = 'd' || c = 'D' then + Bytes.set normalized i 'E' + done; + Bytes.to_string normalized +} + +let digit = [ '0' - '9' ] +let exp_e = [ 'e' 'E' ] +let exp_d = [ 'd' 'D' ] +let white = [ ' ' '\t' '\r' ] + +rule token = parse + white { token lexbuf } (* skip blanks *) + | ['+''-']? digit+ + ( '.' digit* ( exp_e digit+ )? | exp_e digit+ ) + { Some (float_of_string (Lexing.lexeme lexbuf)) } + | ['+''-']? digit+ + ( '.' digit* ( exp_d digit+ )? | exp_d digit+ ) + { Some (float_of_string (normalize_ascii_floats (Lexing.lexeme lexbuf))) } + | ['+''-']? digit+ + { Some (float_of_string (Lexing.lexeme lexbuf)) } + | _ { failwith (Lexing.lexeme lexbuf) } + | eof { None } + +{ + (* Not used by circe2, just for illustration and testing. *) + + let float_list_of_string s = + let lexbuf = Lexing.from_string s in + let rec collect xs_rev = + match token lexbuf with + | None -> List.rev xs_rev + | Some x -> collect (x :: xs_rev) in + try + collect [] + with + | Failure c -> + invalid_arg ("invalid token '" ^ c ^ "' in \"" ^ s ^ "\"") + + let float_array_of_string a s = + let lexbuf = Lexing.from_string s in + try + for i = 0 to Array.length a - 1 do + match token lexbuf with + | None -> invalid_arg ("not enough floats in \"" ^ s ^ "\"") + | Some x -> a.(i) <- x + done + with + | Failure c -> + invalid_arg ("invalid token '" ^ c ^ "' in \"" ^ s ^ "\"") +} Index: trunk/circe2/src/OUnit.ml =================================================================== --- trunk/circe2/src/OUnit.ml (revision 8809) +++ trunk/circe2/src/OUnit.ml (revision 8810) @@ -1,805 +1,779 @@ (* oUnit.ml -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) open Format (* TODO: really use Format in printf call. Most of the time, not * cuts/spaces/boxes are used *) let global_verbose = ref false let buff_printf f = let buff = Buffer.create 13 in let fmt = formatter_of_buffer buff in f fmt; pp_print_flush fmt (); Buffer.contents buff let bracket set_up f tear_down () = let fixture = set_up () in let () = try let () = f fixture in tear_down fixture with e -> let () = tear_down fixture in raise e in () let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode f = bracket (fun () -> Filename.open_temp_file ?mode prefix suffix) f (fun (fn, chn) -> begin try close_out chn with _ -> () end; begin try Sys.remove fn with _ -> () end) exception Skip of string let skip_if b msg = if b then raise (Skip msg) exception Todo of string let todo msg = raise (Todo msg) let assert_failure msg = failwith ("OUnit: " ^ msg) let assert_bool msg b = if not b then assert_failure msg let assert_string str = if not (str = "") then assert_failure str let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = let get_error_string () = (* let max_len = pp_get_margin fmt () in *) (* let ellipsis_text = "[...]" in *) let print_ellipsis p fmt s = (* TODO: find a way to do this let res = p s in let len = String.length res in if diff <> None && len > max_len then begin let len_with_ellipsis = (max_len - (String.length ellipsis_text)) / 2 in (* TODO: we should use %a here to print values *) fprintf fmt "@[%s[...]%s@]" (String.sub res 0 len_with_ellipsis) (String.sub res (len - len_with_ellipsis) len_with_ellipsis) end else begin (* TODO: we should use %a here to print values *) fprintf fmt "@[%s@]" res end *) pp_print_string fmt (p s) in let res = buff_printf (fun fmt -> pp_open_vbox fmt 0; begin match msg with | Some s -> pp_open_box fmt 0; pp_print_string fmt s; pp_close_box fmt (); pp_print_cut fmt () | None -> () end; begin match printer with | Some p -> let p_ellipsis = print_ellipsis p in fprintf fmt "@[expected: @[%a@]@ but got: @[%a@]@]@," p_ellipsis expected p_ellipsis actual | None -> fprintf fmt "@[not equal@]@," end; begin match pp_diff with | Some d -> fprintf fmt "@[differences: %a@]@," d (expected, actual) | None -> () end; pp_close_box fmt ()) in let len = String.length res in if len > 0 && res.[len - 1] = '\n' then String.sub res 0 (len - 1) else res in if not (cmp expected actual) then assert_failure (get_error_string ()) let assert_command ?(exit_code=Unix.WEXITED 0) - ?(sinput=Stream.of_list []) - ?(foutput=ignore) ?(use_stderr=true) ?env ?verbose prg args = let verbose = match verbose with | Some v -> v | None -> !global_verbose in bracket_tmpfile (fun (fn_out, chn_out) -> let cmd_print fmt = let () = match env with | Some e -> begin pp_print_string fmt "env"; Array.iter (fprintf fmt "@ %s") e; pp_print_space fmt () end | None -> () in pp_print_string fmt prg; List.iter (fprintf fmt "@ %s") args in (* Start the process *) let in_write = Unix.dup (Unix.descr_of_out_channel chn_out) in let (out_read, out_write) = Unix.pipe () in let err = if use_stderr then in_write else Unix.stderr in let args = Array.of_list (prg :: args) in let pid = Unix.set_close_on_exec out_write; if verbose then printf "@[Starting command '%t'@]\n" cmd_print; match env with | Some e -> Unix.create_process_env prg args e out_read in_write err | None -> Unix.create_process prg args out_read in_write err in let () = Unix.close out_read; Unix.close in_write in - let () = - (* Dump sinput into the process stdin *) - let buff = Bytes.make 1 ' ' in - Stream.iter - (fun c -> - let _i : int = - Bytes.set buff 0 c; - Unix.write out_write buff 0 1 - in - ()) - sinput; - Unix.close out_write - in let _, real_exit_code = let rec wait_intr () = try Unix.waitpid [] pid with Unix.Unix_error (Unix.EINTR, _, _) -> wait_intr () in wait_intr () in let exit_code_printer = function | Unix.WEXITED n -> Printf.sprintf "exit code %d" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %d" n | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %d" n in (* Dump process output to stderr *) if verbose then begin let chn = open_in fn_out in let buff = Bytes.make 4096 'X' in let len = ref (-1) in while !len <> 0 do len := input chn buff 0 (Bytes.length buff); printf "%s" (Bytes.sub_string buff 0 !len); done; printf "@?"; close_in chn end; (* Check process status *) assert_equal ~msg:(buff_printf (fun fmt -> fprintf fmt "@[Exit status of command '%t'@]" cmd_print)) ~printer:exit_code_printer exit_code - real_exit_code; - - begin - let chn = - open_in fn_out - in - try - foutput (Stream.of_channel chn) - with e -> - close_in chn; - raise e - end) + real_exit_code) () let raises f = try f (); None with e -> Some e let assert_raises ?msg exn (f: unit -> 'a) = let pexn = Printexc.to_string in let get_error_string () = let str = Format.sprintf "expected exception %s, but no exception was raised." (pexn exn) in match msg with | None -> assert_failure str | Some s -> assert_failure (Format.sprintf "%s\n%s" s str) in match raises f with | None -> assert_failure (get_error_string ()) | Some e -> assert_equal ?msg ~printer:pexn exn e (* Compare floats up to a given relative error *) let cmp_float ?(epsilon = 0.00001) a b = abs_float (a -. b) <= epsilon *. (abs_float a) || abs_float (a -. b) <= epsilon *. (abs_float b) (* Now some handy shorthands *) let (@?) = assert_bool (* The type of test function *) type test_fun = unit -> unit (* The type of tests *) type test = | TestCase of test_fun | TestList of test list | TestLabel of string * test (* Some shorthands which allows easy test construction *) let (>:) s t = TestLabel(s, t) (* infix *) let (>::) s f = TestLabel(s, TestCase(f)) (* infix *) let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) (* Utility function to manipulate test *) let rec test_decorate g = function | TestCase f -> TestCase (g f) | TestList tst_lst -> TestList (List.map (test_decorate g) tst_lst) | TestLabel (str, tst) -> TestLabel (str, test_decorate g tst) (* Return the number of available tests *) let rec test_case_count = function | TestCase _ -> 1 | TestLabel (_, t) -> test_case_count t | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l type node = | ListItem of int | Label of string type path = node list let string_of_node = function | ListItem n -> string_of_int n | Label s -> s let string_of_path path = String.concat ":" (List.rev_map string_of_node path) (* Some helper function, they are generally applicable *) (* Applies function f in turn to each element in list. Function f takes one element, and integer indicating its location in the list *) let mapi f l = let rec rmapi cnt l = match l with | [] -> [] | h :: t -> (f h cnt) :: (rmapi (cnt + 1) t) in rmapi 0 l let fold_lefti f accu l = let rec rfold_lefti cnt accup l = match l with | [] -> accup | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t in rfold_lefti 0 accu l (* Returns all possible paths in the test. The order is from test case to root *) let test_case_paths test = let rec tcps path test = match test with | TestCase _ -> [path] | TestList tests -> List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) | TestLabel (l, t) -> tcps ((Label l)::path) t in tcps [] test (* Test filtering with their path *) module SetTestPath = Set.Make(String) let test_filter ?(skip=false) only test = let set_test = List.fold_left (fun st str -> SetTestPath.add str st) SetTestPath.empty only in let rec filter_test path tst = if SetTestPath.mem (string_of_path path) set_test then begin Some tst end else begin match tst with | TestCase f -> begin if skip then Some (TestCase (fun () -> skip_if true "Test disabled"; f ())) else None end | TestList tst_lst -> begin let ntst_lst = fold_lefti (fun ntst_lst tst i -> let nntst_lst = match filter_test ((ListItem i) :: path) tst with | Some tst -> tst :: ntst_lst | None -> ntst_lst in nntst_lst) [] tst_lst in if not skip && ntst_lst = [] then None else Some (TestList (List.rev ntst_lst)) end | TestLabel (lbl, tst) -> begin let ntst_opt = filter_test ((Label lbl) :: path) tst in match ntst_opt with | Some ntst -> Some (TestLabel (lbl, ntst)) | None -> if skip then Some (TestLabel (lbl, tst)) else None end end in filter_test [] test (* The possible test results *) type test_result = | RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string let is_success = function | RSuccess _ -> true | RFailure _ | RError _ | RSkip _ | RTodo _ -> false let is_failure = function | RFailure _ -> true | RSuccess _ | RError _ | RSkip _ | RTodo _ -> false let is_error = function | RError _ -> true | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false let is_skip = function | RSkip _ -> true | RSuccess _ | RFailure _ | RError _ | RTodo _ -> false let is_todo = function | RTodo _ -> true | RSuccess _ | RFailure _ | RError _ | RSkip _ -> false let result_flavour = function | RError _ -> "Error" | RFailure _ -> "Failure" | RSuccess _ -> "Success" | RSkip _ -> "Skip" | RTodo _ -> "Todo" let result_path = function | RSuccess path | RError (path, _) | RFailure (path, _) | RSkip (path, _) | RTodo (path, _) -> path let result_msg = function | RSuccess _ -> "Success" | RError (_, msg) | RFailure (_, msg) | RSkip (_, msg) | RTodo (_, msg) -> msg (* Returns true if the result list contains successes only *) let rec was_successful = function | [] -> true | RSuccess _::t | RSkip _::t -> was_successful t | RFailure _::_ | RError _::_ | RTodo _::_ -> false (* Events which can happen during testing *) type test_event = | EStart of path | EEnd of path | EResult of test_result let maybe_backtrace () = if Printexc.backtrace_status () then "\n" ^ Printexc.get_backtrace () else "" (* Run all tests, report starts, errors, failures, and return the results *) let perform_test report test = let run_test_case f path = try f (); RSuccess path with | Failure s -> RFailure (path, s ^ maybe_backtrace ()) | Skip s -> RSkip (path, s) | Todo s -> RTodo (path, s) | s -> RError (path, Printexc.to_string s ^ maybe_backtrace ()) in let rec run_test path results = function | TestCase(f) -> begin let result = report (EStart path); run_test_case f path in report (EResult result); report (EEnd path); result::results end | TestList (tests) -> begin fold_lefti (fun results t cnt -> run_test ((ListItem cnt)::path) results t) results tests end | TestLabel (label, t) -> begin run_test ((Label label)::path) results t end in run_test [] [] test (* Function which runs the given function and returns the running time of the function, and the original result in a tuple *) let time_fun f x y = let begin_time = Unix.gettimeofday () in (Unix.gettimeofday () -. begin_time, f x y) (* A simple (currently too simple) text based test runner *) let run_test_tt ?verbose test = let verbose = match verbose with | Some v -> v | None -> !global_verbose in let printf = Format.printf in let separator1 = String.make (get_margin ()) '=' in let separator2 = String.make (get_margin ()) '-' in let string_of_result = function | RSuccess _ -> if verbose then "ok\n" else "." | RFailure (_, _) -> if verbose then "FAIL\n" else "F" | RError (_, _) -> if verbose then "ERROR\n" else "E" | RSkip (_, _) -> if verbose then "SKIP\n" else "S" | RTodo (_, _) -> if verbose then "TODO\n" else "T" in let report_event = function | EStart p -> if verbose then printf "%s ...\n" (string_of_path p) | EEnd _ -> () | EResult result -> printf "%s@?" (string_of_result result) in let print_result_list results = List.iter (fun result -> printf "%s\n%s: %s\n\n%s\n%s\n" separator1 (result_flavour result) (string_of_path (result_path result)) (result_msg result) separator2) results in (* Now start the test *) let running_time, results = time_fun perform_test report_event test in let errors = List.filter is_error results in let failures = List.filter is_failure results in let skips = List.filter is_skip results in let todos = List.filter is_todo results in if not verbose then printf "\n"; (* Print test report *) print_result_list errors; print_result_list failures; printf "Ran: %d tests in: %.2f seconds.\n" (List.length results) running_time; (* Print final verdict *) if was_successful results then ( if skips = [] then printf "OK" else printf "OK: Cases: %d Skip: %d\n" (test_case_count test) (List.length skips) ) else printf "FAILED: Cases: %d Tried: %d Errors: %d \ Failures: %d Skip:%d Todo:%d\n" (test_case_count test) (List.length results) (List.length errors) (List.length failures) (List.length skips) (List.length todos); (* Return the results possibly for further processing *) results (* Call this one from you test suites *) let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = let only_test = ref [] in let () = Arg.parse (Arg.align [ "-verbose", Arg.Set global_verbose, " Run the test in verbose mode."; "-only-test", Arg.String (fun str -> only_test := str :: !only_test), "path Run only the selected test"; "-list-test", Arg.Unit (fun () -> List.iter (fun pth -> print_endline (string_of_path pth)) (test_case_paths suite); exit 0), " List tests"; ] @ arg_specs ) (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*") in let nsuite = if !only_test = [] then suite else begin match test_filter ~skip:true !only_test suite with | Some test -> test | None -> failwith ("Filtering test "^ (String.concat ", " !only_test)^ " lead to no test") end in let result = set_verbose !global_verbose; run_test_tt ~verbose:!global_verbose nsuite in if not (was_successful result) then exit 1 else result Index: trunk/circe2/src/Makefile.am =================================================================== --- trunk/circe2/src/Makefile.am (revision 8809) +++ trunk/circe2/src/Makefile.am (revision 8810) @@ -1,298 +1,303 @@ # Makefile.am -- ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2022 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## # backwards compatibility OCAML_BIGARRAY_COMPAT=@OCAML_BIGARRAY_COMPAT@ OCAML_BIGARRAY_CMA=@OCAML_BIGARRAY_CMA@ OCAML_BIGARRAY_CMXA=@OCAML_BIGARRAY_CMXA@ ######################################################################## lib_LTLIBRARIES = SOURCE_FILES = MODULE_FILES = EXTRA_SOURCE_FILES = bigarray_library.ml bigarray_module.ml bigarray_compat.mli NOWEB_FILES = prelude.nw postlude.nw ######################################################################## # The CIRCE2 library proper ######################################################################## lib_LTLIBRARIES += libcirce2.la libcirce2_la_SOURCES = circe2.f90 MODULE_FILES += circe2.$(FCMOD) SOURCE_FILES += $(libcirce2_la_SOURCES) NOWEB_FILES += circe2.nw ######################################################################## # Required for standalone compilation, # otherwise provided by VAMP and/or WHIZARD ######################################################################## EXTRA_SOURCE_FILES += MODULE_FILES += kinds.$(FCMOD) lib_LTLIBRARIES += libtaorng.la libtaorng_la_SOURCES = tao_random_numbers.f90 MODULE_FILES += tao_random_numbers.$(FCMOD) SOURCE_FILES += $(libtaorng_la_SOURCES) lib_LTLIBRARIES += libtaorng_objs.la libtaorng_objs_la_SOURCES = tao_random_objects.f90 MODULE_FILES += tao_random_objects.$(FCMOD) SOURCE_FILES += $(libtaorng_objs_la_SOURCES) ######################################################################## # Install generated .mod files # once in 'circe2' and once in 'whizard' (main only) ######################################################################## execmodcircedir = $(fmoddir)/circe2 nodist_execmodcirce_HEADERS = $(MODULE_FILES) execmoddir = $(fmoddir)/whizard nodist_execmod_HEADERS = circe2.$(FCMOD) ######################################################################## # Testing and tools ######################################################################## bin_PROGRAMS = circe2_moments circe2_ls circe2_generate circe2_moments_SOURCES = circe2_moments.f90 circe2_moments_LDADD = kinds.lo libcirce2.la libtaorng_objs.la libtaorng.la circe2_moments.o: $(MODULE_FILES) circe2_ls_SOURCES = circe2_ls.f90 circe2_ls_LDADD = kinds.lo libcirce2.la libtaorng.la circe2_ls.o: $(MODULE_FILES) circe2_generate_SOURCES = circe2_generate.f90 circe2_generate_LDADD = kinds.lo libcirce2.la libtaorng_objs.la libtaorng.la circe2_generate.o: $(MODULE_FILES) bin_SCRIPTS = if OCAML_AVAILABLE bin_SCRIPTS += $(CIRCE2_NATIVE) endif OCAML_AVAILABLE $(CIRCE2_NATIVE): $(CIRCE2_CMX) $(CIRCE2_BYTECODE): $(CIRCE2_CMO) if OCAML_AVAILABLE all-local: $(CIRCE2_CMX) $(CIRCE2TOOL_CMX) bytecode: $(CIRCE2_CMO) $(CIRCE2TOOL_CMO) else all-local: bytecode: endif include $(top_srcdir)/circe2/src/Makefile.ocaml include $(top_srcdir)/circe2/src/Makefile.sources EXTRA_DIST = $(NOWEB_FILES) $(SOURCE_FILES) $(CIRCE2_CAML) \ $(EXTRA_SOURCE_FILES) $(circe2_moments_SOURCES) \ $(circe2_ls_SOURCES) $(circe2_generate_SOURCES) MYPRECIOUS = $(CIRCE2_DERIVED) # Fortran90 module files are generated at the same time as object files .lo.$(FCMOD): @: # touch $@ AM_FFLAGS = AM_FCFLAGS = ######################################################################## ## Default Fortran compiler options ## Profiling if FC_USE_PROFILING AM_FFLAGS += $(FCFLAGS_PROFILING) AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FFLAGS += $(FCFLAGS_OPENMP) AM_FCFLAGS += $(FCFLAGS_OPENMP) endif ######################################################################## # noweb ######################################################################## TRIPLE = $(srcdir)/prelude.nw $< $(srcdir)/postlude.nw WEBS = $(srcdir)/prelude.nw $(srcdir)/circe2.nw $(srcdir)/postlude.nw NOTANGLE_IT = \ cat $(TRIPLE) | $(NOTANGLE) -R'[[$@]]' > $@ SUFFIXES += .nw .$(FCMOD) if NOWEB_AVAILABLE .nw.f90: $(NOTANGLE_IT) circe2_ls.f90: circe2.nw cat $(WEBS) | $(NOTANGLE) -R'[[$@]]' > $@ circe2_generate.f90: circe2.nw cat $(WEBS) | $(NOTANGLE) -R'[[$@]]' > $@ circe2_moments.f90: circe2.nw cat $(WEBS) | $(NOTANGLE) -R'[[$@]]' > $@ tao_random_objects.f90: circe2.nw cat $(WEBS) | $(NOTANGLE) -R'[[$@]]' > $@ endif NOWEB_AVAILABLE ######################################################################## # O'Caml ######################################################################## if OCAML_AVAILABLE bigarray_compat.ml: $(OCAML_BIGARRAY_COMPAT).ml cp -f $< $@ events.cmx: bigarray_compat.cmi bigarray_compat.cmx events.cmo: bigarray_compat.cmi bigarray_compat.cmo circe2.top: $(CIRCE2_CMO) $(OCAMLMKTOP) $(OCAMLFLAGS) -o $@ \ unix.cma $(OCAML_BIGARRAY_CMA) $(CIRCE2_CMO) lexer.mli: lexer.ml parser.cmi $(OCAMLC) -i $< | $(GREP) 'val token' >$@ +events_lexer.mli: events_lexer.ml + $(OCAMLC) -i $< | $(GREP) 'val token' >$@ + endif OCAML_AVAILABLE ######################################################################## # The following line just says # include Makefile.depend # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE ######################################################################## @am__include@ @am__quote@Makefile.depend@am__quote@ Makefile.depend: $(SOURCE_FILES) $(circe2_moments_SOURCES) $(circe2_ls_SOURCES) $(circe2_generate_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f90//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -e 's/, *only:.*//' \ -e 's/, *&//' \ -e 's/, *.*=>.*//' \ -e 's/ *$$/.lo/'; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -e 's/, *only:.*//' \ -e 's/, *&//' \ -e 's/, *.*=>.*//' \ -e 's/ *$$/.$$(FCMOD)/'; \ done > $@ DISTCLEANFILES = Makefile.depend kinds.f90 if OCAML_AVAILABLE @am__include@ @am__quote@Makefile.depend_ocaml@am__quote@ # echo lexer.mli: lexer.ml >>$@ Makefile.depend_ocaml: $(CIRCE2_SRC) $(CIRCE2TOOL_SRC) @if $(AM_V_P); then :; else echo " OCAMLDEP " $@; fi @rm -f $@ $(AM_V_at)$(OCAMLDEP) -I $(srcdir) $^ | sed 's,[^ ]*/,,g' >$@ echo parser.mli: parser.ml >>$@ echo lexer.cmi: parser.cmi >>$@ echo parser.cmi: syntax.cmi >>$@ echo commands.cmi: parser.cmi lexer.cmi >>$@ echo commands.cmo: parser.cmi lexer.cmi >>$@ echo commands.cmx: parser.cmx lexer.cmx >>$@ echo lexer.cmo: lexer.cmi >>$@ echo lexer.cmx: lexer.cmi parser.cmx >>$@ echo parser.cmo: parser.cmi syntax.cmi >>$@ echo parser.cmx: parser.cmi syntax.cmi syntax.cmx >>$@ + echo events_lexer.cmo: events_lexer.cmi >>$@ + echo events_lexer.cmx: events_lexer.cmi >>$@ DISTCLEANFILES += Makefile.depend_ocaml DISTCLEANFILES += $(CIRCE2_DERIVED) DISTCLEANFILES += bigarray_compat.ml endif OCAML_AVAILABLE ######################################################################## ## Non-standard cleanup tasks ## Remove sources that can be recreated using NOWEB .PRECIOUS = $(MYPRECIOUS) if NOWEB_AVAILABLE maintainer-clean-noweb: -rm -f $(SOURCE_FILES) $(circe2_moments_SOURCES) $(circe2_ls_SOURCES) $(circe2_generate_SOURCES) endif .PHONY: maintainer-clean-noweb ## Remove those sources also if builddir and srcdir are different if NOWEB_AVAILABLE clean-noweb: test "$(srcdir)" != "." && rm -f $(SOURCE_FILES) $(circe2_moments_SOURCES) $(circe2_ls_SOURCES) $(circe2_generate_SOURCES) || true endif .PHONY: clean-noweb ## Remove F90 module files clean-local: clean-noweb -rm -f *.cm[aiox] *.cmxa *.[ao] *.l[oa] *.$(FCMOD) \ *.g90 $(CIRCE2_NATIVE) $(CIRCE2_BYTECODE) $(CIRCE2_DERIVED) if FC_SUBMODULES -rm -f *.smod endif ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup ### module="`basename $$src | sed 's/\.f[90][0358]//'`"; ######################################################################## # MPI ######################################################################## ### ### # The -mismatch_all is for mpi_send() etc. ### MPIFC = mpif90 ### MPIFCFLAGS = # -mismatch_all Index: trunk/circe2/src/circe2_tool.ml =================================================================== --- trunk/circe2/src/circe2_tool.ml (revision 8809) +++ trunk/circe2/src/circe2_tool.ml (revision 8810) @@ -1,496 +1,496 @@ (* circe2/circe2_tool.ml -- *) (* Copyright (C) 2001-2022 by Thorsten Ohl Circe2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Circe2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \subsubsection{Large Numeric File I/O} *) type input_file = | ASCII_ic of in_channel | ASCII_inf of string | Binary_inf of string type output_file = | ASCII_oc of out_channel | ASCII_outf of string | Binary_outf of string let read columns = function | ASCII_ic ic -> Events.of_ascii_channel columns ic | ASCII_inf inf -> Events.of_ascii_file columns inf | Binary_inf inf -> Events.of_binary_file columns inf let write output array = match output with | ASCII_oc oc -> Events.to_ascii_channel oc array | ASCII_outf outf -> Events.to_ascii_file outf array | Binary_outf outf -> Events.to_binary_file outf array (* The special case of writing a binary file with mapped I/O can be treated most efficiently: *) let cat columns input output = match input, output with | ASCII_ic ic, Binary_outf outf -> ignore (Events.of_ascii_channel ~file:outf columns ic) | _, _ -> write output (read columns input) let map_xy fx fy columns input output = let a = read columns input in for i2 = 1 to Bigarray.Array2.dim2 a do Bigarray.Array2.set a 1 i2 (fx (Bigarray.Array2.get a 1 i2)); Bigarray.Array2.set a 2 i2 (fy (Bigarray.Array2.get a 2 i2)) done; write output a let log10_xy = map_xy log10 log10 let exp10_xy = map_xy (fun x -> 10.0 ** x) (fun y -> 10.0 ** y) (* \subsubsection{Histogramming} *) let scan_string s = - let tokens = Events.lexer (Stream.of_string s) in + let tokens = Lexing.from_string s in let t1 = Events.next_float tokens in let t2 = Events.next_float tokens in let t3 = Events.next_float tokens in (t1, t2, t3) let histogram_ascii name histograms = let ic = open_in name and histos = List.map (fun (tag, f, n, x_min, x_max) -> (tag, f, Histogram.create n x_min x_max)) histograms in begin try while true do let x, y, w = scan_string (input_line ic) in List.iter (fun (_, f, h) -> Histogram.record h (f x y) w) histos done with | End_of_file -> () end; close_in ic; List.map (fun (t, _, h) -> (t, h)) histos let histogram_binary_channel ic histograms = let histos = List.map (fun (tag, f, n, x_min, x_max) -> (tag, f, Histogram.create n x_min x_max)) histograms in begin try while true do let x = Float.Double.input_binary_float ic and y = Float.Double.input_binary_float ic and w = Float.Double.input_binary_float ic in List.iter (fun (_, f, h) -> Histogram.record h (f x y) w) histos done with | End_of_file -> () end; List.map (fun (t, _, h) -> (t, h)) histos let histogram_binary name histograms = let a = Events.of_binary_file 3 name and histos = List.map (fun (tag, f, n, x_min, x_max) -> (tag, f, Histogram.create n x_min x_max)) histograms in for i2 = 1 to Bigarray.Array2.dim2 a do let x = Bigarray.Array2.get a 1 i2 and y = Bigarray.Array2.get a 2 i2 and w = Bigarray.Array2.get a 3 i2 in List.iter (fun (_, f, h) -> Histogram.record h (f x y) w) histos done; List.map (fun (t, _, h) -> (t, h)) histos (*i let histogram_binary name histograms = let a = Events.of_binary_file 3 name and histos = List.map (fun (tag, f, n, x_min, x_max) -> (tag, f, Histogram.create n x_min x_max)) histograms in for i2 = 1 to Bigarray.Array2.dim2 a do let x = a.{1,i2} and y = a.{2,i2} and w = a.{3,i2} in List.iter (fun (_, f, h) -> Histogram.record h (f x y) w) histos done; List.map (fun (t, _, h) -> (t, h)) histos i*) let histogram_data to_file n reader suffix = let histograms = reader [ ("x", (fun x y -> x), n, 0.0, 1.0); ("x_low", (fun x y -> x), n, 0.0, 1.0e-4); ("1-x_low", (fun x y -> 1.0 -. x), n, 0.0, 1.0e-2); ("1-x_low2", (fun x y -> 1.0 -. x), n, 1.0e-10, 1.0e-2); ("y", (fun x y -> y), n, 0.0, 1.0); ("y_low", (fun x y -> y), n, 0.0, 1.0e-4); ("1-y_low", (fun x y -> 1.0 -. y), n, 0.0, 1.0e-2); ("1-y_low2", (fun x y -> 1.0 -. y), n, 1.0e-10, 1.0e-2); ("xy", (fun x y -> x *. y), n, 0.0, 1.0); ("xy_low", (fun x y -> x *. y), n, 0.0, 1.0e-8); ("z", (fun x y -> sqrt (x *. y)), n, 0.0, 1.0); ("z_low", (fun x y -> sqrt (x *. y)), n, 0.0, 1.0e-4); ("x-y", (fun x y -> x -. y), n, -1.0, 1.0); ("x_fine", (fun x y -> x), n, 0.75, 0.85); ("y_fine", (fun x y -> y), n, 0.75, 0.85); ("xy_fine", (fun x y -> x *. y), n, 0.5, 0.7); ("x-y_fine", (fun x y -> x -. y), n, -0.1, 0.1) ] in List.iter (fun (tag, h) -> to_file (tag ^ suffix) (Histogram.normalize h)) histograms (* \subsubsection{Moments} *) let moments_ascii name moments = let ic = open_in name and f = Array.of_list (List.map (fun (tag, f) -> f) moments) and m = Array.of_list (List.map (fun (tag, f) -> 0.0) moments) and sum_w = ref 0.0 in begin try while true do let x, y, w = scan_string (input_line ic) in sum_w := !sum_w +. w; for i = 0 to Array.length f - 1 do m.(i) <- m.(i) +. w *. (f.(i) x y) done done with | End_of_file -> () end; close_in ic; List.map2 (fun (tag, f) m -> (tag, m /. !sum_w)) moments (Array.to_list m) let moments_binary name moments = let a = Events.of_binary_file 3 name in let f = Array.of_list (List.map (fun (tag, f) -> f) moments) and m = Array.of_list (List.map (fun (tag, f) -> 0.0) moments) and sum_w = ref 0.0 in for i2 = 1 to Bigarray.Array2.dim2 a do let x = Bigarray.Array2.get a 1 i2 and y = Bigarray.Array2.get a 2 i2 and w = Bigarray.Array2.get a 3 i2 in sum_w := !sum_w +. w; for i = 0 to Array.length f - 1 do m.(i) <- m.(i) +. w *. (f.(i) x y) done done; List.map2 (fun (tag, f) m -> (tag, m /. !sum_w)) moments (Array.to_list m) let fmt var = function | 0 -> "" | 1 -> var | n -> var ^ "^" ^ string_of_int n let moment nx ny = (fmt "x" nx ^ fmt "y" ny, (fun x y -> x ** (float nx) *. y ** (float ny))) let diff_moment n = (fmt "|x-y|" n, (fun x y -> (abs_float (x -. y)) ** (float n))) let moments_data reader = let moments = reader (List.map (moment 0) [1; 2; 3; 4; 5; 6] @ List.map (moment 1) [0; 1; 2; 3; 4; 5] @ List.map (moment 2) [0; 1; 2; 3; 4] @ List.map (moment 3) [0; 1; 2; 3] @ List.map (moment 4) [0; 1; 2] @ List.map (moment 5) [0; 1] @ List.map (moment 6) [0] @ List.map diff_moment [1; 2; 3; 4; 5; 6]) in List.iter (fun (tag, m) -> Printf.printf "%s = %g\n" tag m) moments (* \subsubsection{Regression} *) let regression_interval (tag, h) (log_min, log_max) = let a, b = Histogram.regression h (fun x -> x >= log_min && x <= log_max) (fun x -> x) (fun x -> log x) in Printf.printf "%g<%s<%g: a = %g, b = %g\n" log_min tag log_max a b let intervals = [ (-7.0, -6.0); (-6.0, -5.0); (-5.0, -4.0); (-4.0, -3.0); (-3.0, -2.0); (-7.0, -5.0); (-6.0, -4.0); (-5.0, -3.0); (-4.0, -2.0); (-7.0, -4.0); (-6.0, -3.0); (-5.0, -2.0); (-7.0, -3.0); (-6.0, -2.0) ] let intervals = [ (-7.0, -4.0); (-6.0, -3.0); (-7.0, -3.0); (-6.0, -2.0) ] let regression_data n reader = let histograms = reader [ ("log(x1)", (fun x1 x2 -> log x1), n, -8.0, 0.0); ("log(x2)", (fun x1 x2 -> log x2), n, -8.0, 0.0) ] in List.iter (fun (tag, h) -> List.iter (regression_interval (tag, h)) intervals) histograms (* \subsubsection{Visually Adapting Powermaps} *) let power_map beta eta = - Diffmap.Power.create (1.0 /. (1.0 +. beta)) eta 0.0 1.0 + Diffmap.Power.create ~alpha:(1.0 /. (1.0 +. beta)) ~eta 0.0 1.0 let power_data to_file n center resolution reader suffix = let histograms = reader (List.flatten (List.map (fun p -> let pm = power_map p 0.0 in let ihp = Diffmap.Power.ihp pm in [((Printf.sprintf "1-x_low.%.2f" p), (fun x1 x2 -> ihp (1.0-.x1)), n, 0.0, ihp 1.0e-4); ((Printf.sprintf "1-y_low.%.2f" p), (fun x1 x2 -> ihp (1.0-.x2)), n, 0.0, ihp 1.0e-4); ((Printf.sprintf "x_low.%.2f" p), (fun x1 x2 -> ihp x1), n, 0.0, ihp 1.0e-4); ((Printf.sprintf "y_low.%.2f" p), (fun x1 x2 -> ihp x2), n, 0.0, ihp 1.0e-4)]) [center -. 2.0 *. resolution; center -. resolution; center; center +. resolution; center +. 2.0 *. resolution])) in List.iter (fun (tag, h) -> to_file (tag ^ suffix) (Histogram.normalize h)) histograms (* \subsubsection{Testing} *) let make_test_data n (x_min, x_max) (y_min, y_max) f = let delta_x = x_max -. x_min and delta_y = y_max -. y_min in let array = Bigarray.Array2.create Bigarray.float64 Bigarray.fortran_layout 3 n in for i = 1 to n do let x = x_min +. Random.float delta_x and y = y_min +. Random.float delta_y in Bigarray.Array2.set array 1 i x; Bigarray.Array2.set array 2 i y; Bigarray.Array2.set array 3 i (f x y) done; array (*i let make_test_data n (x_min, x_max) (y_min, y_max) f = let delta_x = x_max -. x_min and delta_y = y_max -. y_min in let array = Bigarray.Array2.create Bigarray.float64 Bigarray.fortran_layout 3 n in for i = 1 to n do let x = x_min +. Random.float delta_x and y = y_min +. Random.float delta_y in array.{1,i} <- x; array.{2,i} <- y; array.{3,i} <- f x y done; array i*) module Div = Division.Mono module Grid = Grid.Make (Div) let test_design grid = let channel = { Grid.pid1 = 22; Grid.pol1 = 0; Grid.pid2 = 22; Grid.pol2 = 0; Grid.lumi = 0.0; Grid.g = grid } in { Grid.name = "TEST"; Grid.roots = 500.0; Grid.channels = [ channel ]; Grid.comments = [ "unphysical test" ]} let test verbose triangle shrink nbins name f = let data = make_test_data 100000 (0.4, 0.9) (0.2, 0.7) f in let initial_grid = Grid.create ~triangle (Div.create nbins 0.0 1.0) (Div.create nbins 0.0 1.0) in let grid = Grid.of_bigarray ~verbose ~fixed_x1_min:(not shrink) ~fixed_x1_max:(not shrink) ~fixed_x2_min:(not shrink) ~fixed_x2_max:(not shrink) data initial_grid in Grid.designs_to_file name [test_design grid] let random_interval () = let x1 = Random.float 1.0 and x2 = Random.float 1.0 in (min x1 x2, max x1 x2) module Test_Power = Diffmap.Make_Test (Diffmap.Power) module Test_Resonance = Diffmap.Make_Test (Diffmap.Resonance) let test_maps seed = Random.init seed; let x_min, x_max = random_interval () and y_min, y_max = random_interval () in let alpha = 1.0 +. Random.float 4.0 and eta = if Random.float 1.0 > 0.5 then y_max +. Random.float 5.0 else y_min -. Random.float 5.0 in Test_Power.all (Diffmap.Power.create ~alpha ~eta ~x_min ~x_max y_min y_max); let a = Random.float 1.0 and eta = y_min +. Random.float (y_max -. y_min) in Test_Resonance.all (Diffmap.Resonance.create ~eta ~a ~x_min ~x_max y_min y_max) (* \subsubsection{Main Program} *) type format = ASCII | Binary type action = | Nothing | Command_file of string | Commands of string | Cat | Histo of format * string | Moments of format * string | Regression of format * string | Test of string * (float -> float -> float) | Test_Diffmaps of int | Unit_Tests | Log10 | Exp10 | Power of format * string let rec passed = function | [] -> true | (OUnit.RFailure _ | OUnit.RError _ | OUnit.RTodo _ ) :: _ -> false | (OUnit.RSuccess _ | OUnit.RSkip _) :: tail -> passed tail let _ = let usage = "usage: " ^ Sys.argv.(0) ^ " [options]" in let nbins = ref 100 and triangle = ref false and shrink = ref false and verbose = ref false and action = ref Nothing and suffix = ref ".histo" and input = ref (ASCII_ic stdin) and output = ref (ASCII_oc stdout) and columns = ref 3 and histogram_to_file = ref Histogram.to_file and center = ref 0.0 and resolution = ref 0.01 in Arg.parse [("-c", Arg.String (fun s -> action := Commands s), "commands"); ("-f", Arg.String (fun f -> action := Command_file f), "command file"); ("-ia", Arg.String (fun n -> input := ASCII_inf n), "ASCII input file"); ("-ib", Arg.String (fun n -> input := Binary_inf n), "Binary input file"); ("-oa", Arg.String (fun n -> output := ASCII_outf n), "ASCII output file"); ("-ob", Arg.String (fun n -> output := Binary_outf n), "Binary output file"); ("-cat", Arg.Unit (fun () -> input := ASCII_ic stdin; output := ASCII_oc stdout; action := Cat), "copy stdin to stdout"); ("-log10", Arg.Unit (fun () -> input := ASCII_ic stdin; output := ASCII_oc stdout; action := Log10), ""); ("-exp10", Arg.Unit (fun () -> input := ASCII_ic stdin; output := ASCII_oc stdout; action := Exp10), ""); ("-ha", Arg.String (fun s -> action := Histo (ASCII, s)), "ASCII histogramming tests"); ("-hb", Arg.String (fun s -> action := Histo (Binary, s)), "binary histogramming tests"); ("-ma", Arg.String (fun s -> action := Moments (ASCII, s)), "ASCII moments tests"); ("-mb", Arg.String (fun s -> action := Moments (Binary, s)), "binary moments tests"); ("-pa", Arg.String (fun s -> action := Power (ASCII, s)), ""); ("-pb", Arg.String (fun s -> action := Power (Binary, s)), ""); ("-C", Arg.Float (fun c -> center := c), ""); ("-R", Arg.Float (fun r -> resolution := r), ""); ("-Pa", Arg.String (fun s -> action := Regression (ASCII, s)), ""); ("-Pb", Arg.String (fun s -> action := Regression (Binary, s)), ""); ("-p", Arg.String (fun s -> suffix := s), "histogram name suffix"); ("-h", Arg.Unit (fun () -> histogram_to_file := Histogram.as_bins_to_file), ""); ("-b", Arg.Int (fun n -> nbins := n), "#bins"); ("-s", Arg.Set shrink, "shrinkwrap interval"); ("-S", Arg.Clear shrink, "don't shrinkwrap interval [default]"); ("-t", Arg.Set triangle, "project symmetrical distribution onto triangle"); ("-v", Arg.Set verbose, "verbose"); ("-test", Arg.Unit (fun () -> action := Unit_Tests), "run unit test suite"); ("-test1", Arg.String (fun s -> action := Test (s, fun x y -> 1.0)), "testing"); ("-test2", Arg.String (fun s -> action := Test (s, fun x y -> x *. y)), "testing"); ("-test3", Arg.String (fun s -> action := Test (s, fun x y -> 1.0 /. x +. 1.0 /. y)), "testing"); ("-testm", Arg.Int (fun seed -> action := Test_Diffmaps seed), "testing maps") ] (fun names -> prerr_endline usage; exit 2) usage; begin try match !action with | Nothing -> () | Commands name -> Commands.execute (Commands.parse_string name) | Command_file name -> Commands.execute (Commands.parse_file name) | Histo (ASCII, name) -> histogram_data !histogram_to_file !nbins (histogram_ascii name) !suffix | Histo (Binary, "-") -> histogram_data !histogram_to_file !nbins (histogram_binary_channel stdin) !suffix | Histo (Binary, name) -> histogram_data !histogram_to_file !nbins (histogram_binary name) !suffix | Moments (ASCII, name) -> moments_data (moments_ascii name) | Moments (Binary, name) -> moments_data (moments_binary name) | Power (ASCII, name) -> power_data !histogram_to_file !nbins !center !resolution (histogram_ascii name) !suffix | Power (Binary, name) -> power_data !histogram_to_file !nbins !center !resolution (histogram_binary name) !suffix | Regression (ASCII, name) -> regression_data !nbins (histogram_ascii name) | Regression (Binary, name) -> regression_data !nbins (histogram_binary name) | Cat -> cat !columns !input !output | Log10 -> log10_xy !columns !input !output | Exp10 -> exp10_xy !columns !input !output | Test (name, f) -> test !verbose !triangle !shrink !nbins name f | Test_Diffmaps seed -> test_maps seed | Unit_Tests -> let suite = OUnit.(>:::) "All" [ThoArray.suite; ThoMatrix.suite; Filter.suite] in if passed (OUnit.run_test_tt ~verbose:!verbose suite) then exit 0 else exit 1 with | Syntax.Syntax_Error (msg, _, _) -> Printf.eprintf "%s: parse error: %s\n" Sys.argv.(0) msg; exit 1 end; exit 0 (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*)