mirror of
https://gitlab.com/scemama/QCaml.git
synced 2024-12-22 20:33:36 +01:00
Command-line org
This commit is contained in:
parent
b08079c09d
commit
5244b2dba8
@ -1,4 +1,11 @@
|
||||
#+begin_src elisp tangle: no :results none
|
||||
(setq pwd (file-name-directory buffer-file-name))
|
||||
(setq name (file-name-nondirectory (substring buffer-file-name 0 -4)))
|
||||
(setq lib (concat pwd "lib/"))
|
||||
(setq testdir (concat pwd "test/"))
|
||||
(setq mli (concat lib name ".mli"))
|
||||
(setq ml (concat lib name ".ml"))
|
||||
(setq test-ml (concat testdir name ".ml"))
|
||||
(org-babel-tangle)
|
||||
#+end_src
|
||||
|
||||
@ -15,7 +22,7 @@
|
||||
** Type
|
||||
|
||||
#+NAME: types
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
type t =
|
||||
| S | P | D | F | G | H | I | J | K | L | M | N | O
|
||||
| Int of int
|
||||
@ -36,7 +43,7 @@ type kind =
|
||||
The ~kind~ is used to build shells, shell doublets, triplets or
|
||||
quartets, use in the two-electron operators.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
<<types>>
|
||||
open Powers
|
||||
#+end_src
|
||||
@ -54,11 +61,11 @@ open Powers
|
||||
Angular_momentum.of_char 'p' -> Angular_momentum.P
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_char : char -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let of_char = function
|
||||
| 's' | 'S' -> S | 'p' | 'P' -> P
|
||||
| 'd' | 'D' -> D | 'f' | 'F' -> F
|
||||
@ -78,11 +85,11 @@ let of_char = function
|
||||
Angular_momentum.(to_string D) -> "D"
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val to_string : t -> string
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let to_string = function
|
||||
| S -> "S" | P -> "P"
|
||||
| D -> "D" | F -> "F"
|
||||
@ -101,11 +108,11 @@ let to_string = function
|
||||
Angular_momentum.(to_char D) -> 'D'
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val to_char : t -> char
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let to_char = function
|
||||
| S -> 'S' | P -> 'P'
|
||||
| D -> 'D' | F -> 'F'
|
||||
@ -124,11 +131,11 @@ let to_char = function
|
||||
Angular_momentum.(to_char D) -> 2
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val to_int : t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let to_int = function
|
||||
| S -> 0 | P -> 1
|
||||
| D -> 2 | F -> 3
|
||||
@ -147,11 +154,11 @@ let to_int = function
|
||||
Angular_momentum.of_int 3 -> Angular_momentum.F
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_int : int -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let of_int = function
|
||||
| 0 -> S | 1 -> P
|
||||
| 2 -> D | 3 -> F
|
||||
@ -174,11 +181,11 @@ let of_int = function
|
||||
Angular_momentum.n_functions D -> 6
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val n_functions : t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let n_functions a =
|
||||
let a =
|
||||
to_int a
|
||||
@ -210,11 +217,11 @@ let n_functions a =
|
||||
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val zkey_array : kind -> Zkey.t array
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let zkey_array_memo : (kind, Zkey.t array) Hashtbl.t =
|
||||
Hashtbl.create 13
|
||||
|
||||
@ -295,12 +302,12 @@ let zkey_array a =
|
||||
|
||||
** Arithmetic
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val ( + ) : t -> t -> t
|
||||
val ( - ) : t -> t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let ( + ) a b =
|
||||
of_int ( (to_int a) + (to_int b) )
|
||||
|
||||
@ -313,12 +320,12 @@ let ( - ) a b =
|
||||
|
||||
Printers can print as a string (~pp_string~) or as an integer (~pp_int~).
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val pp_string : Format.formatter -> t -> unit
|
||||
val pp_int : Format.formatter -> t -> unit
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let pp_string ppf x =
|
||||
Format.fprintf ppf "@[%s@]" (to_string x)
|
||||
|
||||
|
||||
@ -1,4 +1,11 @@
|
||||
#+begin_src elisp tangle: no :results none
|
||||
(setq pwd (file-name-directory buffer-file-name))
|
||||
(setq name (file-name-nondirectory (substring buffer-file-name 0 -4)))
|
||||
(setq lib (concat pwd "lib/"))
|
||||
(setq testdir (concat pwd "test/"))
|
||||
(setq mli (concat lib name ".mli"))
|
||||
(setq ml (concat lib name ".ml"))
|
||||
(setq test-ml (concat testdir name ".ml"))
|
||||
(org-babel-tangle)
|
||||
#+end_src
|
||||
|
||||
@ -19,7 +26,7 @@
|
||||
|
||||
** Single-integer implementation
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
module One = struct
|
||||
|
||||
let of_int x =
|
||||
@ -60,7 +67,7 @@ end
|
||||
|
||||
** Zarith implementation
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
module Many = struct
|
||||
|
||||
let of_z x = x
|
||||
@ -92,11 +99,11 @@ end
|
||||
|
||||
** Type
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
type t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
type t =
|
||||
| One of int
|
||||
| Many of Z.t
|
||||
@ -104,7 +111,7 @@ type t =
|
||||
|
||||
** Tests header
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
open Common.Bitstring
|
||||
let check msg x = Alcotest.(check bool) msg true x
|
||||
let test_all () =
|
||||
@ -119,16 +126,16 @@ let test_all () =
|
||||
|
||||
Creates a bit string from an ~int~.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_int : int -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let of_int x =
|
||||
One (One.of_int x)
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "of_x" true (one_x = (of_int x));
|
||||
#+end_src
|
||||
|
||||
@ -136,16 +143,16 @@ let of_int x =
|
||||
|
||||
Creates a bit string from an ~Z.t~ multi-precision integer.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_z : Z.t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let of_z x =
|
||||
if Z.numbits x < 64 then One (Z.to_int x) else Many (Many.of_z x)
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "of_z" true (one_x = (of_z (Z.of_int x)));
|
||||
#+end_src
|
||||
|
||||
@ -153,11 +160,11 @@ let of_z x =
|
||||
|
||||
~zero n~ creates a zero bit string with ~n~ bits.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val zero : int -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let zero = function
|
||||
| n when n < 64 -> One (One.zero)
|
||||
| _ -> Many (Many.zero)
|
||||
@ -167,11 +174,11 @@ let zero = function
|
||||
|
||||
Returns the number of bits used to represent the bit string.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val numbits : t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let numbits = function
|
||||
| One x -> One.numbits x
|
||||
| Many x -> Many.numbits x
|
||||
@ -181,11 +188,11 @@ let numbits = function
|
||||
|
||||
True if all the bits of the bit string are zero.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val is_zero : t -> bool
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let is_zero = function
|
||||
| One x -> One.is_zero x
|
||||
| Many x -> Many.is_zero x
|
||||
@ -199,11 +206,11 @@ let is_zero = function
|
||||
neg (of_int x) = neg (of_int (-x))
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val neg : t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let neg = function
|
||||
| One x -> One (One.neg x)
|
||||
| Many x -> Many (Many.neg x)
|
||||
@ -214,17 +221,17 @@ let neg = function
|
||||
~shift_left t n~ returns a new bit strings with all the bits
|
||||
shifted ~n~ positions to the left.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val shift_left : t -> int -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let shift_left x i = match x with
|
||||
| One x -> One (One.shift_left x i)
|
||||
| Many x -> Many (Many.shift_left x i)
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "shift_left1" true (of_int (x lsl 3) = shift_left one_x 3);
|
||||
Alcotest.(check bool) "shift_left2" true (of_z (Z.shift_left z 3) = shift_left many_x 3);
|
||||
Alcotest.(check bool) "shift_left3" true (of_z (Z.shift_left z 100) = shift_left many_x 100);
|
||||
@ -235,17 +242,17 @@ let shift_left x i = match x with
|
||||
~shift_right t n~ returns a new bit strings with all the bits
|
||||
shifted ~n~ positions to the right.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val shift_right : t -> int -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let shift_right x i = match x with
|
||||
| One x -> One (One.shift_right x i)
|
||||
| Many x -> Many (Many.shift_right x i)
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "shift_right1" true (of_int (x lsr 3) = shift_right one_x 3);
|
||||
Alcotest.(check bool) "shift_right2" true (of_z (Z.shift_right z 3) = shift_right many_x 3);
|
||||
#+end_src
|
||||
@ -257,18 +264,18 @@ let shift_right x i = match x with
|
||||
It is equivalent as shifting ~1~ by ~n~ bits to the left.
|
||||
~size~ is the total number of bits of the bit string.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val shift_left_one : int -> int -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let shift_left_one = function
|
||||
| n when n < 64 -> fun i -> One (One.shift_left_one i)
|
||||
| _ -> fun i -> Many (Many.shift_left_one i)
|
||||
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "shift_left_one1" true (of_int (1 lsl 3) = shift_left_one 4 3);
|
||||
Alcotest.(check bool) "shift_left_one2" true (of_z (Z.shift_left Z.one 200) = shift_left_one 300 200);
|
||||
#+end_src
|
||||
@ -278,17 +285,17 @@ let shift_left_one = function
|
||||
~testbit t n~ is true if the ~n~-th bit of the bit string ~t~ is
|
||||
set to ~1~.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val testbit : t -> int -> bool
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let testbit = function
|
||||
| One x -> One.testbit x
|
||||
| Many x -> Many.testbit x
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "testbit1" true (testbit (of_int 8) 3);
|
||||
Alcotest.(check bool) "testbit2" false (testbit (of_int 8) 2);
|
||||
Alcotest.(check bool) "testbit3" false (testbit (of_int 8) 4);
|
||||
@ -301,11 +308,11 @@ let testbit = function
|
||||
|
||||
Bitwise logical or.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val logor : t -> t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let logor a b =
|
||||
match a,b with
|
||||
| One a, One b -> One (One.logor a b)
|
||||
@ -313,7 +320,7 @@ let logor a b =
|
||||
| _ -> invalid_arg "Bitstring.logor"
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "logor1" true (of_int (1 lor 2) = logor (of_int 1) (of_int 2));
|
||||
Alcotest.(check bool) "logor2" true (of_z (Z.of_int (1 lor 2)) = logor (of_z Z.one) (of_z (Z.of_int 2)));
|
||||
#+end_src
|
||||
@ -322,11 +329,11 @@ let logor a b =
|
||||
|
||||
Bitwise logical exclusive or.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val logxor : t -> t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let logxor a b =
|
||||
match a,b with
|
||||
| One a, One b -> One (One.logxor a b)
|
||||
@ -335,7 +342,7 @@ let logxor a b =
|
||||
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "logxor1" true (of_int (1 lxor 2) = logxor (of_int 1) (of_int 2));
|
||||
Alcotest.(check bool) "logxor2" true (of_z (Z.of_int (1 lxor 2)) = logxor (of_z Z.one) (of_z (Z.of_int 2)));
|
||||
#+end_src
|
||||
@ -344,11 +351,11 @@ let logxor a b =
|
||||
|
||||
Bitwise logical and.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val logand : t -> t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let logand a b =
|
||||
match a,b with
|
||||
| One a, One b -> One (One.logand a b)
|
||||
@ -357,7 +364,7 @@ let logand a b =
|
||||
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "logand1" true (of_int (1 land 3) = logand (of_int 1) (of_int 3));
|
||||
Alcotest.(check bool) "logand2" true (of_z (Z.of_int (1 land 3)) = logand (of_z Z.one) (of_z (Z.of_int 3)));
|
||||
#+end_src
|
||||
@ -366,11 +373,11 @@ let logand a b =
|
||||
|
||||
Bitwise logical negation.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val lognot : t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let lognot = function
|
||||
| One x -> One (One.lognot x)
|
||||
| Many x -> Many (Many.lognot x)
|
||||
@ -384,11 +391,11 @@ let lognot = function
|
||||
minus_one (of_int 10) = of_int 9
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val minus_one : t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let minus_one = function
|
||||
| One x -> One (One.minus_one x)
|
||||
| Many x -> Many (Many.minus_one x)
|
||||
@ -402,11 +409,11 @@ let minus_one = function
|
||||
plus_one (of_int 10) = of_int 11
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val plus_one : t -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let plus_one = function
|
||||
| One x -> One (One.plus_one x)
|
||||
| Many x -> Many (Many.plus_one x)
|
||||
@ -416,11 +423,11 @@ let plus_one = function
|
||||
|
||||
Returns the number of trailing zeros in the bit string.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val trailing_zeros : t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let trailing_zeros = function
|
||||
| One x -> One.trailing_zeros x
|
||||
| Many x -> Many.trailing_zeros x
|
||||
@ -431,11 +438,11 @@ let trailing_zeros = function
|
||||
Returns the Hamming distance, i.e. the number of bits differing
|
||||
between two bit strings.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val hamdist : t -> t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let hamdist a b = match a, b with
|
||||
| One a, One b -> One.hamdist a b
|
||||
| Many a, Many b -> Many.hamdist a b
|
||||
@ -446,11 +453,11 @@ let hamdist a b = match a, b with
|
||||
|
||||
Returns the number of bits set to one in the bit string.
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val popcount : t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let popcount = function
|
||||
| One x -> One.popcount x
|
||||
| Many x -> Many.popcount x
|
||||
@ -467,11 +474,11 @@ Bitstring.to_list (of_int 5);;
|
||||
- : int list = [1; 3]
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val to_list : ?accu:(int list) -> t -> int list
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let rec to_list ?(accu=[]) = function
|
||||
| t when (is_zero t) -> List.rev accu
|
||||
| t -> let newlist =
|
||||
@ -481,7 +488,7 @@ let rec to_list ?(accu=[]) = function
|
||||
|> (to_list [@tailcall]) ~accu:newlist
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
Alcotest.(check bool) "to_list" true ([ 1 ; 3 ; 4 ; 6 ] = (to_list (of_int 45)));
|
||||
#+end_src
|
||||
|
||||
@ -503,11 +510,11 @@ Bitstring.permutations 2 4
|
||||
"--++------------------------------------------------------------"]
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val permutations : int -> int -> t list
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let permutations m n =
|
||||
|
||||
let rec aux k u rest =
|
||||
@ -527,7 +534,7 @@ let permutations m n =
|
||||
aux (Util.binom n m) (minus_one (shift_left_one n m)) []
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
check "permutations"
|
||||
(permutations 2 4 = List.map of_int
|
||||
[ 3 ; 5 ; 6 ; 9 ; 10 ; 12 ]);
|
||||
@ -537,11 +544,11 @@ check "permutations"
|
||||
|
||||
Printers can print as a string (~pp_string~) or as an integer (~pp_int~).
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val pp : Format.formatter -> t -> unit
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let pp ppf = function
|
||||
| One x -> One.pp ppf x
|
||||
| Many x -> Many.pp ppf x
|
||||
@ -549,7 +556,7 @@ let pp ppf = function
|
||||
|
||||
** Tests
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "test-ml" t)
|
||||
#+begin_src ocaml :tangle (eval test-ml)
|
||||
()
|
||||
|
||||
let tests = [
|
||||
|
||||
@ -1,12 +1,17 @@
|
||||
#+begin_src elisp tangle: no :results none
|
||||
(setq pwd (file-name-directory buffer-file-name))
|
||||
(setq name (file-name-nondirectory (substring buffer-file-name 0 -4)))
|
||||
(setq lib (concat pwd "lib/"))
|
||||
(setq testdir (concat pwd "test/"))
|
||||
(setq mli (concat lib name ".mli"))
|
||||
(setq ml (concat lib name ".ml"))
|
||||
(setq test-ml (concat testdir name ".ml"))
|
||||
(org-babel-tangle)
|
||||
#+end_src
|
||||
|
||||
|
||||
* Charge
|
||||
:PROPERTIES:
|
||||
:ml: lib/charge.ml
|
||||
:mli: lib/charge.mli
|
||||
:test-ml: test/charge.ml
|
||||
:header-args: :noweb yes :comments both
|
||||
:END:
|
||||
|
||||
@ -14,11 +19,11 @@
|
||||
|
||||
This type should be used for all charges in the program (electrons, nuclei,...).
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
type t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
type t = float
|
||||
#+end_src
|
||||
|
||||
@ -26,36 +31,36 @@ type t = float
|
||||
|
||||
*** ~of_float~ / ~to_float~
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_float : float -> t
|
||||
val to_float : t -> float
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
external of_float : float -> t = "%identity"
|
||||
external to_float : t -> float = "%identity"
|
||||
#+end_src
|
||||
|
||||
*** ~of_int~ / ~to_int~
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_int : int -> t
|
||||
val to_int : t -> int
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let of_int = float_of_int
|
||||
let to_int = int_of_float
|
||||
#+end_src
|
||||
|
||||
*** ~of_string~ / ~to_string~
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val of_string: string -> t
|
||||
val to_string: t -> string
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let of_string = float_of_string
|
||||
|
||||
let to_string x =
|
||||
@ -69,14 +74,14 @@ let to_string x =
|
||||
|
||||
** Simple operations
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val ( + ) : t -> t -> t
|
||||
val ( - ) : t -> t -> t
|
||||
val ( * ) : t -> float -> t
|
||||
val ( / ) : t -> float -> t
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let gen_op op =
|
||||
fun a b ->
|
||||
op (to_float a) (to_float b)
|
||||
@ -90,11 +95,11 @@ let ( / ) = gen_op ( /. )
|
||||
|
||||
** Printers
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "mli" t)
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val pp : Format.formatter -> t -> unit
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (org-entry-get nil "ml" t)
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let pp ppf x =
|
||||
Format.fprintf ppf "@[+%s@]" (to_string x)
|
||||
#+end_src
|
||||
|
||||
367
common/command_line.org
Normal file
367
common/command_line.org
Normal file
@ -0,0 +1,367 @@
|
||||
#+begin_src elisp tangle: no :results none
|
||||
(setq pwd (file-name-directory buffer-file-name))
|
||||
(setq name (file-name-nondirectory (substring buffer-file-name 0 -4)))
|
||||
(setq lib (concat pwd "lib/"))
|
||||
(setq testdir (concat pwd "test/"))
|
||||
(setq mli (concat lib name ".mli"))
|
||||
(setq ml (concat lib name ".ml"))
|
||||
(setq test-ml (concat testdir name ".ml"))
|
||||
(org-babel-tangle)
|
||||
#+end_src
|
||||
|
||||
* Command line
|
||||
:PROPERTIES:
|
||||
:header-args: :noweb yes :comments both
|
||||
:END:
|
||||
|
||||
This module is a wrapper around the ~Getopt~ library and helps to
|
||||
define command-line arguments.
|
||||
|
||||
Here is an example of how to use this module.
|
||||
First, define the specification:
|
||||
#+begin_src ocaml :tangle no
|
||||
let open Command_line in
|
||||
begin
|
||||
set_header_doc (Sys.argv.(0) ^ " - One-line description");
|
||||
set_description_doc "Long description of the command.";
|
||||
set_specs
|
||||
[ { short='c'; long="check"; opt=Optional;
|
||||
doc="Checks the input data";
|
||||
arg=Without_arg; };
|
||||
|
||||
{ short='b' ; long="basis" ; opt=Mandatory;
|
||||
arg=With_arg "<string>";
|
||||
doc="Name of the file containing the basis set"; } ;
|
||||
|
||||
{ short='m' ; long="multiplicity" ; opt=Optional;
|
||||
arg=With_arg "<int>";
|
||||
doc="Spin multiplicity (2S+1). Default is singlet"; } ;
|
||||
]
|
||||
end;
|
||||
#+end_src
|
||||
|
||||
Then, define what to do with the arguments:
|
||||
#+begin_src ocaml :tangle no
|
||||
let c =
|
||||
Command_line.get_bool "check"
|
||||
in
|
||||
|
||||
let basis =
|
||||
match Command_line.get "basis" with
|
||||
| Some x -> x
|
||||
| None -> assert false
|
||||
in
|
||||
|
||||
let multiplicity =
|
||||
match Command_line.get "multiplicity" with
|
||||
| None -> 1
|
||||
| Some n -> int_of_string n
|
||||
in
|
||||
#+end_src
|
||||
|
||||
** Type
|
||||
|
||||
- Short option: in the command line, a dash with a single character
|
||||
(ex: =ls -l=)
|
||||
- Long option: in the command line, two dashes with a word
|
||||
(ex: =ls --directory=)
|
||||
- Command-line options can be ~Mandatory~ or ~Optional~
|
||||
- Documentation of the option is used in the help function
|
||||
- Some options require an argument (~ls --ignore="*.ml"~ ), some
|
||||
don't (~ls -l~) and for some arguments the argument is optional
|
||||
(~git --log[=<n>]~)
|
||||
|
||||
#+NAME:type
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
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 ;
|
||||
}
|
||||
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
<<type>>
|
||||
#+end_src
|
||||
|
||||
** Mutable attributes
|
||||
|
||||
All the options are stored in the hash table ~dict~ where the key
|
||||
is the long option and the value is a value of type ~description~.
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let header_doc = ref ""
|
||||
let description_doc = ref ""
|
||||
let footer_doc = ref ""
|
||||
let anon_args_ref = ref []
|
||||
let specs = ref []
|
||||
let dict = Hashtbl.create 67
|
||||
#+end_src
|
||||
|
||||
Functions to set the header, footer and main description of the
|
||||
documentation provided by the ~help~ function:
|
||||
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val set_header_doc : string -> unit
|
||||
val set_description_doc : string -> unit
|
||||
val set_footer_doc : string -> unit
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let set_header_doc s = header_doc := s
|
||||
let set_description_doc s = description_doc := s
|
||||
let set_footer_doc s = footer_doc := s
|
||||
#+end_src
|
||||
|
||||
Function to create an anonymous argument:
|
||||
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val anonymous : long_opt -> optional -> documentation -> description
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let anonymous name opt doc =
|
||||
{ short=' ' ; long=name; opt; doc; arg=Without_arg; }
|
||||
#+end_src
|
||||
|
||||
** Text formatting functions
|
||||
|
||||
Function to print some text such that it fits on the screen
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
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 "@]"
|
||||
#+end_src
|
||||
|
||||
|
||||
Function to build the short description of the command-line
|
||||
arguments, such as
|
||||
#+begin_example
|
||||
my_program -b <string> [-h] [-u <float>] -x <string> [--]
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
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
|
||||
#+end_src
|
||||
|
||||
|
||||
Function to build the long description of the command-line
|
||||
arguments, such as
|
||||
#+begin_example
|
||||
-x --xyz=<string> Name of the file containing the nuclear
|
||||
coordinates in xyz format
|
||||
#+end_example
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
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
|
||||
#+end_src
|
||||
|
||||
** Query functions
|
||||
|
||||
*** ~anon_args~
|
||||
|
||||
Returns the list of anonymous arguments
|
||||
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val anon_args : unit -> string list
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let anon_args () = !anon_args_ref
|
||||
#+end_src
|
||||
|
||||
*** ~help~
|
||||
|
||||
Prints the documentation of the program.
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
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 "@."
|
||||
#+end_src
|
||||
|
||||
*** ~get~
|
||||
|
||||
Returns the argument associated with a long option.
|
||||
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val get : long_opt -> string option
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let get x =
|
||||
try Some (Hashtbl.find dict x)
|
||||
with Not_found -> None
|
||||
#+end_src
|
||||
|
||||
*** ~get_bool~
|
||||
|
||||
True if the ~Optional~ argument is present in the command-line
|
||||
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val get_bool : long_opt -> bool
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
let get_bool x = Hashtbl.mem dict x
|
||||
#+end_src
|
||||
|
||||
** Specification
|
||||
|
||||
Gives the specifications of the current program as a list of
|
||||
~descrption~ variables.
|
||||
|
||||
#+begin_src ocaml :tangle (eval mli)
|
||||
val set_specs : description list -> unit
|
||||
#+end_src
|
||||
|
||||
#+begin_src ocaml :tangle (eval ml)
|
||||
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 ; 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_ref := !anon_args_ref @ [x]);
|
||||
|
||||
if (get_bool "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.")
|
||||
)
|
||||
#+end_src
|
||||
@ -1,59 +1,81 @@
|
||||
(* [[file:../command_line.org::*Type][Type:2]] *)
|
||||
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 = {
|
||||
type description = {
|
||||
short: short_opt ;
|
||||
long : long_opt ;
|
||||
opt : optional ;
|
||||
doc : documentation ;
|
||||
arg : argument ;
|
||||
}
|
||||
}
|
||||
(* Type:2 ends here *)
|
||||
|
||||
let anon_args = ref []
|
||||
and header_doc = ref ""
|
||||
and description_doc = ref ""
|
||||
and footer_doc = ref ""
|
||||
and specs = ref []
|
||||
(* Mutable attributes
|
||||
*
|
||||
* All the options are stored in the hash table ~dict~ where the key
|
||||
* is the long option and the value is a value of type ~description~. *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*Mutable attributes][Mutable attributes:1]] *)
|
||||
let header_doc = ref ""
|
||||
let description_doc = ref ""
|
||||
let footer_doc = ref ""
|
||||
let anon_args_ref = ref []
|
||||
let specs = ref []
|
||||
let dict = Hashtbl.create 67
|
||||
(* Mutable attributes:1 ends here *)
|
||||
|
||||
(* [[file:../command_line.org::*Mutable attributes][Mutable attributes:3]] *)
|
||||
let set_header_doc s = header_doc := s
|
||||
let set_description_doc s = description_doc := s
|
||||
let set_footer_doc s = footer_doc := s
|
||||
(* Mutable attributes:3 ends here *)
|
||||
|
||||
(* 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
|
||||
|
||||
(* [[file:../command_line.org::*Mutable attributes][Mutable attributes:5]] *)
|
||||
let anonymous name opt doc =
|
||||
{ short=' ' ; long=name; opt; doc; arg=Without_arg; }
|
||||
(* Mutable attributes:5 ends here *)
|
||||
|
||||
(* Text formatting functions
|
||||
*
|
||||
* Function to print some text such that it fits on the screen *)
|
||||
|
||||
(* [[file:../command_line.org::*Text formatting functions][Text formatting functions:1]] *)
|
||||
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
|
||||
| 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 "@]"
|
||||
;;
|
||||
|
||||
(* Text formatting functions:1 ends here *)
|
||||
|
||||
|
||||
|
||||
|
||||
(* Function to build the short description of the command-line
|
||||
* arguments, such as
|
||||
* #+begin_example
|
||||
* my_program -b <string> [-h] [-u <float>] -x <string> [--]
|
||||
* #+end_example *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*Text formatting functions][Text formatting functions:2]] *)
|
||||
let output_short x =
|
||||
match x.short, x.opt, x.arg with
|
||||
| ' ', Mandatory, _ -> Format.printf "@[%s@]" x.long
|
||||
@ -64,8 +86,20 @@ let output_short x =
|
||||
| _ , 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
|
||||
(* Text formatting functions:2 ends here *)
|
||||
|
||||
|
||||
|
||||
|
||||
(* Function to build the long description of the command-line
|
||||
* arguments, such as
|
||||
* #+begin_example
|
||||
* -x --xyz=<string> Name of the file containing the nuclear
|
||||
* coordinates in xyz format
|
||||
* #+end_example *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*Text formatting functions][Text formatting functions:3]] *)
|
||||
let output_long max_width x =
|
||||
let arg =
|
||||
match x.short, x.arg with
|
||||
@ -86,114 +120,128 @@ let output_long max_width x =
|
||||
end;
|
||||
Format.printf "@]";
|
||||
output_text x.doc
|
||||
(* Text formatting functions:3 ends here *)
|
||||
|
||||
(* [[file:../command_line.org::*~anon_args~][~anon_args~:2]] *)
|
||||
let anon_args () = !anon_args_ref
|
||||
(* ~anon_args~:2 ends here *)
|
||||
|
||||
(* ~help~
|
||||
*
|
||||
* Prints the documentation of the program. *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*~help~][~help~:1]] *)
|
||||
let help () =
|
||||
|
||||
(* Print the header *)
|
||||
output_text !header_doc;
|
||||
Format.printf "@.@.";
|
||||
(* 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 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 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
|
||||
(* 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 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 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:@,";
|
||||
(* 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 "@]@,@]@,";
|
||||
Format.printf "@[<v 0>" ;
|
||||
List.iter (fun x -> Format.printf "@ "; output_long max_width x) options;
|
||||
Format.printf "@]@,@]@,";
|
||||
|
||||
|
||||
(* Print footer *)
|
||||
if !description_doc <> "" then
|
||||
(* 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 "@."
|
||||
(* Print footer *)
|
||||
output_text !footer_doc;
|
||||
Format.printf "@."
|
||||
(* ~help~:1 ends here *)
|
||||
|
||||
(* [[file:../command_line.org::*~get~][~get~:2]] *)
|
||||
let get x =
|
||||
try Some (Hashtbl.find dict x)
|
||||
with Not_found -> None
|
||||
(* ~get~:2 ends here *)
|
||||
|
||||
(* [[file:../command_line.org::*~get_bool~][~get_bool~:2]] *)
|
||||
let get_bool x = Hashtbl.mem dict x
|
||||
(* ~get_bool~:2 ends here *)
|
||||
|
||||
(* [[file:../command_line.org::*Specification][Specification:2]] *)
|
||||
let set_specs specs_in =
|
||||
specs := { short='h' ;
|
||||
long ="help" ;
|
||||
doc ="Prints the help message." ;
|
||||
arg =Without_arg ;
|
||||
opt =Optional ;
|
||||
} :: 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 ; 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
|
||||
let cmd_specs =
|
||||
List.filter (fun x -> x.short != ' ') !specs
|
||||
|> List.map (fun { short ; long ; 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_ref := !anon_args_ref @ [x]);
|
||||
|
||||
if (get_bool "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.")
|
||||
)
|
||||
(* Specification:2 ends here *)
|
||||
|
||||
87
common/lib/command_line.mli
Normal file
87
common/lib/command_line.mli
Normal file
@ -0,0 +1,87 @@
|
||||
(* Type
|
||||
*
|
||||
* - Short option: in the command line, a dash with a single character
|
||||
* (ex: =ls -l=)
|
||||
* - Long option: in the command line, two dashes with a word
|
||||
* (ex: =ls --directory=)
|
||||
* - Command-line options can be ~Mandatory~ or ~Optional~
|
||||
* - Documentation of the option is used in the help function
|
||||
* - Some options require an argument (~ls --ignore="*.ml"~ ), some
|
||||
* don't (~ls -l~) and for some arguments the argument is optional
|
||||
* (~git --log[=<n>]~)
|
||||
*
|
||||
* #+NAME:type *)
|
||||
|
||||
(* [[file:../command_line.org::type][type]] *)
|
||||
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 ;
|
||||
}
|
||||
(* type ends here *)
|
||||
|
||||
|
||||
|
||||
(* Functions to set the header, footer and main description of the
|
||||
* documentation provided by the ~help~ function: *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*Mutable attributes][Mutable attributes:2]] *)
|
||||
val set_header_doc : string -> unit
|
||||
val set_description_doc : string -> unit
|
||||
val set_footer_doc : string -> unit
|
||||
(* Mutable attributes:2 ends here *)
|
||||
|
||||
|
||||
|
||||
(* Function to create an anonymous argument: *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*Mutable attributes][Mutable attributes:4]] *)
|
||||
val anonymous : long_opt -> optional -> documentation -> description
|
||||
(* Mutable attributes:4 ends here *)
|
||||
|
||||
(* ~anon_args~
|
||||
*
|
||||
* Returns the list of anonymous arguments *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*~anon_args~][~anon_args~:1]] *)
|
||||
val anon_args : unit -> string list
|
||||
(* ~anon_args~:1 ends here *)
|
||||
|
||||
(* ~get~
|
||||
*
|
||||
* Returns the argument associated with a long option. *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*~get~][~get~:1]] *)
|
||||
val get : long_opt -> string option
|
||||
(* ~get~:1 ends here *)
|
||||
|
||||
(* ~get_bool~
|
||||
*
|
||||
* True if the ~Optional~ argument is present in the command-line *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*~get_bool~][~get_bool~:1]] *)
|
||||
val get_bool : long_opt -> bool
|
||||
(* ~get_bool~:1 ends here *)
|
||||
|
||||
(* Specification
|
||||
*
|
||||
* Gives the specifications of the current program as a list of
|
||||
* ~descrption~ variables. *)
|
||||
|
||||
|
||||
(* [[file:../command_line.org::*Specification][Specification:1]] *)
|
||||
val set_specs : description list -> unit
|
||||
(* Specification:1 ends here *)
|
||||
Loading…
Reference in New Issue
Block a user