CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Benchmarked the result on allocations familiales, it is fast enough

Browse Source
This commit is contained in:
Denis Merigoux 2021-01-28 23:46:39 +01:00
parent 617d19df24
commit 313ca065f4
14 changed files with 250 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -14,7 +14,7 @@ dependencies-ocaml:
ocamlformat ANSITerminal sedlex menhir menhirLib dune cmdliner obelisk \
re obelisk unionfind bindlib zarith zarith_stubs_js ocamlgraph \
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile \
visitors
visitors benchmark
init-submodules:
git submodule update --init
@ -147,7 +147,7 @@ tests: test_suite test_examples
##########################################
allocations_familiales_ml:
SCOPE=InterfaceAllocationsFamiliales $(MAKE) -C examples/allocations_familiales allocations_familiales.ml -B
$(MAKE) -C examples/allocations_familiales allocations_familiales.ml -B
cp -f examples/allocations_familiales/allocations_familiales.ml src/catala_examples
$(MAKE) -C ./ format
dune exec src/catala_examples/driver.exe

1
dune-project
View File

@ -35,6 +35,7 @@
(ocamlgraph (>= 1.8.8))
(calendar (>= 2.04))
(visitors (>= 20200210))
(benchmark (>= 1.6))
)
)

1
examples/Makefile.common.mk
View File

@ -35,7 +35,6 @@ endif
@$(CATALA) Makefile $<
@$(CATALA) \
OCaml \
-s $(SCOPE) \
$<

3
examples/allocations_familiales/securite_sociale_R.catala_fr
View File

@ -109,7 +109,8 @@ champ d'application AllocationsFamiliales :
montant_initial_base *€ rapport_enfants_total_moyen
définition rapport_enfants_total_moyen égal à
nombre_moyen_enfants /. nombre_total_enfants
si nombre_total_enfants = 0,0 alors 0,0 sinon
(nombre_moyen_enfants /. nombre_total_enfants)
*/
Le nombre moyen d'enfants, pour chaque foyer, est obtenu en faisant la somme

11
examples/allocations_familiales/tests/tests_allocations_familiales.catala_fr
View File

@ -95,4 +95,15 @@ champ d'application Test4:
définition f.date_courante égal à |01/05/2020|
définition f.résidence égal à Métropole
assertion f.montant_versé = 99,37€
déclaration champ d'application Test5:
contexte f champ d'application InterfaceAllocationsFamiliales
contexte données champ d'application Données
champ d'application Test5:
définition f.enfants égal à [données.enfant1]
définition f.ressources_ménage égal à 30 000 €
définition f.date_courante égal à |01/05/2020|
définition f.résidence égal à Métropole
assertion f.montant_versé = 0,00€
*/

2
src/catala/default_calculus/print.ml
View File

@ -42,7 +42,7 @@ let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
match l with
| TUnit -> Format.fprintf fmt "unit"
| TBool -> Format.fprintf fmt "boolean"
| TBool -> Format.fprintf fmt "bool"
| TInt -> Format.fprintf fmt "integer"
| TRat -> Format.fprintf fmt "decimal"
| TMoney -> Format.fprintf fmt "money"

13
src/catala/driver.ml
View File

@ -126,9 +126,10 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
Cli.debug_print "Name resolution...";
let ctxt = Surface.Name_resolution.form_context program in
let scope_uid =
match ex_scope with
| None -> Errors.raise_error "No scope was provided for execution."
| Some name -> (
match (ex_scope, backend) with
| None, Cli.Run -> Errors.raise_error "No scope was provided for execution."
| None, _ -> snd (Desugared.Ast.IdentMap.choose ctxt.scope_idmap)
| Some name, _ -> (
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| None ->
Errors.raise_error
@ -140,7 +141,9 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
Cli.debug_print "Collecting rules...";
let prgm = Desugared.Desugared_to_scope.translate_program prgm in
Cli.debug_print "Translating to default calculus...";
let prgm, prgm_expr = Scopelang.Scope_to_dcalc.translate_program prgm scope_uid in
let prgm, prgm_expr, type_ordering =
Scopelang.Scope_to_dcalc.translate_program prgm scope_uid
in
(* Cli.debug_print (Format.asprintf "Output program:@\n%a" (Dcalc.Print.format_expr ctx)
prgm); *)
Cli.debug_print "Typechecking...";
@ -184,7 +187,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
Cli.debug_print (Printf.sprintf "Writing to %s..." output_file);
let oc = open_out output_file in
let fmt = Format.formatter_of_out_channel oc in
Lcalc.To_ocaml.format_program fmt prgm;
Lcalc.To_ocaml.format_program fmt prgm type_ordering;
close_out oc;
0
| _ -> assert false

2
src/catala/lambda_calculus/dune
View File

@ -1,7 +1,7 @@
(library
(name lcalc)
(public_name catala.lcalc)
(libraries bindlib dcalc))
(libraries bindlib dcalc scopelang))
(documentation
(package catala))

113
src/catala/lambda_calculus/to_ocaml.ml
View File

@ -24,8 +24,13 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit
(Pos.same_pos_as (Dcalc.Ast.LRat i) l)
| LMoney e -> Format.fprintf fmt "money_of_cent_string@ \"%s\"" (Z.to_string e)
| LDate d -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LDate d) l)
| LDuration d -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LDuration d) l)
| LDate d ->
Format.fprintf fmt "date_of_numbers (%d) (%d) (%d)" (CalendarLib.Date.year d)
(CalendarLib.Date.int_of_month (CalendarLib.Date.month d))
(CalendarLib.Date.day_of_month d)
| LDuration d ->
let years, months, days = CalendarLib.Date.Period.ymd d in
Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days
let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
Format.fprintf fmt "%s"
@ -52,29 +57,28 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : un
| Lte k -> Format.fprintf fmt "%s%a" "<=" format_op_kind k
| Gt k -> Format.fprintf fmt "%s%a" ">" format_op_kind k
| Gte k -> Format.fprintf fmt "%s%a" ">=" format_op_kind k
| Map -> Format.fprintf fmt "List.map"
| Filter -> Format.fprintf fmt "List.filter"
| Map -> Format.fprintf fmt "Array.map"
| Filter -> Format.fprintf fmt "array_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> Format.fprintf fmt "List.fold_left"
match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit =
Format.fprintf fmt "%s"
( match Pos.unmark op with
| Minus _ -> "-"
| Not -> "not"
| ErrorOnEmpty -> "error_empty"
| Log (entry, infos) ->
Format.asprintf "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
infos
| Length -> "length"
| IntToRat -> "int_to_rat"
| GetDay -> "get_day"
| GetMonth -> "get_month"
| GetYear -> "get_year" )
match Pos.unmark op with
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
| Not -> Format.fprintf fmt "%s" "not"
| ErrorOnEmpty -> Format.fprintf fmt "%s" "error_empty"
| Log (entry, infos) ->
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
infos
| Length -> Format.fprintf fmt "%s" "array_length"
| IntToRat -> Format.fprintf fmt "%s" "int_to_rat"
| GetDay -> Format.fprintf fmt "%s" "get_day"
| GetMonth -> Format.fprintf fmt "%s" "get_month"
| GetYear -> Format.fprintf fmt "%s" "get_year"
let to_ascii (s : string) : string =
let out = ref "" in
@ -166,7 +170,7 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp
Format.fprintf fmt "%a=@ %a" format_struct_field_name struct_field format_expr e))
(List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
| EArray es ->
Format.fprintf fmt "@[<hov 2>[%a]@]"
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
@ -233,6 +237,7 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_expr arg1
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
| EApp (f, args) ->
@ -251,37 +256,41 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp
Format.fprintf fmt "@[<hov 2>try@ %a@ with@ %a@ ->@ %a@]" format_expr e1 format_exception exc
format_expr e2
let format_ctx (fmt : Format.formatter) (ctx : D.decl_ctx) : unit =
Format.fprintf fmt "%a\n\n%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(fun fmt (struct_name, struct_fields) ->
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}" format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ
struct_field_type))
struct_fields))
(Dcalc.Ast.StructMap.bindings ctx.Dcalc.Ast.ctx_structs)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_name, enum_cons) ->
Format.fprintf fmt "type %a =@\n@[<hov 2> %a@]@\n" format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ
enum_cons_type))
enum_cons))
(List.filter
(* option is a polymorphic type which we don't handle well... *)
(fun (e, _) -> e <> Compile_with_exceptions.option_enum)
(Dcalc.Ast.EnumMap.bindings ctx.Dcalc.Ast.ctx_enums))
let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}" format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ
struct_field_type))
struct_fields
in
let format_enum_decl fmt (enum_name, enum_cons) =
Format.fprintf fmt "type %a =@\n@[<hov 2> %a@]@\n" format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ
enum_cons_type))
enum_cons
in
List.iter
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n@\n" format_struct_decl
(s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n@\n" format_enum_decl
(e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums))
type_ordering
let format_program (fmt : Format.formatter) (p : Ast.program) : unit =
Format.fprintf fmt "open Runtime@\n@\n[@@@@@@ocaml.warning \"-26\"]@\n@\n%a@\n@\n%a" format_ctx
p.decl_ctx
let format_program (fmt : Format.formatter) (p : Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
Format.fprintf fmt "open Runtime@\n@\n[@@@@@@ocaml.warning \"-26\"]@\n@\n%a@\n@\n%a"
(format_ctx type_ordering) p.decl_ctx
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
(fun fmt (name, e) ->

7
src/catala/scope_language/dependency.ml
View File

@ -203,11 +203,11 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDepend
in
g
let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : unit =
let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TVertex.t list =
let g = build_type_graph structs enums in
(* if there is a cycle, there will be an strongly connected component of cardinality > 1 *)
let sccs = TSCC.scc_list g in
if List.length sccs < TDependencies.nb_vertex g then
( if List.length sccs < TDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
Errors.raise_multispanned_error "Cyclic dependency detected between types!"
(List.flatten
@ -224,4 +224,5 @@ let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : unit =
( Some ("Used here in the definition of another cycle type " ^ succ_str ^ ":"),
edge_pos );
])
scc))
scc)) );
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

6
src/catala/scope_language/scope_to_dcalc.ml
View File

@ -518,10 +518,10 @@ let build_scope_typ_from_sig (scope_sig : (Ast.ScopeVar.t * Dcalc.Ast.typ) list)
scope_sig result_typ
let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName.t) :
Dcalc.Ast.program * Dcalc.Ast.expr Pos.marked =
Dcalc.Ast.program * Dcalc.Ast.expr Pos.marked * Dependency.TVertex.t list =
let scope_dependencies = Dependency.build_program_dep_graph prgm in
Dependency.check_for_cycle_in_scope scope_dependencies;
Dependency.check_type_cycles prgm.program_structs prgm.program_enums;
let types_ordering = Dependency.check_type_cycles prgm.program_structs prgm.program_enums in
let scope_ordering = Dependency.get_scope_ordering scope_dependencies in
let struct_ctx = prgm.program_structs in
let enum_ctx = prgm.program_enums in
@ -570,4 +570,4 @@ let translate_program (prgm : Ast.program) (top_level_scope_name : Ast.ScopeName
(dvar, Bindlib.unbox scope_expr) :: scopes ))
scope_ordering (acc, [])
in
({ scopes; decl_ctx }, Bindlib.unbox whole_program_expr)
({ scopes; decl_ctx }, Bindlib.unbox whole_program_expr, types_ordering)

47
src/catala_examples/driver.ml
View File

@ -1,3 +1,48 @@
module M = Allocations_familiales
open Runtime
let _ = Allocations_familiales.test1 (fun () -> assert false)
let run_test (id : int) =
let _, _, _, _, _, amount =
M.interfaceallocationsfamiliales
(fun _ -> date_of_numbers 2020 05 01)
(fun _ ->
[|
{
d_identifiant = Z.of_int 1;
d_r_muneration_mensuelle = Z.of_int 0;
d_date_de_naissance = date_of_numbers 2007 01 01;
d_garde_altern_e = M.NonGardeUnique ();
d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille ();
};
{
d_identifiant = Z.of_int 2;
d_r_muneration_mensuelle = Z.of_int 0;
d_date_de_naissance = date_of_numbers 2009 01 01;
d_garde_altern_e = M.NonGardeUnique ();
d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille ();
};
{
d_identifiant = Z.of_int 3;
d_r_muneration_mensuelle = Z.of_int 40000;
d_date_de_naissance = date_of_numbers 2003 01 01;
d_garde_altern_e = M.OuiPartageAllocations ();
d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille ();
};
{
d_identifiant = Z.of_int id;
d_r_muneration_mensuelle = Z.of_int 110000;
d_date_de_naissance = date_of_numbers 2001 01 01;
d_garde_altern_e = M.NonGardeUnique ();
d_pris_en_charge_par_services_sociaux = M.NonPriseEnChargeFamille ();
};
|])
(fun _ -> raise EmptyError)
(fun _ -> money_of_cent_string "3000000")
(fun _ -> M.M_tropole ())
(fun _ -> raise EmptyError)
in
assert (Z.to_int amount = 35126)
let _ =
let _ = Benchmark.latency1 ~style:Auto (Int64.of_int 100000) run_test 4 in
()

10
src/catala_examples/dune
View File

@ -2,5 +2,13 @@
(name driver)
(modes native)
(package catala)
(modules
(:standard \ runtime))
(public_name catala_examples)
(libraries catala.utils zarith calendar))
(libraries runtime))
(library
(name runtime)
(public_name catala.runtime)
(libraries catala.utils zarith calendar benchmark)
(modules runtime))

113
src/catala_examples/runtime.ml
View File

@ -34,12 +34,13 @@ let decimal_of_string (d : string) : decimal = Q.of_string d
let integer_of_string (i : string) : integer = Z.of_string i
(**{1 Logging} *)
let date_of_numbers (year : int) (month : int) (day : int) : date =
CalendarLib.Date.make year month day
let log_entry : 'a. string -> 'a -> 'a =
fun msg arg ->
Printf.printf "%s\n" msg;
arg
let duration_of_numbers (year : int) (month : int) (day : int) : duration =
CalendarLib.Date.Period.make year month day
let int_to_rat (i : integer) : decimal = Q.of_bigint i
(**{1 Exceptions and defaults} *)
@ -48,10 +49,10 @@ exception EmptyError
let error_empty : 'a. 'a -> 'a =
fun x -> try x with EmptyError -> Errors.raise_error "empty value found!"
let handle_default : 'a. (unit -> 'a) list -> (unit -> bool) -> (unit -> 'a) -> 'a =
let handle_default : 'a. (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a =
fun exceptions just cons ->
let except =
List.fold_left
Array.fold_left
(fun acc except ->
let new_val = try Some (except ()) with EmptyError -> None in
match (acc, new_val) with
@ -64,12 +65,100 @@ let handle_default : 'a. (unit -> 'a) list -> (unit -> bool) -> (unit -> 'a) ->
(**{1 Operators} *)
let ( *$ ) (_m : money) (_d : decimal) : money = assert false
let ( *$ ) (i1 : money) (i2 : decimal) : money =
let rat_result = Q.mul (Q.of_bigint i1) i2 in
let res, remainder = Z.div_rem (Q.num rat_result) (Q.den rat_result) in
(* we perform nearest rounding when multiplying an amount of money by a decimal !*)
if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) else res
let ( +$ ) (_m1 : money) (_m2 : money) : money = assert false
let ( /$ ) (i1 : money) (i2 : money) : decimal =
if i2 <> Z.zero then Q.div (Q.of_bigint i1) (Q.of_bigint i2)
else Errors.raise_error "division by zero at runtime"
let ( -$ ) (_m1 : money) (_m2 : money) : money = assert false
let ( +$ ) (i1 : money) (i2 : money) : money = Z.add i1 i2
let ( <=$ ) (_m1 : money) (_m2 : money) : bool = assert false
let ( -$ ) (i1 : money) (i2 : money) : money = Z.sub i1 i2
let ( >=! ) (_m1 : integer) (_m2 : integer) : bool = assert false
let ( ~-$ ) (i1 : money) : money = Z.sub Z.zero i1
let ( +! ) (i1 : integer) (i2 : integer) : integer = Z.add i1 i2
let ( -! ) (i1 : integer) (i2 : integer) : integer = Z.sub i1 i2
let ( ~-! ) (i1 : integer) : integer = Z.sub Z.zero i1
let ( *! ) (i1 : integer) (i2 : integer) : integer = Z.mul i1 i2
let ( /! ) (i1 : integer) (i2 : integer) : integer =
if i2 <> Z.zero then Z.div i1 i2 else Errors.raise_error "division by zero at runtime"
let ( +. ) (i1 : decimal) (i2 : decimal) : decimal = Q.add i1 i2
let ( -. ) (i1 : decimal) (i2 : decimal) : decimal = Q.sub i1 i2
let ( ~-. ) (i1 : decimal) : decimal = Q.sub Q.zero i1
let ( *. ) (i1 : decimal) (i2 : decimal) : decimal = Q.mul i1 i2
let ( /. ) (i1 : decimal) (i2 : decimal) : decimal =
if i2 <> Q.zero then Q.div i1 i2 else Errors.raise_error "division by zero at runtime"
let ( +@ ) (d1 : date) (d2 : duration) : date = CalendarLib.Date.add d1 d2
let ( -@ ) (d1 : date) (d2 : date) : duration = CalendarLib.Date.sub d1 d2
let ( +^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.add d1 d2
let ( -^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.sub d1 d2
let ( <=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 <= 0
let ( >=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 >= 0
let ( <$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 < 0
let ( >$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 > 0
let ( >=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 >= 0
let ( <=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 <= 0
let ( >! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 > 0
let ( <! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 < 0
let ( >=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 >= 0
let ( <=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 <= 0
let ( >@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 > 0
let ( <@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 < 0
let compare_periods (p1 : CalendarLib.Date.Period.t) (p2 : CalendarLib.Date.Period.t) : int =
try
let p1_days = CalendarLib.Date.Period.nb_days p1 in
let p2_days = CalendarLib.Date.Period.nb_days p2 in
compare p1_days p2_days
with CalendarLib.Date.Period.Not_computable ->
Errors.raise_error
"Cannot compare together durations that cannot be converted to a precise number of days"
let ( >=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 >= 0
let ( <=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 <= 0
let ( >^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 > 0
let ( <^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 < 0
let array_filter (f : 'a -> bool) (a : 'a array) : 'a array =
Array.of_list (List.filter f (Array.to_list a))
let array_length (a : 'a array) : integer = Z.of_int (Array.length a)
let get_year (d : date) : integer = Z.of_int (CalendarLib.Date.year d)
let get_month (d : date) = Z.of_int (CalendarLib.Date.int_of_month (CalendarLib.Date.month d))
let get_day (d : date) = Z.of_int (CalendarLib.Date.day_of_month d)