From c4d09d5b03a18a96696795793c36a41dd34d4a6d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Fran=C3=A7ois=20Bobot?= <francois.bobot@cea.fr>
Date: Sat, 7 Nov 2020 22:57:40 +0100
Subject: [PATCH] Get the modification made on popop files in witan
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Modifications made by François Bobot, Stéphane Graham-Lengrand and Guillaume
Bury. The witan licence has been used for the files not mainly modified by Bobot
---
.gitattributes | 5 -
.gitignore | 38 +-
.spcrc | 7 -
INSTALL.adoc | 39 -
Makefile | 170 +-
README.adoc | 26 -
README.md | 25 +
TODO | 6 +
_tags | 1 -
api.odocl | 46 -
compare_smt2.sh | 32 +
dune-project | 5 +
fuzz/compare.sh | 4 -
fuzz/compare_smt2.sh | 14 -
fuzz/fuzzsmt2.sh | 24 -
fuzz/iter_on_commits.sh | 12 -
fuzz/non_terminating_smt2.sh | 24 -
fuzz/search_diff.ml | 67 -
misc/headache_config.txt | 16 +
misc/header.txt | 20 +
misc/header_colibrics.txt | 17 +
misc/header_framac.txt | 19 +
misc/header_jc.txt | 10 +
misc/header_ocaml.txt | 10 +
misc/header_why3.txt | 8 +
misc/header_witan.txt | 20 +
popop_top.mltop | 1 -
src/arith/arith.ml | 1129 ----------
src/arith/interval.ml | 311 ---
src/arith/interval.mli | 60 -
src/arith/polynome.ml | 172 --
src/bin/dune | 13 +
src/bin/options.ml | 212 ++
src/bin/options.mli | 66 +
src/bin/typecheck.ml | 936 ++++++++
src/bin/witan.ml | 61 +
src/bool.ml | 850 -------
src/bool.mli | 82 -
src/bv.ml | 474 ----
src/cmd/popop_cmd.ml | 82 -
src/cmd/popop_dimacs.ml | 10 -
src/cmd/popop_lib.ml | 4 -
src/conflict.ml | 1477 ------------
src/conflict.mli | 285 ---
src/core/demon.ml | 549 +++++
src/{ => core}/demon.mli | 114 +-
src/core/dune | 12 +
src/core/egraph.ml | 1186 ++++++++++
src/core/egraph.mli | 183 ++
.../popop_of_smtlib2.mli => core/env.ml} | 59 +-
src/core/env.mli | 35 +
src/core/events.ml | 280 +++
src/core/events.mli | 124 ++
src/core/interp.ml | 115 +
src/core/interp.mli | 37 +
src/core/structures/domKind.ml | 67 +
src/core/structures/domKind.mli | 55 +
src/core/structures/dune | 12 +
src/core/structures/nodes.ml | 455 ++++
src/core/structures/nodes.mli | 234 ++
src/{popop.ml => core/structures/term.ml} | 42 +-
src/core/structures/ty.ml | 33 +
.../dimacs.mli => core/structures/ty.mli} | 55 +-
src/core/theory.ml | 24 +
src/core/trail.ml | 32 +
src/core/witan_core.ml | 95 +
src/demon.ml | 464 ----
src/dune | 0
src/equality.ml | 1132 ----------
src/equality.mli | 69 -
src/explanation.ml | 473 ----
src/explanation.mli | 252 ---
src/inputlang/altergo/popop_of_altergo.ml | 196 --
src/inputlang/altergo/symbols.ml | 139 --
src/inputlang/altergo/symbols.mli | 64 -
src/inputlang/altergo/why_lexer.mll | 308 ---
src/inputlang/altergo/why_parser.mly | 554 -----
src/inputlang/altergo/why_ptree.mli | 193 --
src/inputlang/altergo/why_ty.ml | 369 ---
src/inputlang/altergo/why_ty.mli | 87 -
src/inputlang/altergo/why_typing.ml | 1390 ------------
src/inputlang/altergo/why_typing.mli | 36 -
src/inputlang/dimacs_cnf/dimacs.mll | 127 --
src/inputlang/smtlib2/COPYRIGHT | 3 -
src/inputlang/smtlib2/popop_of_smtlib2.ml | 247 ---
src/inputlang/smtlib2/smtlib2_ast.ml | 180 --
src/inputlang/smtlib2/smtlib2_lexer.mll | 95 -
src/inputlang/smtlib2/smtlib2_parser.mly | 290 ---
src/{util => popop_lib}/IArray.ml | 42 +-
src/{util => popop_lib}/IArray.mli | 42 +-
src/{util => popop_lib}/bag.ml | 44 +-
src/{util => popop_lib}/bag.mli | 50 +-
src/{util => popop_lib}/cmdline.ml | 8 +-
src/{util => popop_lib}/cmdline.mli | 2 +-
src/{util => popop_lib}/debug.ml | 158 +-
src/{util => popop_lib}/debug.mli | 53 +-
src/popop_lib/dune | 10 +
src/{util => popop_lib}/enum.ml | 40 +-
src/{util => popop_lib}/enum.mli | 40 +-
src/{util => popop_lib}/exn_printer.ml | 6 +-
src/{util => popop_lib}/exn_printer.mli | 6 +-
src/{util => popop_lib}/exthtbl.ml | 19 +-
src/{util => popop_lib}/exthtbl.mli | 26 +-
src/popop_lib/extmap.ml | 667 ++++++
src/{util => popop_lib}/extmap.mli | 11 +-
src/{util => popop_lib}/extset.ml | 26 +-
src/{util => popop_lib}/extset.mli | 26 +-
src/{util => popop_lib}/hashcons.ml | 18 +-
src/{util => popop_lib}/hashcons.mli | 6 +-
src/popop_lib/intmap.ml | 1726 +++++++++++++++
src/{util => popop_lib}/intmap.mli | 42 +-
src/{util => popop_lib}/intmap_hetero.ml | 112 +-
src/{util => popop_lib}/intmap_hetero.mli | 74 +-
src/{util => popop_lib}/leftistheap.ml | 46 +-
src/{util => popop_lib}/leftistheap.mli | 30 +-
src/{util => popop_lib}/lists.ml | 2 +-
src/{util => popop_lib}/lists.mli | 2 +-
src/{util => popop_lib}/loc.ml | 8 +-
src/{util => popop_lib}/loc.mli | 2 +-
src/{util => popop_lib}/map_intf.ml | 30 +-
src/{util => popop_lib}/number.ml | 8 +-
src/{util => popop_lib}/number.mli | 4 +-
src/{util => popop_lib}/opt.ml | 10 +-
src/{util => popop_lib}/opt.mli | 6 +-
src/{util => popop_lib}/plugin.ml | 6 +-
src/{util => popop_lib}/plugin.mli | 2 +-
.../stdlib.ml => popop_lib/popop_stdlib.ml} | 64 +-
.../stdlib.mli => popop_lib/popop_stdlib.mli} | 45 +-
src/{util => popop_lib}/pp.ml | 69 +-
src/popop_lib/pp.mli | 161 ++
src/{util => popop_lib}/print_tree.ml | 10 +-
src/{util => popop_lib}/print_tree.mli | 10 +-
src/{util => popop_lib}/refo.ml | 40 +-
src/{util => popop_lib}/refo.mli | 40 +-
src/{util => popop_lib}/simple_vector.ml | 61 +-
src/{util => popop_lib}/simple_vector.mli | 46 +-
src/{util => popop_lib}/strings.ml | 28 +-
src/{util => popop_lib}/strings.mli | 11 +-
src/{util => popop_lib}/sysutil.ml | 16 +-
src/{util => popop_lib}/sysutil.mli | 2 +-
src/{util => popop_lib}/unit.ml | 51 +-
src/{util => popop_lib}/unit.mli | 42 +-
src/{util => popop_lib}/util.ml | 2 +-
src/{util => popop_lib}/util.mli | 2 +-
src/{util => popop_lib}/vector_hetero.ml | 119 +-
src/{util => popop_lib}/vector_hetero.mli | 91 +-
src/{util => popop_lib}/warning.ml | 4 +-
src/{util => popop_lib}/warning.mli | 2 +-
src/{util => popop_lib}/weakhtbl.ml | 4 +-
src/{util => popop_lib}/weakhtbl.mli | 4 +-
src/popop_types.ml | 515 -----
src/popop_types.mli | 256 ---
src/scheduler.ml | 35 -
src/scheduler_queue.ml | 431 ----
src/scheduler_queue.mli | 68 -
src/solver.ml | 1173 ----------
src/solver.mli | 264 ---
src/solver/dune | 12 +
src/solver/input.ml | 86 +
src/solver/input.mli | 38 +
src/solver/notypecheck.ml | 361 +++
src/solver/notypecheck.mli | 29 +
src/solver/scheduler.ml | 418 ++++
src/solver/scheduler.mli | 36 +
src/solver/solver.ml | 22 +
src/stdlib/comp_keys.ml | 399 ++++
src/stdlib/comp_keys.mli | 187 ++
src/stdlib/config.ml | 21 +
src/stdlib/context.ml | 244 ++
src/stdlib/context.mli | 136 ++
src/stdlib/dune | 11 +
src/stdlib/hashtbl_hetero.ml | 210 ++
src/stdlib/hashtbl_hetero.mli | 35 +
src/stdlib/hashtbl_hetero_sig.ml | 168 ++
src/stdlib/keys.ml | 278 +++
src/{arith/arith.mli => stdlib/keys.mli} | 63 +-
src/stdlib/keys_sig.ml | 174 ++
src/stdlib/map_hetero.ml | 144 ++
src/stdlib/map_hetero.mli | 30 +
src/stdlib/map_hetero_sig.ml | 153 ++
src/{util => stdlib}/shuffle.ml | 34 +-
src/stdlib/shuffle.mli | 60 +
src/stdlib/std.ml | 101 +
src/stdlib/std.mli | 60 +
src/stdlib/std_sig.ml | 48 +
src/template.ml | 106 -
src/tests/dune | 15 +
.../solve/dimacs/sat/anomaly_agetooold.cnf | 15 +
.../solve/dimacs/sat/anomaly_agetooold2.cnf | 32 +
src/tests/solve/dimacs/sat/assertion_fail.cnf | 2 +
src/tests/solve/dimacs/sat/fuzzing1.cnf | 17 +
src/tests/solve/dimacs/sat/fuzzing2.cnf | 11 +
src/tests/solve/dimacs/sat/par8-1-c.cnf | 275 +++
src/tests/solve/dimacs/sat/pigeon-2.cnf | 24 +
src/tests/solve/dimacs/sat/pigeon-3.cnf | 37 +
src/tests/solve/dimacs/sat/pigeon-4.cnf | 60 +
src/tests/solve/dimacs/sat/quinn.cnf | 21 +
src/tests/solve/dimacs/sat/simple_v3_c2.cnf | 5 +
.../solve/dimacs/unsat/anomaly_agetooold.cnf | 22 +
src/tests/solve/dimacs/unsat/modus_ponens.cnf | 6 +
src/tests/solve/dimacs/unsat/pigeon-1.cnf | 19 +
src/tests/solve/dimacs/unsat/pigeon-2.cnf | 25 +
src/tests/solve/dimacs/unsat/pigeon-3.cnf | 38 +
src/tests/solve/dimacs/unsat/pigeon-4.cnf | 61 +
.../solve/smt_lra/sat/arith_merge_case_4.smt2 | 14 +
.../solve/smt_lra/sat/arith_zero_dom.smt2 | 11 +
src/tests/solve/smt_uf/sat/bad_conflict.smt2 | 12 +
.../unsat/NEQ004_size4__decide_eq_us.smt2 | 23 +
src/tests/solve/smt_uf/unsat/deltaed0.smt2 | 20 +
.../smt_uf/unsat/diff_to_value_for_bool.smt2 | 20 +
.../smt_uf/unsat/diff_value_substupfalse.smt2 | 14 +
src/tests/solve/smt_uf/unsat/distinct.smt2 | 10 +
src/tests/solve/smt_uf/unsat/eq_diamond2.smt2 | 20 +
.../solve/smt_uf/unsat/equality_norm_set.smt2 | 12 +
.../solve/smt_uf/unsat/many_distinct.smt2 | 37 +
.../unsat/polyeq_genequality_deltaed.smt2 | 13 +
src/tests/solve/smt_uf/unsat/xor.smt2 | 11 +
src/tests/test.ml | 26 +
src/tests/tests.ml | 142 ++
src/tests/tests_LRA.ml | 300 +++
src/tests/tests_bool.ml | 186 ++
src/tests/tests_lib.ml | 68 +
{tests => src/tests}/tests_uf.ml | 94 +-
src/theories/LRA/LRA.ml | 1123 ++++++++++
src/theories/LRA/LRA.mli | 39 +
src/theories/LRA/dune | 13 +
src/theories/LRA/interval.ml | 984 ++++++++
src/theories/LRA/interval.mli | 95 +
src/theories/LRA/interval_sig.ml | 77 +
src/theories/LRA/polynome.ml | 207 ++
src/{arith => theories/LRA}/polynome.mli | 73 +-
src/theories/bool/boolean.ml | 719 ++++++
src/theories/bool/boolean.mli | 62 +
src/theories/bool/dune | 13 +
src/theories/bool/equality.ml | 887 ++++++++
.../bool/equality.mli} | 62 +-
src/theories/bool/uninterp.ml | 246 ++
src/theories/bool/uninterp.mli | 48 +
src/uninterp.ml | 263 ---
src/uninterp.mli | 54 -
src/util/config.ml | 8 -
src/util/extmap.ml | 640 ------
src/util/intmap.ml | 1711 --------------
src/util/pp.mli | 158 --
src/util/rc.mli | 221 --
src/util/rc.mll | 429 ----
src/util/shuffle.mli | 29 -
src/variable.ml | 76 -
src/variable.mli | 39 -
tests/Makefile | 13 +
tests/myutop_main.ml | 59 -
tests/parsing/Axioms/SYN000+0.ax | 37 +
tests/parsing/Axioms/SYN000-0.ax | 34 +
tests/parsing/Axioms/SYN000^0.ax | 46 +
tests/parsing/Axioms/SYN000_0.ax | 47 +
tests/parsing/Axioms/SYN001-0.ax | 1821 +++++++++++++++
tests/parsing/Axioms/SYN002+0.ax | 37 +
tests/parsing/Makefile | 15 +
tests/parsing/SYN000+1.p | 99 +
tests/parsing/SYN000+2.p | 127 ++
tests/parsing/SYN000-1.p | 83 +
tests/parsing/SYN000-2.p | 117 +
tests/parsing/SYN000=2.p | 309 +++
tests/parsing/SYN000^1.p | 192 ++
tests/parsing/SYN000^2.p | 206 ++
tests/parsing/SYN000_1.p | 170 ++
tests/parsing/SYN000_2.p | 135 ++
tests/tests.ml | 124 --
tests/tests_altergo_arith.split | 1972 -----------------
tests/tests_altergo_qualif.split | 1238 -----------
tests/tests_arith.ml | 206 --
tests/tests_arith_uninterp.ml | 40 -
tests/tests_bool.ml | 85 -
tests/tests_bv.ml | 290 ---
tests/tests_lib.ml | 60 -
tests/tests_popop.split | 25 -
tests/tests_utils.ml | 261 ---
witan.opam | 42 +
278 files changed, 22125 insertions(+), 23855 deletions(-)
delete mode 100644 .gitattributes
delete mode 100644 .spcrc
delete mode 100644 INSTALL.adoc
delete mode 100644 README.adoc
create mode 100644 README.md
create mode 100644 TODO
delete mode 100644 _tags
delete mode 100644 api.odocl
create mode 100755 compare_smt2.sh
create mode 100644 dune-project
delete mode 100755 fuzz/compare.sh
delete mode 100755 fuzz/compare_smt2.sh
delete mode 100755 fuzz/fuzzsmt2.sh
delete mode 100755 fuzz/iter_on_commits.sh
delete mode 100755 fuzz/non_terminating_smt2.sh
delete mode 100644 fuzz/search_diff.ml
create mode 100644 misc/headache_config.txt
create mode 100644 misc/header.txt
create mode 100644 misc/header_colibrics.txt
create mode 100644 misc/header_framac.txt
create mode 100644 misc/header_jc.txt
create mode 100644 misc/header_ocaml.txt
create mode 100644 misc/header_why3.txt
create mode 100644 misc/header_witan.txt
delete mode 100644 popop_top.mltop
delete mode 100644 src/arith/arith.ml
delete mode 100644 src/arith/interval.ml
delete mode 100644 src/arith/interval.mli
delete mode 100644 src/arith/polynome.ml
create mode 100644 src/bin/dune
create mode 100644 src/bin/options.ml
create mode 100644 src/bin/options.mli
create mode 100644 src/bin/typecheck.ml
create mode 100644 src/bin/witan.ml
delete mode 100644 src/bool.ml
delete mode 100644 src/bool.mli
delete mode 100644 src/bv.ml
delete mode 100644 src/cmd/popop_cmd.ml
delete mode 100644 src/cmd/popop_dimacs.ml
delete mode 100644 src/cmd/popop_lib.ml
delete mode 100644 src/conflict.ml
delete mode 100644 src/conflict.mli
create mode 100644 src/core/demon.ml
rename src/{ => core}/demon.mli (50%)
create mode 100644 src/core/dune
create mode 100644 src/core/egraph.ml
create mode 100644 src/core/egraph.mli
rename src/{inputlang/smtlib2/popop_of_smtlib2.mli => core/env.ml} (52%)
create mode 100644 src/core/env.mli
create mode 100644 src/core/events.ml
create mode 100644 src/core/events.mli
create mode 100644 src/core/interp.ml
create mode 100644 src/core/interp.mli
create mode 100644 src/core/structures/domKind.ml
create mode 100644 src/core/structures/domKind.mli
create mode 100644 src/core/structures/dune
create mode 100644 src/core/structures/nodes.ml
create mode 100644 src/core/structures/nodes.mli
rename src/{popop.ml => core/structures/term.ml} (58%)
create mode 100644 src/core/structures/ty.ml
rename src/{inputlang/dimacs_cnf/dimacs.mli => core/structures/ty.mli} (57%)
create mode 100644 src/core/theory.ml
create mode 100644 src/core/trail.ml
create mode 100644 src/core/witan_core.ml
delete mode 100644 src/demon.ml
create mode 100644 src/dune
delete mode 100644 src/equality.ml
delete mode 100644 src/equality.mli
delete mode 100644 src/explanation.ml
delete mode 100644 src/explanation.mli
delete mode 100644 src/inputlang/altergo/popop_of_altergo.ml
delete mode 100644 src/inputlang/altergo/symbols.ml
delete mode 100644 src/inputlang/altergo/symbols.mli
delete mode 100644 src/inputlang/altergo/why_lexer.mll
delete mode 100644 src/inputlang/altergo/why_parser.mly
delete mode 100644 src/inputlang/altergo/why_ptree.mli
delete mode 100644 src/inputlang/altergo/why_ty.ml
delete mode 100644 src/inputlang/altergo/why_ty.mli
delete mode 100644 src/inputlang/altergo/why_typing.ml
delete mode 100644 src/inputlang/altergo/why_typing.mli
delete mode 100644 src/inputlang/dimacs_cnf/dimacs.mll
delete mode 100644 src/inputlang/smtlib2/COPYRIGHT
delete mode 100644 src/inputlang/smtlib2/popop_of_smtlib2.ml
delete mode 100644 src/inputlang/smtlib2/smtlib2_ast.ml
delete mode 100644 src/inputlang/smtlib2/smtlib2_lexer.mll
delete mode 100644 src/inputlang/smtlib2/smtlib2_parser.mly
rename src/{util => popop_lib}/IArray.ml (79%)
rename src/{util => popop_lib}/IArray.mli (69%)
rename src/{util => popop_lib}/bag.ml (92%)
rename src/{util => popop_lib}/bag.mli (81%)
rename src/{util => popop_lib}/cmdline.ml (94%)
rename src/{util => popop_lib}/cmdline.mli (93%)
rename src/{util => popop_lib}/debug.ml (55%)
rename src/{util => popop_lib}/debug.mli (75%)
create mode 100644 src/popop_lib/dune
rename src/{util => popop_lib}/enum.ml (80%)
rename src/{util => popop_lib}/enum.mli (68%)
rename src/{util => popop_lib}/exn_printer.ml (89%)
rename src/{util => popop_lib}/exn_printer.mli (88%)
rename src/{util => popop_lib}/exthtbl.ml (95%)
rename src/{util => popop_lib}/exthtbl.mli (88%)
create mode 100644 src/popop_lib/extmap.ml
rename src/{util => popop_lib}/extmap.mli (90%)
rename src/{util => popop_lib}/extset.ml (77%)
rename src/{util => popop_lib}/extset.mli (62%)
rename src/{util => popop_lib}/hashcons.ml (93%)
rename src/{util => popop_lib}/hashcons.mli (96%)
create mode 100644 src/popop_lib/intmap.ml
rename src/{util => popop_lib}/intmap.mli (76%)
rename src/{util => popop_lib}/intmap_hetero.ml (77%)
rename src/{util => popop_lib}/intmap_hetero.mli (82%)
rename src/{util => popop_lib}/leftistheap.ml (79%)
rename src/{util => popop_lib}/leftistheap.mli (81%)
rename src/{util => popop_lib}/lists.ml (98%)
rename src/{util => popop_lib}/lists.mli (98%)
rename src/{util => popop_lib}/loc.ml (95%)
rename src/{util => popop_lib}/loc.mli (96%)
rename src/{util => popop_lib}/map_intf.ml (96%)
rename src/{util => popop_lib}/number.ml (97%)
rename src/{util => popop_lib}/number.mli (95%)
rename src/{util => popop_lib}/opt.ml (87%)
rename src/{util => popop_lib}/opt.mli (91%)
rename src/{util => popop_lib}/plugin.ml (92%)
rename src/{util => popop_lib}/plugin.mli (95%)
rename src/{util/stdlib.ml => popop_lib/popop_stdlib.ml} (64%)
rename src/{util/stdlib.mli => popop_lib/popop_stdlib.mli} (52%)
rename src/{util => popop_lib}/pp.ml (74%)
create mode 100644 src/popop_lib/pp.mli
rename src/{util => popop_lib}/print_tree.ml (94%)
rename src/{util => popop_lib}/print_tree.mli (85%)
rename src/{util => popop_lib}/refo.ml (67%)
rename src/{util => popop_lib}/refo.mli (66%)
rename src/{util => popop_lib}/simple_vector.ml (78%)
rename src/{util => popop_lib}/simple_vector.mli (74%)
rename src/{util => popop_lib}/strings.ml (87%)
rename src/{util => popop_lib}/strings.mli (83%)
rename src/{util => popop_lib}/sysutil.ml (93%)
rename src/{util => popop_lib}/sysutil.mli (97%)
rename src/{util => popop_lib}/unit.ml (90%)
rename src/{util => popop_lib}/unit.mli (66%)
rename src/{util => popop_lib}/util.ml (95%)
rename src/{util => popop_lib}/util.mli (96%)
rename src/{util => popop_lib}/vector_hetero.ml (83%)
rename src/{util => popop_lib}/vector_hetero.mli (80%)
rename src/{util => popop_lib}/warning.ml (91%)
rename src/{util => popop_lib}/warning.mli (93%)
rename src/{util => popop_lib}/weakhtbl.ml (98%)
rename src/{util => popop_lib}/weakhtbl.mli (95%)
delete mode 100644 src/popop_types.ml
delete mode 100644 src/popop_types.mli
delete mode 100644 src/scheduler.ml
delete mode 100644 src/scheduler_queue.ml
delete mode 100644 src/scheduler_queue.mli
delete mode 100644 src/solver.ml
delete mode 100644 src/solver.mli
create mode 100644 src/solver/dune
create mode 100644 src/solver/input.ml
create mode 100644 src/solver/input.mli
create mode 100644 src/solver/notypecheck.ml
create mode 100644 src/solver/notypecheck.mli
create mode 100644 src/solver/scheduler.ml
create mode 100644 src/solver/scheduler.mli
create mode 100644 src/solver/solver.ml
create mode 100644 src/stdlib/comp_keys.ml
create mode 100644 src/stdlib/comp_keys.mli
create mode 100644 src/stdlib/config.ml
create mode 100644 src/stdlib/context.ml
create mode 100644 src/stdlib/context.mli
create mode 100644 src/stdlib/dune
create mode 100644 src/stdlib/hashtbl_hetero.ml
create mode 100644 src/stdlib/hashtbl_hetero.mli
create mode 100644 src/stdlib/hashtbl_hetero_sig.ml
create mode 100644 src/stdlib/keys.ml
rename src/{arith/arith.mli => stdlib/keys.mli} (51%)
create mode 100644 src/stdlib/keys_sig.ml
create mode 100644 src/stdlib/map_hetero.ml
create mode 100644 src/stdlib/map_hetero.mli
create mode 100644 src/stdlib/map_hetero_sig.ml
rename src/{util => stdlib}/shuffle.ml (63%)
create mode 100644 src/stdlib/shuffle.mli
create mode 100644 src/stdlib/std.ml
create mode 100644 src/stdlib/std.mli
create mode 100644 src/stdlib/std_sig.ml
delete mode 100644 src/template.ml
create mode 100644 src/tests/dune
create mode 100644 src/tests/solve/dimacs/sat/anomaly_agetooold.cnf
create mode 100644 src/tests/solve/dimacs/sat/anomaly_agetooold2.cnf
create mode 100644 src/tests/solve/dimacs/sat/assertion_fail.cnf
create mode 100644 src/tests/solve/dimacs/sat/fuzzing1.cnf
create mode 100644 src/tests/solve/dimacs/sat/fuzzing2.cnf
create mode 100644 src/tests/solve/dimacs/sat/par8-1-c.cnf
create mode 100644 src/tests/solve/dimacs/sat/pigeon-2.cnf
create mode 100644 src/tests/solve/dimacs/sat/pigeon-3.cnf
create mode 100644 src/tests/solve/dimacs/sat/pigeon-4.cnf
create mode 100644 src/tests/solve/dimacs/sat/quinn.cnf
create mode 100644 src/tests/solve/dimacs/sat/simple_v3_c2.cnf
create mode 100644 src/tests/solve/dimacs/unsat/anomaly_agetooold.cnf
create mode 100644 src/tests/solve/dimacs/unsat/modus_ponens.cnf
create mode 100644 src/tests/solve/dimacs/unsat/pigeon-1.cnf
create mode 100644 src/tests/solve/dimacs/unsat/pigeon-2.cnf
create mode 100644 src/tests/solve/dimacs/unsat/pigeon-3.cnf
create mode 100644 src/tests/solve/dimacs/unsat/pigeon-4.cnf
create mode 100644 src/tests/solve/smt_lra/sat/arith_merge_case_4.smt2
create mode 100644 src/tests/solve/smt_lra/sat/arith_zero_dom.smt2
create mode 100644 src/tests/solve/smt_uf/sat/bad_conflict.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/NEQ004_size4__decide_eq_us.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/deltaed0.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/diff_to_value_for_bool.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/diff_value_substupfalse.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/distinct.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/eq_diamond2.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/equality_norm_set.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/many_distinct.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/polyeq_genequality_deltaed.smt2
create mode 100644 src/tests/solve/smt_uf/unsat/xor.smt2
create mode 100644 src/tests/test.ml
create mode 100644 src/tests/tests.ml
create mode 100644 src/tests/tests_LRA.ml
create mode 100644 src/tests/tests_bool.ml
create mode 100644 src/tests/tests_lib.ml
rename {tests => src/tests}/tests_uf.ml (64%)
create mode 100644 src/theories/LRA/LRA.ml
create mode 100644 src/theories/LRA/LRA.mli
create mode 100644 src/theories/LRA/dune
create mode 100644 src/theories/LRA/interval.ml
create mode 100644 src/theories/LRA/interval.mli
create mode 100644 src/theories/LRA/interval_sig.ml
create mode 100644 src/theories/LRA/polynome.ml
rename src/{arith => theories/LRA}/polynome.mli (55%)
create mode 100644 src/theories/bool/boolean.ml
create mode 100644 src/theories/bool/boolean.mli
create mode 100644 src/theories/bool/dune
create mode 100644 src/theories/bool/equality.ml
rename src/{inputlang/altergo/popop_of_altergo.mli => theories/bool/equality.mli} (50%)
create mode 100644 src/theories/bool/uninterp.ml
create mode 100644 src/theories/bool/uninterp.mli
delete mode 100644 src/uninterp.ml
delete mode 100644 src/uninterp.mli
delete mode 100644 src/util/config.ml
delete mode 100644 src/util/extmap.ml
delete mode 100644 src/util/intmap.ml
delete mode 100644 src/util/pp.mli
delete mode 100644 src/util/rc.mli
delete mode 100644 src/util/rc.mll
delete mode 100644 src/util/shuffle.mli
delete mode 100644 src/variable.ml
delete mode 100644 src/variable.mli
create mode 100644 tests/Makefile
delete mode 100644 tests/myutop_main.ml
create mode 100644 tests/parsing/Axioms/SYN000+0.ax
create mode 100644 tests/parsing/Axioms/SYN000-0.ax
create mode 100644 tests/parsing/Axioms/SYN000^0.ax
create mode 100644 tests/parsing/Axioms/SYN000_0.ax
create mode 100644 tests/parsing/Axioms/SYN001-0.ax
create mode 100644 tests/parsing/Axioms/SYN002+0.ax
create mode 100644 tests/parsing/Makefile
create mode 100644 tests/parsing/SYN000+1.p
create mode 100644 tests/parsing/SYN000+2.p
create mode 100644 tests/parsing/SYN000-1.p
create mode 100644 tests/parsing/SYN000-2.p
create mode 100644 tests/parsing/SYN000=2.p
create mode 100644 tests/parsing/SYN000^1.p
create mode 100644 tests/parsing/SYN000^2.p
create mode 100644 tests/parsing/SYN000_1.p
create mode 100644 tests/parsing/SYN000_2.p
delete mode 100644 tests/tests.ml
delete mode 100644 tests/tests_altergo_arith.split
delete mode 100644 tests/tests_altergo_qualif.split
delete mode 100644 tests/tests_arith.ml
delete mode 100644 tests/tests_arith_uninterp.ml
delete mode 100644 tests/tests_bool.ml
delete mode 100644 tests/tests_bv.ml
delete mode 100644 tests/tests_lib.ml
delete mode 100644 tests/tests_popop.split
delete mode 100644 tests/tests_utils.ml
create mode 100644 witan.opam
diff --git a/.gitattributes b/.gitattributes
deleted file mode 100644
index b648ebe5a..000000000
--- a/.gitattributes
+++ /dev/null
@@ -1,5 +0,0 @@
-/benchsresult export-ignore
-/benchs export-ignore
-/fuzz
-/doc
-/.gitlab-ci.yml
diff --git a/.gitignore b/.gitignore
index c6376904d..6e8b4c7be 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,33 +1,15 @@
-*.tmp
-*~
-*.bak
-_build
-*.vo
-*.vd
-*.glob
-\#*\#
-*.native
-*.byte
-
-*.aux
-*.pdf
-*.log
-.merlin
+# build directory
+_build/
-*.out
-*.out.[0-9]*
+# executable
+*.exe
-#Old versions kept if wanted
-/popop.*
-#The output of fuzzing
-/errors/
+# jbuild generated files
+*.merlin
-# /src/util/
-/src/util/config.ml
-/src/util/rc.ml
+# test result files
+*.res
-# benchs
-benchs/smtlib/
-/popop_top.top
-/popop*.tar.gz
+# old versions of files
+*~
diff --git a/.spcrc b/.spcrc
deleted file mode 100644
index 9f165ec82..000000000
--- a/.spcrc
+++ /dev/null
@@ -1,7 +0,0 @@
-# HTML COLOR NAME COL A N T STRING or REGULAR EXPRESSION
-#################### ### # # # ################################################################
-Blue blu 1 ^[[:space:]]*(<[0-9]+[.][0-9]*>)
-Red red 1 (\[[a-zA-Z0-9.]+\])
-Green grn u (Make decision: level [0-9]+ \([0-9]+\)|conflict:)
-Green grn u \[[a-zA-Z0-9.]+\] (decide .*$)
-Cyan cya 1 (analyse pexp exp|Done:)
diff --git a/INSTALL.adoc b/INSTALL.adoc
deleted file mode 100644
index d954db091..000000000
--- a/INSTALL.adoc
+++ /dev/null
@@ -1,39 +0,0 @@
-
-== Compilation
-
- With http://opam.ocaml.org/[opam] the needed library can be installed
-
-[source,sh]
-opam install ocamlbuild ocamlfind ounit zarith ocamlgraph cryptokit
-
-
-Then the compilation is done in the directory with:
-
-[source,sh]
-make
-
-It builds the binary `popop.native`
-
-== Tests
-
-The tool can be tested by running
-
-[source,sh]
-make tests
-
-The tests are composed by unit tests, hand written tests and
-delta-debugged bugs. Moreover part of the solver that need to do an
-arbitrary choice are randomized in 10 different ways (using the
-`--seed` argument of `popop.native` and `tests.native``). Example of
-such arbitrary choices are:
-* which class becomes the representative during a merge
-* on which class to do the pivot during the equality of linear arithmetic
- polynomial
-* in which order the arguments of associative and commutative
- operators are parsed and treated.
-
-This fuzzing of the tests allows to exercise more behavior with the
-same number of tests. Often a bug can be found with one seed but will
-avoid a bug when tested with another seed. However we don't use a
-random seed because we want a commit to succeed or fail the tests in a
-deterministic way.
diff --git a/Makefile b/Makefile
index 5b2161db2..41301c8a8 100644
--- a/Makefile
+++ b/Makefile
@@ -1,86 +1,88 @@
-
-
-PACKAGES=oUnit zarith ocamlgraph cryptokit #-package lablgtk2
-# I don't understand warning 18
-OPTIONS=-tag annot -no-sanitize -tag debug -use-ocamlfind -cflags -w,+a-4-9-18-41-44-40-45-42-50 -cflags -warn-error,+5+10+8+12+20+11 -tag strict_sequence -cflag -bin-annot -j 8
-#OPTIONS += -cflags -warn-error,+a
-DIRECTORIES=src src/util src/inputlang/altergo src/inputlang/dimacs_cnf src/inputlang/smtlib2 tests src/cmd src/arith fuzz
-OCAMLBUILD=ocamlbuild \
- $(addprefix -package ,$(PACKAGES)) \
- $(OPTIONS) \
- $(addprefix -I ,$(DIRECTORIES)) \
-
-.PHONY: tests tests.native tests_debug popop.native popop.top
-
-all: popop.native .merlin popop_lib.cma
-
-popop.native tests.native search_diff.native:
- $(OCAMLBUILD) src/cmd/popop_cmd.native tests/tests.native fuzz/search_diff.native src/cmd/popop_lib.cma
- cp popop_cmd.native popop.native
-
-popop_lib.cma:
- $(OCAMLBUILD) src/cmd/popop_lib.cma
-
-byte:
- $(OCAMLBUILD) src/cmd/popop.byte
-
-
-tests: tests.native
- ./tests.native
-
-tests_debug: tests.native
- OCAMLRUNPARAM=b ./tests.native --debug stack_trace
-
-noassert: OPTIONS += -cflag -noassert
-noassert: all tests
-
-.PHONY: doc api dep wc
-
-doc:
- @$(MAKE) -C doc
-
-api:
- $(OCAMLBUILD) api.docdir/index.html
-
-#Because ocamlbuild doesn't give to ocamldoc the .ml when a .mli is present
-dep:
- cd _build; \
- ocamlfind ocamldoc -o dependencies.dot $$(find src -name "*.ml" -or -name "*.mli") \
- $(addprefix -package ,$(PACKAGES)) \
- $(addprefix -I ,$(DIRECTORIES)) \
- -dot -dot-reduce
- sed -i -e "s/ \(size\|ratio\|rotate\|fontsize\).*$$//" _build/dependencies.dot
- dot _build/dependencies.dot -T svg > dependencies.svg
+##########################################################################
+# This file is part of Colibrics. #
+# #
+# Copyright (C) 2017 #
+# CEA (Commissariat à l'énergie atomique et aux énergies #
+# alternatives) #
+# #
+# you can redistribute it and/or modify it under the terms of the GNU #
+# Lesser General Public License as published by the Free Software #
+# Foundation, version 2.1. #
+# #
+# It 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 Lesser General Public License for more details. #
+# #
+# See the GNU Lesser General Public License version 2.1 #
+# for more details (enclosed in the file licenses/LGPLv2.1). #
+##########################################################################
+
+.PHONY: clean build build-dev test test-dev
+
+build:
+ dune build @install
+
+build-install:
+ dune build @install
+
+build-all-supported-version:
+ dune build --workspace jbuild-workspace.dev
clean:
- ocamlbuild -clean
-
-popop_top.top: popop_lib.cma
- ocamlbuild -I tests -use-ocamlfind -tag thread -pkg threads,utop,compiler-libs popop_top.top
-
-WC_UTILS_FILES:= eqtype.ml IArray.ml strings.ml vector_hetero.ml \
- shuffle.ml simple_vector.ml intmap_hetero.ml unit.ml \
-
-WC_FILES:=src/*.ml src/inputlang/altergo/popop_of_altergo.ml \
- $(addprefix src/util/, $(WC_UTILS_FILES)) \
-
-WC_FILES:=$(addsuffix i, $(WC_FILES)) $(WC_FILES)
-
-WC_FILES:= $(WC_FILES) src/cmd/*.ml src/inputlang/dimacs_cnf/*.ml[li]
-
-wc:
- ocamlwc $(WC_FILES)
-
-.merlin: Makefile
- @rm -f .merlin.tmp
- @for PKG in $(PACKAGES); do echo PKG $$PKG >> .merlin.tmp; done
- @for SRC in $(DIRECTORIES); do echo S $$SRC >> .merlin.tmp; done
- @for SRC in $(DIRECTORIES); do echo B _build/$$SRC >> .merlin.tmp; done
- @mv .merlin.tmp .merlin
-
-VERSION=0.1
-
-GIT_TARNAME = popop-$(VERSION)
-archive:
- git archive --format=tar --prefix=$(GIT_TARNAME)/ -o $(GIT_TARNAME).tar HEAD^{tree}
- gzip -f -9 $(GIT_TARNAME).tar
+ dune clean
+ cd tests && $(MAKE) clean
+
+install: build-install
+ dune install
+
+uninstall:
+ dune uninstall
+
+###############
+# file headers
+###############
+
+WHY3_FILES = $(addprefix src/popop_lib/, cmdline.ml cmdline.mli debug.ml \
+ debug.mli exn_printer.ml exn_printer.mli hashcons.ml \
+ hashcons.mli lists.ml lists.mli loc.ml loc.mli number.ml \
+ number.mli opt.ml opt.mli plugin.ml plugin.mli pp.ml pp.mli \
+ print_tree.ml print_tree.mli stdlib.ml stdlib.mli strings.ml \
+ strings.mli sysutil.ml sysutil.mli util.ml util.mli \
+ warning.ml warning.mli weakhtbl.ml weakhtbl.mli )
+
+OCAML_FILES = $(addprefix src/popop_lib/, map_intf.ml exthtbl.ml \
+ exthtbl.mli extmap.ml extmap.mli extset.ml extset.mli )
+
+FRAMAC_FILES = $(addprefix src/popop_lib/, intmap.ml intmap_hetero.ml \
+ intmap.mli intmap_hetero.mli bag.ml bag.mli)
+
+JC_FILES = $(addprefix src/popop_lib/, leftistheap.ml leftistheap.mli)
+
+WITAN_FILES = src/bin/typecheck.ml src/stdlib/std.ml src/stdlib/std.mli \
+ src/stdlib/hashtbl_hetero.ml src/stdlib/hashtbl_hetero.mli \
+ src/stdlib/hashtbl_hetero_sig.ml \
+ src/stdlib/map_hetero.ml src/stdlib/map_hetero.mli \
+ src/stdlib/map_hetero_sig.ml \
+ src/stdlib/keys.mli src/stdlib/keys_sig.ml \
+ src/stdlib/comp_keys.mli src/stdlib/comp_keys.mli
+
+COLIBRICS_FILES = Makefile \
+ $(filter-out $(WHY3_FILES) $(OCAML_FILES) $(FRAMAC_FILES) $(JC_FILES) \
+ , $(wildcard src/*/*/*.ml* src/*/*.ml* src/*.ml*))
+
+headers:
+ headache -c misc/headache_config.txt -h misc/header_colibrics.txt \
+ $(COLIBRICS_FILES)
+ headache -c misc/headache_config.txt -h misc/header_witan.txt \
+ $(WITAN_FILES)
+ headache -c misc/headache_config.txt -h misc/header_why3.txt \
+ $(WHY3_FILES)
+ headache -c misc/headache_config.txt -h misc/header_ocaml.txt \
+ $(OCAML_FILES)
+ headache -c misc/headache_config.txt -h \
+ misc/header_framac.txt $(FRAMAC_FILES)
+ headache -c misc/headache_config.txt -h \
+ misc/header_jc.txt $(JC_FILES)
+
+.PHONY: clean doc all install uninstall remove reinstall test
diff --git a/README.adoc b/README.adoc
deleted file mode 100644
index b2f8c2571..000000000
--- a/README.adoc
+++ /dev/null
@@ -1,26 +0,0 @@
-
-== Popop
-
-Popop is a solver based on an extension of MC-SAT framework developed
-in the SOPRANO ANR project. It proposes an architecture allowing easy
-additions of new domains and theories.
-
-It features parsers for:
-* Dimacs
-* SMTLIB
-* Alt-Ergo language
-
-== Roadmap
-
-Two main parts remain to be done in the implementation of Popop:
-theories and the conflict framework. The current conflict framework is
-functional and very generic however it is quite hard to use, so when
-working on new theories we will have to factorize the boilerplate and
-simplify the API as possible. For the theories the current roadmap is:
-
-* reimplement the rational linear arithmetic theory and extend it
-* finish the implementation of bitvectors on bitvectors operators
-* structures, algebraic datatypes, arrays
-* floating point
-* non-linear rational arithmetics
-* integer linear arithmetic and bitvectors on arithmetic operators
diff --git a/README.md b/README.md
new file mode 100644
index 000000000..3b4b91cfd
--- /dev/null
+++ b/README.md
@@ -0,0 +1,25 @@
+# Colibrics
+
+A prototype implementation of a CP solver for the smtlib. Reimplementation of
+COLIBRICS written in Eclipse Prolog by Bruno Marre
+
+## Installation ##
+
+Using [opam](http://opam.ocaml.org/):
+
+```shell
+opam pin add dolmen https://github.com/Gbury/dolmen.git#1cabe6b20b3b5f32c4dd9704fdb105cd941cd572
+opam pin add colibrics https://git.frama-c.com/bobot/colibrics.git
+```
+
+## Development ##
+
+```shell
+git clone https://git.frama-c.com/bobot/colibrics.git
+opam pin add dolmen https://github.com/Gbury/dolmen.git#1cabe6b20b3b5f32c4dd9704fdb105cd941cd572
+opam pin add --no-action colibrics .
+opam install --deps-only colibrics
+opam install ounit
+make build
+make test
+```
diff --git a/TODO b/TODO
new file mode 100644
index 000000000..ae0024e7c
--- /dev/null
+++ b/TODO
@@ -0,0 +1,6 @@
+- .header file for easy inclusion to new files
+- separate witan into two packages (witan-lib and witan-bin)
+
+
+- naming:
+ Conflict => conflict_element \/ hypothesis
diff --git a/_tags b/_tags
deleted file mode 100644
index 43b28770e..000000000
--- a/_tags
+++ /dev/null
@@ -1 +0,0 @@
-true: -traverse
diff --git a/api.odocl b/api.odocl
deleted file mode 100644
index 4b055200a..000000000
--- a/api.odocl
+++ /dev/null
@@ -1,46 +0,0 @@
-Popop_of_altergo
-Popop
-Popop_dimacs
-Arith
-Scheduler_queue
-Popop_types
-Popop_cmd
-Solver
-Conflict
-Explanation
-Scheduler
-Bool
-Equality
-Dimacs
-Why_ptree
-Why_lexer
-Why_parser
-Symbols
-Leftistheap
-Exn_printer
-Shuffle
-Intmap
-Intmap_hetero
-Vector_hetero
-Extmap
-Opt
-Stdlib
-Hashcons
-Plugin
-Simple_vector
-Number
-Exthtbl
-Strings
-Weakhtbl
-Pp
-Loc
-IArray
-Debug
-Print_tree
-Warning
-Sysutil
-Cmdline
-Lists
-Util
-Uninterp
-Variable
\ No newline at end of file
diff --git a/compare_smt2.sh b/compare_smt2.sh
new file mode 100755
index 000000000..917796462
--- /dev/null
+++ b/compare_smt2.sh
@@ -0,0 +1,32 @@
+#!/bin/dash
+
+#File without check-sat are not acceptable (popop print sat in this case...)
+grep -q "^(check-sat)$" $1 || exit 1
+
+#We want well typed problems
+CVC4=$(cvc4 --lang=smt2 $1 2>&1)
+(echo $CVC4 | grep -q "CVC4 Error:") && exit 1
+
+if [ "$SEED" != "" ]; then
+ SEED="--seed $SEED"
+fi
+
+if [ "$STEP" != "" ]; then
+ STEP="--step $STEP"
+fi
+
+if [ "$INVSTATUS" != "" ]; then
+ OK=0
+ BAD=1
+else
+ #for deltasmt
+ OK=1
+ BAD=0
+fi
+
+
+if test "$CVC4" = "$(_build/default/src/bin/witan.exe $SEED $STEP --input=smt2 $1 2>&1)"; then
+ exit $OK
+else
+ exit $BAD
+fi
diff --git a/dune-project b/dune-project
new file mode 100644
index 000000000..51d5c322e
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,5 @@
+(lang dune 2.0)
+
+(name witan)
+
+(formatting disabled)
diff --git a/fuzz/compare.sh b/fuzz/compare.sh
deleted file mode 100755
index d3f4d93da..000000000
--- a/fuzz/compare.sh
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/bin/dash
-
-(minisat $3 | grep -q "$1") && (./popop.native --dimacs $3 2>&1 | grep -q "$2") && exit 42
-exit 13
\ No newline at end of file
diff --git a/fuzz/compare_smt2.sh b/fuzz/compare_smt2.sh
deleted file mode 100755
index 74119bc85..000000000
--- a/fuzz/compare_smt2.sh
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/bin/dash
-
-#File without check-sat are not acceptable (popop print sat in this case...)
-grep -q "^(check-sat)$q" $1 || exit 1
-
-#We want well typed problems
-CVC4=$(cvc4 --lang=smt2 $1 2>&1)
-(echo $CVC4 | grep -q "CVC4 Error:") && exit 1
-
-if test "$CVC4" = "$(./popop.native --lang smtlib2 $1 2>&1)"; then
- exit 1
-else
- exit 0
-fi
\ No newline at end of file
diff --git a/fuzz/fuzzsmt2.sh b/fuzz/fuzzsmt2.sh
deleted file mode 100755
index ac9b1c7d2..000000000
--- a/fuzz/fuzzsmt2.sh
+++ /dev/null
@@ -1,24 +0,0 @@
-#!/bin/sh
-
-#DELTABIN=../ddsmt/ddsmt.py
-DELTABIN=../deltasmtV2/deltasmt
-
-FILEFUZZED=$(tempfile --prefix fuzz --suffix .smt2)
-FILEDELTA=$(tempfile --prefix delta --suffix .smt2)
-mkdir -p errors/
-
-while true; do
- ../fuzzsmt-0.2/fuzzsmt "$@" | grep -v "^(set-info" | sed -e "s/<=\|>=/=/g" -e "s/(< \|(> /(= /g" -e "so/ o* og" > $FILEFUZZED
-
- while test "$(cvc4 $FILEFUZZED)" = "$(./popop.native $FILEFUZZED)"; do
- echo -n ".";
- ../fuzzsmt-0.2/fuzzsmt "$@" | grep -v "^(set-info" | sed -e "s/<=\|>=/=/g" -e "s/(< \|(> /(= /g" -e "so/ o* og" > $FILEFUZZED
- done
- echo "!"
- rm -f $FILEDELTA
- $DELTABIN -v $FILEFUZZED $FILEDELTA fuzz/compare_smt2.sh
-
- cp $FILEDELTA $(tempfile -d errors/ --prefix fuzz --suffix .smt2)
-done
-
-
diff --git a/fuzz/iter_on_commits.sh b/fuzz/iter_on_commits.sh
deleted file mode 100755
index bf57c913c..000000000
--- a/fuzz/iter_on_commits.sh
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-
-COMMITS=$1
-CMD=$2
-shift 2
-
-for commit in $FIRSTCOMMIT $(git rev-list $COMMITS); do
- echo do $commit
- git checkout $commit > /dev/null 2>&1
- (make tests > /dev/null 2>&1) || (echo "don't compile or test" && continue)
- $CMD "$@"
-done
\ No newline at end of file
diff --git a/fuzz/non_terminating_smt2.sh b/fuzz/non_terminating_smt2.sh
deleted file mode 100755
index 9e0185c26..000000000
--- a/fuzz/non_terminating_smt2.sh
+++ /dev/null
@@ -1,24 +0,0 @@
-#!/bin/dash
-
-#File without check-sat are not acceptable (popop print sat in this case...)
-grep -q "^(check-sat)$q" $1 || exit 1
-
-#We want well typed problems
-CVC4=$(cvc4 --lang=smt2 --parse-only $1 2>&1)
-(echo $CVC4 | grep -q "CVC4 Error:") && exit 1
-
-CVC4=$(why3-cpulimit 2 1000 -h cvc4 --lang=smt2 --parse-only $1 2>&1)
-CVC4_N=$?
-
-if test "$CVC4_N" = "2"; then
- exit 1
-fi
-
-POPOP=$(why3-cpulimit 20 1000 -h ./popop.native --lang smtlib2 $1 2>&1)
-POPOP_N=$?
-
-if test "$POPOP_N" != "2"; then
- exit 1
-else
- exit 0
-fi
\ No newline at end of file
diff --git a/fuzz/search_diff.ml b/fuzz/search_diff.ml
deleted file mode 100644
index 23a89d3d5..000000000
--- a/fuzz/search_diff.ml
+++ /dev/null
@@ -1,67 +0,0 @@
-
-
-let rec new_problem f =
- let filename,cout = Filename.open_temp_file "search_diff" ".cnf" in
- let fd = Unix.descr_of_out_channel cout in
- let pid = Unix.create_process "fuzzsat" Sys.argv Unix.stdin fd fd in
- let pid', status = Unix.wait () in
- assert (pid = pid');
- match status with
- | Unix.WEXITED 0 ->
- f filename;
- close_out cout;
- Sys.remove filename
- | _ ->
- Format.printf "Error in fuzzsat:@.%t@."
- (Sysutil.file_contents_fmt filename);
- close_out cout;
- Sys.remove filename;
- new_problem f
-
-
-let sat_for_minisat filename =
- let cmd =
- Printf.sprintf "minisat %s | grep -q \"^SATISFIABLE\"" filename in
- Sys.command cmd = 0
-
-type result = Error | Result of bool
-
-let sat_for_popop filename =
- let error,cout = Filename.open_temp_file "popop" ".out" in
- let fd = Unix.descr_of_out_channel cout in
- let pid = Unix.create_process "./popop.native" [|"./popop.native";filename|]
- Unix.stdin fd fd in
- let pid', _status = Unix.wait () in
- assert (pid = pid');
- let cmd = Printf.sprintf "grep -q \"anomaly\" %s" error in
- if Sys.command cmd = 0 then
- begin
- Format.printf "Error in popop:@.%t@."
- (Sysutil.file_contents_fmt error);
- close_out cout;
- Sys.remove error;
- Error
- end
- else let cmd = Printf.sprintf "grep -q \"^Sat\" %s" error in
- let r = (Sys.command cmd = 0) in
- close_out cout;
- Sys.remove error;
- Result r
-
-let feedback reason filename =
- let basename = Filename.basename filename in
- Sysutil.backup_file basename;
- Sysutil.copy_file filename basename;
- Printf.printf "%s on %s\n%!" reason basename
-
-let rec run () =
- new_problem (fun filename ->
- match sat_for_minisat filename, sat_for_popop filename with
- | _, Error -> feedback "anomaly" filename
- | b1, Result b2 when b1 <> b2 -> feedback "different" filename;
- Printf.printf "minisat sat:%b popop sat:%b\n%!" b1 b2;
- ignore (Sys.command (Printf.sprintf "wc -l %s" filename))
- | _ -> Printf.printf ".%!");
- run ()
-
-let () = run ()
diff --git a/misc/headache_config.txt b/misc/headache_config.txt
new file mode 100644
index 000000000..01cba0886
--- /dev/null
+++ b/misc/headache_config.txt
@@ -0,0 +1,16 @@
+# no header
+| "META.in" -> no
+| "extmap.ml[i]?" -> no
+| "literals.mll" -> no
+# Objective Caml source
+| ".*\\.ml[il4]?" -> frame width:62 open:"(*" line:"*" close:"*)"
+| ".*\\.ml[il4]?\\.in" -> frame width:62 open:"(*" line:"*" close:"*)"
+| ".*\\.mly" -> frame width:62 open:"(*" line:"*" close:"*)"
+# Coq source
+| ".*\\.v" -> frame width:62 open:"(*" line:"*" close:"*)"
+# C source
+| ".*\\.c" -> frame width:62 open:"/*" line:"*" close:"*/"
+# Misc
+| "configure.in" -> frame width:62 open:"#" line:"#" close:"#"
+| "Makefile.in" -> frame width:62 open:"#" line:"#" close:"#"
+| "README" -> frame width:62 open:"#" line:"#" close:"#"
diff --git a/misc/header.txt b/misc/header.txt
new file mode 100644
index 000000000..1bfa61664
--- /dev/null
+++ b/misc/header.txt
@@ -0,0 +1,20 @@
+This file is part of Witan.
+
+Copyright (C) 2017
+ CEA (Commissariat à l'énergie atomique et aux énergies
+ alternatives)
+ INRIA (Institut National de Recherche en Informatique et en
+ Automatique)
+ CNRS (Centre national de la recherche scientifique)
+
+you can redistribute it and/or modify it under the terms of the GNU
+Lesser General Public License as published by the Free Software
+Foundation, version 2.1.
+
+It 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 Lesser General Public License for more details.
+
+See the GNU Lesser General Public License version 2.1
+for more details (enclosed in the file licenses/LGPLv2.1).
diff --git a/misc/header_colibrics.txt b/misc/header_colibrics.txt
new file mode 100644
index 000000000..7c2e78960
--- /dev/null
+++ b/misc/header_colibrics.txt
@@ -0,0 +1,17 @@
+This file is part of Colibrics.
+
+Copyright (C) 2017
+ CEA (Commissariat à l'énergie atomique et aux énergies
+ alternatives)
+
+you can redistribute it and/or modify it under the terms of the GNU
+Lesser General Public License as published by the Free Software
+Foundation, version 2.1.
+
+It 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 Lesser General Public License for more details.
+
+See the GNU Lesser General Public License version 2.1
+for more details (enclosed in the file licenses/LGPLv2.1).
diff --git a/misc/header_framac.txt b/misc/header_framac.txt
new file mode 100644
index 000000000..f153eca74
--- /dev/null
+++ b/misc/header_framac.txt
@@ -0,0 +1,19 @@
+
+This file is part of Frama-C.
+
+Copyright (C) 2007-2017
+ CEA (Commissariat à l'énergie atomique et aux énergies
+ alternatives)
+
+you can redistribute it and/or modify it under the terms of the GNU
+Lesser General Public License as published by the Free Software
+Foundation, version 2.1.
+
+It 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 Lesser General Public License for more details.
+
+See the GNU Lesser General Public License version 2.1
+for more details (enclosed in the file licenses/LGPLv2.1).
+
diff --git a/misc/header_jc.txt b/misc/header_jc.txt
new file mode 100644
index 000000000..9fcc11275
--- /dev/null
+++ b/misc/header_jc.txt
@@ -0,0 +1,10 @@
+Copyright (C) Jean-Christophe Filliatre
+
+This software is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public
+License version 2.1, with the special exception on linking
+described in file LICENSE.
+
+This software 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.
diff --git a/misc/header_ocaml.txt b/misc/header_ocaml.txt
new file mode 100644
index 000000000..fb03d47b8
--- /dev/null
+++ b/misc/header_ocaml.txt
@@ -0,0 +1,10 @@
+ OCaml
+
+ Xavier Leroy, projet Cristal, INRIA Rocquencourt
+
+Copyright 1996 Institut National de Recherche en Informatique et
+ en Automatique.
+
+All rights reserved. This file is distributed under the terms of
+the GNU Lesser General Public License version 2.1, with the
+special exception on linking described in the file LICENSE.
diff --git a/misc/header_why3.txt b/misc/header_why3.txt
new file mode 100644
index 000000000..04f4e9162
--- /dev/null
+++ b/misc/header_why3.txt
@@ -0,0 +1,8 @@
+
+The Why3 Verification Platform / The Why3 Development Team
+Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University
+
+This software is distributed under the terms of the GNU Lesser
+General Public License version 2.1, with the special exception
+on linking described in file LICENSE.
+
diff --git a/misc/header_witan.txt b/misc/header_witan.txt
new file mode 100644
index 000000000..1bfa61664
--- /dev/null
+++ b/misc/header_witan.txt
@@ -0,0 +1,20 @@
+This file is part of Witan.
+
+Copyright (C) 2017
+ CEA (Commissariat à l'énergie atomique et aux énergies
+ alternatives)
+ INRIA (Institut National de Recherche en Informatique et en
+ Automatique)
+ CNRS (Centre national de la recherche scientifique)
+
+you can redistribute it and/or modify it under the terms of the GNU
+Lesser General Public License as published by the Free Software
+Foundation, version 2.1.
+
+It 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 Lesser General Public License for more details.
+
+See the GNU Lesser General Public License version 2.1
+for more details (enclosed in the file licenses/LGPLv2.1).
diff --git a/popop_top.mltop b/popop_top.mltop
deleted file mode 100644
index 026b0f5c5..000000000
--- a/popop_top.mltop
+++ /dev/null
@@ -1 +0,0 @@
-Myutop_main
\ No newline at end of file
diff --git a/src/arith/arith.ml b/src/arith/arith.ml
deleted file mode 100644
index ad8ddaef3..000000000
--- a/src/arith/arith.ml
+++ /dev/null
@@ -1,1129 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-(** Linear Arithmetique *)
-
-(**
- This module use one domain and one semantic value.
- They are both polynomes, but the domain can be reduced to a class
- (p = 1 * cl + 0) but the semantic value can't.
-*)
-open Popop
-open Stdlib
-open Types
-open Solver
-
-let debug = Debug.register_info_flag
- ~desc:"for the arithmetic theory"
- "arith"
-
-let debug_todo = debug
-
-
-open Polynome
-let dom_invariant = Polynome.invariant
-let sem_invariant p = Polynome.is_one_cl p == None && dom_invariant p
-
-
-let sem : t sem = Sem.create_key "SARITH"
-let dom : t dom = Dom.create_key "ARITH"
-let real_ctr = Ty.Constr.create "Real"
-let real = Ty.ctr real_ctr
-
-let minus_or_one inv =
- if inv then Q.minus_one else Q.one
-
-let sub_cl cl p =
- x_p_cy (monome Q.one cl) Q.minus_one p
-
-(** cl1 -> cl2 *)
-let dist cl1 cl2 =
- add (monome Q.one cl1) (monome Q.minus_one cl2)
-
-(** Real summary
- merge cl1 cl2 -> cl1 - cl2 = 0
- set_sem cl1 sem v -> cl1 - v = 0
- dist cl1 cl2 -> cl1 - cl2 = 0
-*)
-
-(** A merge gives two thing, a knowledge for the pivot
- and a knowledge for the two classes merged *)
-(*
-type expkind =
-| ExpSolve of pexp * Q.t * Cl.t option * Cl.t option
-(** pexp, div, cl_o, cl_r
-
-
- Since when P, P_o, P_r have been decided cl_r = cl_o, then
- dom(cl_r) = dom(cl_o) and we propagated for the pivot q that
- (dom(cl_r) - dom(cl_o) - div q)/div = q
-
- (q is a pivot, coef_o * q \in dom(cl_o) and coef_r * q \in dom(cl_r)
- div = coef_o + coef_r <> 0 but coef_o or coef_r can be null)
-
- With the following explications:
- pexp -> +- P + cl_r = cl_o
- cl_r -> P_r + dom(cl_r) = cl_r
- cl_o -> P_o + dom(cl_o) = cl_o
-
- the explication of this propagation is: (+- P + P_r - P_o)/div
- because
- (+- P + P_r - P_o)/div + (dom(cl_r) - dom(cl_o) - div q)/div = q
-
- +- depend on the non-deterministic choice of the solver for the equivalence
- class for cl_r and cl_o.
-*)
-*)
-type expequality =
-(* | ExpSem of expkind * Cl.t *)
-(* (\** ExpSem (exp,q): propagate a sem: exp = q *\) *)
-(* | ExpCl of expkind * Cl.t * Cl.t *)
-(* (\** ExpCl (exp,p,q): propagate a merge: exp + p = q *\) *)
-(* | ExpSubst of Cl.t * norm *)
-| ExpCombi of int * t * combi (** int only used for debug *)
-(** All the class have been simplified
- remains a constant different than zero *)
-| ExpCstDiff of Q.t * combi
-| ExpMult of Q.t (**p**) * Cl.t (**g**) * Cl.t (**f**) * Cl.t (**own**)
- (** p = g -> g*f = p*f **)
-
-(** linear combination *)
-and combi =
-| CombiRepr of Q.t * Cl.t * combi
-| CombiDom of Q.t * Cl.t * combi
-| CombiSem of Q.t * t * combi
-| CombiPexp of Q.t * t * Explanation.pexp * combi
-| CombiNull
-
-let rec iter_combi f = function
- | CombiNull -> ()
- | CombiRepr (_,_,n)
- | CombiDom (_,_,n) | CombiPexp (_,_,_,n)
- | CombiSem (_,_,n) as c ->
- f c; iter_combi f n
-
-let rec mult_combi m = function
- | CombiNull -> CombiNull
- | CombiRepr (q,a1,n) -> CombiRepr(Q.mul m q,a1,mult_combi m n)
- | CombiDom (q,a1,n) -> CombiDom(Q.mul m q,a1,mult_combi m n)
- | CombiPexp (q,th,a1,n) ->
- CombiPexp(Q.mul m q,th,a1,mult_combi m n)
- | CombiSem (q,a1,n) -> CombiSem(Q.mul m q,a1,mult_combi m n)
-
-(** Substitution daemon *)
-
-module T = struct
- include Polynome
- let key = sem
-end
-
-module ThE = RegisterSem(T)
-
-let propa_dem = Demon.Key.create "Arith.DaemonPropa"
-
-let expequality : expequality Explanation.exp =
- Explanation.Exp.create_key "Arith.equality"
-
-let print_bag_cl = Bag.print Pp.comma Cl.print
-
-let attach d clsem b1 =
- Debug.dprintf4 debug "[Arith] @[attach@ %a@ for@ %a@]@\n"
- ThE.print clsem print_bag_cl b1;
- let open Demon.Key in
- match is_attached d propa_dem clsem with
- | SDead | SRedirected _ ->
- Debug.dprintf2 debug "[Arith] @[Dead or redirected! of %a@]@\n"
- ThE.print clsem;
- assert false (** absurd: it was considered not
- useful anymore it can't be needed now *)
- | SAlive b2 ->
- Demon.Key.set_info d propa_dem clsem (Bag.concat b1 b2)
- | SUnborn ->
- Debug.dprintf2 debug "[Arith] @[attach propagation of %a@]@\n"
- ThE.print clsem;
- let events = Polynome.fold (fun acc cl _ ->
- Demon.Create.EventDom(cl,dom,cl)::
- begin if Delayed.get_dom d dom cl == None
- then Demon.Create.EventChange(cl,cl)::acc
- else acc
- end
- ) [] (ThE.sem clsem) in
- Demon.Key.attach d propa_dem clsem events;
- Demon.Key.set_info d propa_dem clsem b1
-
-module Th = struct
- include T
-
- let merged v1 v2 =
- match v1,v2 with
- | None, None -> true
- | Some v', Some v -> T.equal v' v
- | _ -> false
-
- type 'a normalizeResult =
- | NormalizeTo of Cl.t
- | NormalizeToSem of 'a
-
- let norm x =
- match is_one_cl x with
- | None -> NormalizeToSem x
- | Some cl -> NormalizeTo cl
-
- let subst_sp pi x = function
- | NormalizeTo y ->
- subst_cl pi x y
- | NormalizeToSem s ->
- subst pi x s
-
- let normalize d v =
- Polynome.fold
- (fun (norm,p) x _ ->
- let x' = Delayed.find_def d x in
- match Delayed.get_dom d dom x' with
- | None when Cl.equal x x' -> norm,p
- | None -> let p,q = subst_cl p x x' in
- (if Q.equal q Q.zero then norm else CombiRepr(q,x,norm)), p
- | Some s -> let p,q = subst p x s in
- (if Q.equal q Q.zero then norm else CombiDom(q,x,norm)), p)
- (CombiNull,v) v
-
- let filter_to_update d cls =
- (** filter out the classes that are the same can append because
- two classes wainting for their merge have the same dom, and
- this dom can be be exactly the same so no merge happend for
- this dom at the end *)
- if Bag.is_num_elt 1 cls then cls
- else
- let m = Bag.fold_left
- (fun m cl -> Cl.M.add (Delayed.find d cl) cl m) Cl.M.empty cls in
- Bag.list (Cl.M.values m)
-
- (* let equal_sr sr1 sr2 = *)
- (* match sr1, sr2 with *)
- (* | NormalizeTo cl1, NormalizeTo cl2 -> Cl.equal cl1 cl2 *)
- (* | NormalizeToSem p1, NormalizeToSem p2 -> equal p1 p2 *)
- (* | _ -> false *)
-
- (** combi: q*x + p' = 0 *)
- let apply_pivot d combi q x p' =
- (** sr = (-1/q) * p' *)
- let iq = Q.inv q in
- let miq = Q.neg iq in
- let s = mult_cst miq p' in
- let sr = norm s in
- let expkind = mult_combi miq combi in
- let miq_p' = mult_cst miq p' in
- let mx = monome Q.one x in
- let clsemmx = ThE.index mx real in
- let cls,nodom =
- match Demon.Key.is_attached d propa_dem clsemmx with
- | SDead | SRedirected _ ->
- assert false (** absurd: it was considered not
- useful anymore it can't be needed now *)
- | SAlive b ->
- Debug.dprintf2 debug "@[b = %a@]@\n" print_bag_cl b;
- assert (Bag.exists (fun y -> Delayed.is_equal d x y) b);
- b, false
- | SUnborn -> Bag.elt x, true
- in
- let cls = filter_to_update d cls in
- Demon.Key.kill d propa_dem clsemmx;
- let age = Delayed.current_age d in
- let pexp own =
- if nodom
- then begin
- assert (Cl.equal own x);
- Delayed.mk_pexp ~age d expequality
- (ExpCombi(1,sub_cl own miq_p',expkind))
- end
- else
- Delayed.mk_pexp ~age d expequality
- (ExpCombi(15,sub_cl own miq_p',CombiDom(Q.one,own,expkind)))
- in
- begin match sr with
- | NormalizeTo y ->
- Debug.dprintf6 debug
- "[Arith] @[merge q=%a x=%a@, y=%a@]@\n"
- Q.pp_print q Cl.print x Cl.print y;
- Delayed.merge d (pexp x) x y;
- let subst = monome Q.one y in
- let clsemsubst = ThE.index subst real in
- let iter own =
- let pexp = pexp own in
- Delayed.set_dom d pexp dom own subst;
- in
- Bag.iter iter cls;
- let cls =
- match Delayed.get_dom d dom y with
- | None ->
- let combinull = Delayed.mk_pexp d expequality
- (ExpCombi(3,Polynome.zero,CombiNull)) in
- Delayed.set_dom d combinull dom y subst;
- Bag.add y cls
- | Some s' ->
- assert (T.equal subst s');
- cls
- in
- attach d clsemsubst cls
- | NormalizeToSem subst ->
- Debug.dprintf6 debug
- "[Arith] @[set_sem q=%a x=%a@, s=%a@]@\n"
- Q.pp_print q Cl.print x print subst;
- let clsemsubst = ThE.index subst real in
- let iter own =
- let pexp = pexp own in
- Delayed.set_dom d pexp dom own subst
- in
- Bag.iter iter cls;
- let clsem = ThE.clsem (ThE.index subst real) in
- Delayed.set_sem d (pexp x) x clsem;
- attach d clsemsubst cls
- end
-
-
- (** p = p1 - p2 *)
- let solve_aux d combi p =
- match Polynome.extract p with
- | Zero -> () (** nothing to do already equal *)
- | Cst q ->
- let pexp = Delayed.mk_pexp d expequality
- (ExpCstDiff(q, combi)) in
- Delayed.contradiction d pexp
- | Var(q,x,p') ->
- (** p = qx + p' *)
- assert ( not (Q.equal Q.zero q) );
- Debug.dprintf2 debug "[Arith] @[solve p=%a@]@\n" print p;
- apply_pivot d combi q x p'
-
- let norm_dom d cl = function
- | None ->
- let r = Delayed.find d cl in
- let r = monome Q.one r in
- let clsemr = ThE.index r real in
- let pexp = Delayed.mk_pexp d expequality
- (ExpCombi(2,sub_cl cl r,
- CombiRepr(Q.one,cl,CombiNull))) in
- Delayed.set_dom d pexp dom cl r;
- attach d clsemr (Bag.elt cl);
- r
- | Some p ->
- p
-
-
- let merge d pexp_merge (p1o,cl1) (p2o,cl2) _ =
- assert (not (Delayed.is_equal d cl1 cl2));
- assert (not (p1o == None && p2o == None));
- let p1 = norm_dom d cl1 p1o in
- let p2 = norm_dom d cl2 p2o in
- let dist = dist cl1 cl2 in (* pexp *)
- let diff,diff_pexp = sub p1 p2,
- CombiPexp(Q.minus_one,dist, pexp_merge,
- CombiDom(Q.one,cl1,
- CombiDom(Q.minus_one,cl2,
- CombiNull))) in
- solve_aux d diff_pexp diff
-
- let merge_itself d combi cl1 p1 =
-
- let p2o = Delayed.get_dom d dom cl1 in
- match p2o with
- | Some p2 when equal p1 p2 -> ()
- | _ ->
- let p2 = norm_dom d cl1 p2o in
- let pexp = CombiDom(Q.minus_one,cl1,combi) in
- let diff,diff_pexp = sub p1 p2, pexp in
- solve_aux d diff_pexp diff
-
-
-end
-
-module D = RegisterDom(struct include Th let key = dom end)
-
-let embed t cl =
- match Delayed.get_dom t dom cl with
- | None -> monome Q.one cl
- | Some r -> r
-
-module DaemonPropa = struct
- let key = propa_dem
-
- module Key = ThE
- module Data = Cl
- type info = Cl.t Bag.t let default = Bag.empty
-
- let immediate = true
- let wakeup d clsem ev cls =
- let v = ThE.sem clsem in
- let cls = Th.filter_to_update d cls in
- let norm, v' = List.fold_left (fun acc ev ->
- let f (norm,p) x =
- match Delayed.get_dom d dom x with
- | None ->
- let x' = Delayed.find d x in
- let p,q = subst_cl p x x' in
- (if Q.equal Q.zero q then norm else CombiRepr(q,x,norm)), p
- | Some v ->
- let p,q = subst p x v in
- (if Q.equal Q.zero q
- then norm
- else CombiDom(q,x,norm)), p
- in
- match ev with
- | Events.Fired.EventChange(_,cl) ->
- Debug.dprintf4 debug "Cl: x:%a p:%a@\n"
- Cl.print cl Th.print (snd acc);
- f acc cl
- | Events.Fired.EventDom(_,dom',cl) ->
- Debug.dprintf4 debug "Dom: x:%a p:%a@\n"
- Cl.print cl Th.print (snd acc);
- assert (Dom.equal dom dom');
- f acc cl
- | _ -> raise UnwaitedEvent
- ) (CombiNull,v) ev in
- Debug.dprintf4 debug "[Arith] @[subst %a@ into %a@]@\n"
- Th.print v Th.print v';
- assert (Th.equal v' (snd (Th.normalize d v)));
- let clsem' = ThE.index v' real in
- if ThE.equal clsem' clsem then Demon.AliveReattached
- else
- let pexp own =
- Delayed.mk_pexp d expequality
- (ExpCombi(8,sub_cl own v',
- (CombiDom(Q.one,own,norm)))) in
- begin match Th.norm v' with
- | Th.NormalizeTo y ->
- let iter own =
- let pexp = pexp own in
- Delayed.set_dom d pexp dom own v';
- Delayed.merge d pexp own y
- in
- Bag.iter iter cls;
- attach d clsem' (Bag.add y cls)
- | Th.NormalizeToSem s ->
- let clsem = ThE.clsem (ThE.index s real) in
- let iter own =
- let pexp = pexp own in
- Delayed.set_dom d pexp dom own s;
- Delayed.set_sem d pexp own clsem
- in
- Bag.iter iter cls;
- attach d clsem' cls
- end;
- Demon.AliveStopped
-end
-
-module RDaemonPropa = Demon.Key.Register(DaemonPropa)
-
-module DaemonInit = struct
- let key = Demon.Key.create "Arith.DaemonInit"
-
- module Key = DUnit
- module Data = DUnit
- type info = unit let default = ()
-
- let immediate = false
-
- let wakeup d () ev () =
- List.iter
- (function Events.Fired.EventRegSem(clsem,()) ->
- begin
- let clsem = ThE.coerce_clsem clsem in
- let v = ThE.sem clsem in
- let own0 = ThE.cl clsem in
- match Demon.Key.is_attached d DaemonPropa.key clsem with
- | SDead | SAlive _ | SRedirected _ -> ()
- | SUnborn ->
- assert (sem_invariant v);
- Polynome.iter (fun x _ -> Delayed.register d x) v;
- let norm,v' = Th.normalize d v in
- let norm = CombiSem(Q.one,v,norm) in
- Debug.dprintf4 debug "[Arith] @[normalize %a@ into %a@]@\n"
- Th.print v Th.print v';
- Th.merge_itself d norm own0 v'
- end;
- Delayed.flush d;
- | _ -> raise UnwaitedEvent
- ) ev;
- Demon.AliveReattached
-
-end
-
-module RDaemonInit = Demon.Key.Register(DaemonInit)
-
-(** For the multiplication *)
-type mul = Mul of Cl.t * Cl.t
-let make_mul f g = if Cl.compare f g > 0 then Mul(f,g) else Mul(g,f)
-
-let mul_sem : mul sem = Sem.create_key "Arith.(*)"
-
-type expmulsubst = mul
-let expmulsubst : expmulsubst Explanation.exp =
- Explanation.Exp.create_key "Arith.(*)"
-
-
-module Mul = struct
- module T = struct
- type t = mul
- let equal n m =
- match n, m with
- | Mul (g1,f1), Mul(g2,f2) -> Cl.equal g1 g2 && Cl.equal f1 f2
-
- let hash n =
- match n with
- | Mul(g,f) -> 3 * (Cl.hash g) + 5 * (Cl.hash f)
-
- let compare n m =
- match n, m with
- | Mul(g1,f1), Mul(g2,f2) ->
- let c = Cl.compare g1 g2 in
- if c <> 0 then c
- else Cl.compare f1 f2
-
- let print fmt v =
- match v with
- | Mul (f,g) -> Format.fprintf fmt "(@[%a@] * @[%a@])"
- Cl.print f Cl.print g
-
- end
-
- include MkDatatype(T)
-
- let key = mul_sem
-
- let cl_ord f g = if Cl.compare f g > 0 then f,g else g,f
-end
-
-module MulE = RegisterSem(Mul)
-
-
-let norm_mul d own = function
- | Mul(f0,g0) as v ->
- let f = Delayed.find d f0 in
- let g = Delayed.find d g0 in
- let res = match Opt.bind is_cst (Delayed.get_dom d dom f) with
- | Some q ->
- Some (monome q g0, ExpMult(q,f0,g0,own))
- | _ ->
- match Opt.bind is_cst (Delayed.get_dom d dom g) with
- | Some q ->
- Some (monome q f0, ExpMult(q,g0,f0,own))
- | _ -> None in
- match res with
- | None when Cl.equal f f0 && Cl.equal g g0 ->
- Demon.AliveReattached
- | None (** congruence closure *) ->
- let pexp = Delayed.mk_pexp d expmulsubst v in
- let f,g = Mul.cl_ord f g in
- let clsem = MulE.clsem (MulE.index (Mul(f,g)) real) in
- Delayed.set_sem d pexp own clsem;
- Demon.AliveStopped
- | Some (r,exp) ->
- let pexp = Delayed.mk_pexp d expequality exp in
- begin match Th.norm r with
- | Th.NormalizeTo y ->
- Delayed.merge d pexp own y
- | Th.NormalizeToSem s ->
- let clsem = ThE.clsem (ThE.index s real) in
- Delayed.set_sem d pexp own clsem
- end;
- Demon.AliveStopped
-
-
-
-module DaemonMultPropa = struct
- let key = Demon.Key.create "Uninterp.DaemonMultPropa"
-
- module Key = Mul
- module Data = DUnit
- type info = unit let default = ()
-
- let immediate = false
- let wakeup d v _ev () =
- let own = Cl.index mul_sem v real in
- Debug.dprintf4 debug "[Uninterp] @[wakeup own %a v:%a@]@\n"
- Cl.print own Mul.print v;
- norm_mul d own v
-end
-
-module RDaemonMultPropa = Demon.Key.Register(DaemonMultPropa)
-
-module DaemonMultInit = struct
- type k = unit
- type d = unit
- let key = Demon.Key.create "Uninterp.DaemonMultInit"
-
- module Key = DUnit
- module Data = DUnit
- type info = unit let default = ()
-
- let immediate = false
-
-(*
- let _close_assoc d x y own =
- let use = Delayed.are_waiting_cl_change d x DaemonMultPropa.key in
- List.iter (fun ((Mul(z1,z2) as m),()) ->
- match Delayed.is_sem_present d mul_sem m with
- | None -> assert false
- | Some other ->
- let z = if Cl.equal z1 x then z2 else (assert (Cl.equal x z2); z1) in
- let newcl = Delayed.index d mul_sem (make_mul other y) in
- Delayed.register d newcl;
- Delayed.set_sem d mul_sem newcl (make_mul own z);
- ) use
-*)
-
- let wakeup d () ev () =
- List.iter
- (function Events.Fired.EventRegSem(clsem,()) ->
- begin
- let clsem = MulE.coerce_clsem clsem in
- let v = MulE.sem clsem in
- let own = MulE.cl clsem in
- match v with
- | Mul(f,g) ->
- Debug.dprintf2 debug "[Arith] @[init mult %a@]@\n" Mul.print v;
- Delayed.register d f; Delayed.register d g;
- match norm_mul d own v with
- | AliveReattached ->
- (* close_assoc d f g own; *)
- (* close_assoc d g f own; *)
- Demon.Key.attach d DaemonMultPropa.key v
- [Demon.Create.EventDom(f,dom,());
- Demon.Create.EventDom(g,dom,());
- Demon.Create.EventChange(f,());
- Demon.Create.EventChange(g,());
- ]
- | AliveStopped | AliveRedirected _ -> ()
- end
- | _ -> raise UnwaitedEvent
- ) ev;
- Demon.AliveReattached
-
-end
-
-module RDaemonMultInit = Demon.Key.Register(DaemonMultInit)
-
-let zero = ThE.cl (ThE.index Polynome.zero real)
-
-let th_register env =
- RDaemonPropa.init env;
- RDaemonInit.init env;
- RDaemonMultPropa.init env;
- RDaemonMultInit.init env;
- Demon.Key.attach env
- DaemonInit.key () [Demon.Create.EventRegSem(sem,())];
- Demon.Key.attach env
- DaemonMultInit.key () [Demon.Create.EventRegSem(mul_sem,())];
- Delayed.register env zero
-
-
-(** Conflict *)
-(** Reason of equalities between arithmetical terms *)
-type conpoly = {imp : Th.t; exp : Th.t}
-let conpoly : conpoly Explanation.con = Explanation.Con.create_key "Arith.eq"
-
-let mk_conpoly p = {imp = p; exp = p}
-let zero_conpoly = {imp = Polynome.zero; exp = Polynome.zero}
-
-let add_conpoly p1 p2 =
- if p2 == zero_conpoly then p1
- else if p1 == zero_conpoly then p2
- else
- {imp = add p1.imp p2.imp; exp = add p1.exp p2.exp}
-
-let x_p_cy_conpoly p1 q p2 =
- if p2 == zero_conpoly then p1
- else
- {imp = x_p_cy p1.imp q p2.imp; exp = x_p_cy p1.exp q p2.exp}
-
-let get_pexp_conpoly_deps t pexp deps =
- let open Conflict in
- let v, deps' = ComputeConflict.get_pexp_deps t pexp conpoly in
- let deps = Explanation.Deps.concat deps' deps in
- match v with
- | GRequested p -> Some p, deps
- | GOther(con,c) ->
- None, Explanation.Deps.add_unknown_con deps con c
-
-let get_pexp_conpoly t pexp =
- let r, deps = get_pexp_conpoly_deps t pexp Explanation.Deps.empty in
- Conflict.ComputeConflict.add_deps t deps;
- r
-
-let dist_conpoly cl1 cl2 =
- let g = dist cl1 cl2 in
- {imp=g;exp=g}
-
-let print_conpoly fmt t =
- Format.fprintf fmt "{imp=%a;exp=%a}" Th.print t.imp Th.print t.exp
-
-let get_rlist_conpoly_deps t age cl1 cl2 deps =
- let rlist = Conflict.ComputeConflict.get_equal t age cl1 cl2 in
- Debug.dprintf6 debug "[Arith] get_rlist_conpoly cl1:%a cl2:%a: %a@\n"
- Cl.print cl1 Cl.print cl2 Conflict.print_rlist rlist;
- let r,deps,cl2' = List.fold_left
- (fun (p,deps,cl) edge ->
- let r,deps = get_pexp_conpoly_deps t edge.Conflict.epexp deps in
- let p = match r with
- | None -> add_conpoly p (dist_conpoly cl edge.Conflict.eto)
- | Some p' ->
- Debug.dprintf6 debug
- "[Arith] get_rlist_conpoly %a..%a: Done %a@\n"
- Cl.print cl Cl.print edge.Conflict.eto print_conpoly p';
- assert (Th.equal p'.exp (if edge.Conflict.einv
- then dist edge.Conflict.eto cl
- else dist cl edge.Conflict.eto));
- x_p_cy_conpoly p (minus_or_one edge.Conflict.einv) p'
- in
- p, deps, edge.Conflict.eto)
- (zero_conpoly,deps,cl1)
- rlist in
- Debug.dprintf6 debug "[Arith] get_rlist_conpoly %a -> %a: Done %a@\n"
- Cl.print cl1 Cl.print cl2' print_conpoly r;
- assert (Cl.equal cl2 cl2');
- assert (Th.equal r.exp (dist cl1 cl2));
- r,deps
-
-let get_rlist_conpoly t age cl1 cl2 =
- let r, deps = get_rlist_conpoly_deps t age cl1 cl2 Explanation.Deps.empty in
- Conflict.ComputeConflict.add_deps t deps;
- r
-
-(** Gen Equality and disequality *)
-module GenEquality = struct
- open Conflict
- open Explanation
-
- let equality t age cl1 cl2 =
- (** cl1 -> cl2 *)
- let p = get_rlist_conpoly t age cl1 cl2 in
- (** cl2 -> cl1 *)
- let p = add_conpoly p (dist_conpoly cl2 cl1) in
- (** cl1 -> cl2 -> cl1 = 0 *)
- assert (is_zero p.exp);
- ComputeConflict.unknown_con t conpoly p
-
- let expspecial =
- let f = fun (b1,deps) _ b2 -> add_conpoly b1 b2, deps in
- let get_sem t deps age sem v pexp =
- let b,deps = get_pexp_conpoly_deps t pexp deps in
- raise TODO
- (* Explanation.Deps.add_unknown_con deps conpoly b *)
- in
- { Equality.equality = equality;
- disequality = (fun t age ~hyp cl1d cl1e cl2e cl2d ->
- equality t age cl1d cl1e;
- equality t age cl2d cl2e);
- merged = (fun t deps age cl1d cl1 pexp cl2 cl2d ->
- Debug.dprintf8 (* TODO *) debug
- "cl1d:%a cl1:%a cl2:%a cl2d:%a@\n"
- Cl.print cl1d Cl.print cl1
- Cl.print cl2 Cl.print cl2d;
- (** cl1d -> cl1 *)
- let pr1,deps = get_rlist_conpoly_deps t age cl1d cl1 deps in
- Debug.dprintf2 debug "cl1d -> cl1: %a@\n" print_conpoly pr1;
- assert (Th.equal pr1.exp (dist cl1d cl1));
- (** cl1 -> cl2 *)
- let ppexp, deps = get_pexp_conpoly_deps t pexp deps in
- let ppexp = match ppexp with
- | None -> dist_conpoly cl1 cl2
- | Some p -> p in
- Debug.dprintf2 debug "cl1 -> cl2: %a@\n" print_conpoly ppexp;
- assert (Th.equal ppexp.exp (dist cl1 cl2));
- (** cl2 -> cl2d *)
- let pr2,deps = get_rlist_conpoly_deps t age cl2 cl2d deps in
- Debug.dprintf2 debug "cl2 -> cl2d: %a@\n" print_conpoly pr2;
- assert (Th.equal pr2.exp (dist cl2 cl2d));
- (** cl2d -> cl1d *)
- let pd = dist_conpoly cl2d cl1d in
- Debug.dprintf2 debug "cl2d -> cl1d: %a@\n" print_conpoly pd;
- (** cl1d -> cl1 -> cl2 -> cl2d -> cl1d = 0 *)
- let p = add_conpoly (add_conpoly (add_conpoly pr1 ppexp) pr2) pd in
- Debug.dprintf2 debug "sum: %a@\n" print_conpoly p;
- assert (is_zero p.exp);
- Explanation.Deps.add_unknown_con deps conpoly p);
- repr = (fun t deps age cl r1 -> assert false);
- (* let p,deps = get_rlist_conpoly_deps t cl r1 deps in *)
- (* assert (is_zero p.exp); *)
- (* Explanation.Deps.add_unknown_con deps conpoly p); *)
- dodec = true (** TODO *);
- }
-
- let () = Equality.register_sort real expspecial
-
-end
-
-module ConPoly = struct
- open Explanation
- open Conflict
- type t = conpoly
-
- let print = print_conpoly
-
- let key = conpoly
-
- class finalized v : Conflict.finalized = object
- method print fmt =
- Pp.print_iter1 Th.S.iter Pp.semi
- (fun fmt x -> Format.fprintf fmt "%a=0" Th.print x) fmt v
- method test d =
- try
- Th.S.fold_left (fun acc v -> (** different than 0 *)
- let _,vn = Th.normalize d v in
- match Polynome.classify vn with
- | ZERO -> acc
- | CST -> raise Exit
- | VAR -> ToDecide
- ) False v
- with Exit -> True
- method decide :
- 'a. 'a Conflict.fold_decisions -> Solver.Delayed.t -> 'a -> 'a =
- fun f d acc ->
- Th.S.fold_left (fun acc v ->
- let _,vn = Th.normalize d v in
- match Polynome.is_cst vn with
- | Some _ -> acc
- | None ->
- let f cl =
- if Equality.is_equal d cl zero ||
- Equality.is_disequal d cl zero then acc
- else
- let c = Equality.Eq(cl,zero,false) in
- f.fold_decisions acc Equality.choequal c ()
- in
- match Th.is_one_cl v with
- | Some cl -> f cl
- | None -> f (ThE.cl (ThE.index v real))
- ) acc v
- method conflict_add d =
- let fold acc v =
- let f cl1 cl2 =
- let eq = Equality.disequality [cl1;cl2] in
- Cl.M.add eq false acc in
- (* let _,v = Th.normalize d v in *)
- (** todo: why the explication can be ignored? *)
- match Polynome.is_cst v with
- | Some _ -> acc
- | None ->
- (** no find because the explication would be different *)
- match Polynome.is_one_cl v with
- | Some cl' -> f cl' zero
- | None ->
- let cl' = Cl.index sem v real in
- f cl' zero
- in
- Th.S.fold_left fold Cl.M.empty v
-
- end
-
- (* let print fmt sl = *)
- (* Bag.iter (fun p -> *)
- (* Format.fprintf fmt "@[{imp=%a|exp=%a}@];" *)
- (* Th.print p.imp Th.print p.exp) sl *)
- (* in *)
-
-
- let finalize _ sl =
- Debug.dprintf2 debug "[Arith] @[sl:%a@]@\n"
- (Bag.print Pp.semi print_conpoly) sl;
- let s = Bag.fold_left (fun acc p ->
- assert (is_zero p.exp);
- if is_zero p.imp then acc else Th.S.add p.imp acc
- ) Th.S.empty sl in
- let print = Pp.print_iter1 Th.S.iter Pp.semi Th.print in
- Debug.dprintf2 Conflict.print_conflicts
- "[Arith] @[conflict:%a.@]@\n" print s;
- if Th.S.is_empty s
- then None
- else Some (new finalized s)
-
-
- let same_sem (type a) t age (sem':a sem) (v:a) pexp1 cl1 cl2 =
- let r1 = get_pexp_conpoly t pexp1 in
- let p = match r1 with
- | Some p1 ->
- let p2 =
- match Sem.Eq.eq_type sem sem' with
- | None -> raise Impossible (* understand why that happend *)
- | Some Types.Eq ->
- let p2 = x_p_cy (monome Q.one cl2) Q.minus_one v in
- {imp = p2; exp = p2}
- in
- x_p_cy_conpoly p1 Q.minus_one p2
- | _ -> dist_conpoly cl1 cl2 in
- Debug.dprintf6 debug_todo "@[same_sem cl1:%a cl2:%a = %a@]@\n"
- Cl.print cl1 Cl.print cl2 print_conpoly p;
- assert (Th.equal p.exp (dist cl1 cl2));
- GRequested p
-
-
- let propacl t age cl rcl =
- if ComputeConflict.before_first_dec t age
- then GRequested (dist_conpoly cl rcl)
- else GRequested {imp = Polynome.zero; exp = dist cl rcl}
-
-end
-
-module EConPoly = Conflict.RegisterCon(ConPoly)
-
-module ExpEquality = struct
- open Conflict
- (* open IterExp *)
- open ComputeConflict
-
- type t = expequality
-(*
- let print_kind fmt = function
- | ExpSolve (pexp,q,cl1,cl2) ->
- Format.fprintf fmt "ExpSolve(%a,%a,%a,%a)"
- print_pexpclcl pexp
- Q.pp_print q
- (Pp.print_option Cl.print) cl1
- (Pp.print_option Cl.print) cl2
- | ExpMerge (pexp,q1,q2,cl1,cl2) ->
- Format.fprintf fmt "ExpMerge(%a,%a,%a,%a,%a)"
- print_pexpclcl pexp
- Q.pp_print q1
- Q.pp_print q2
- (Pp.print_option Cl.print) cl1
- (Pp.print_option Cl.print) cl2
-*)
-
- let print_combi1 fmt = function
- | CombiRepr (q,cl,_) -> Format.fprintf fmt "%a~%a" Q.pp_print q Cl.print cl
- | CombiDom (q,cl,_) -> Format.fprintf fmt "%a.%a" Q.pp_print q Cl.print cl
- | CombiSem (q,t,_) -> Format.fprintf fmt "%a:%a" Q.pp_print q Th.print t
- | CombiPexp (q,def,pexp,_) -> Format.fprintf fmt "%a~(%a)%a"
- Q.pp_print q Th.print def
- Conflict.print_pexp pexp
- | CombiNull -> Format.pp_print_string fmt "0"
-
- let print_combi fmt n =
- Pp.print_iter1 iter_combi (Pp.constant_string "+") print_combi1 fmt n
-
- let print fmt = function
-(* | ExpSem (kind,cl) ->
- Format.fprintf fmt "ExpSem(%a,%a)"
- print_kind kind
- Cl.print cl
- | ExpCl (kind,cl1,cl2) ->
- Format.fprintf fmt "ExpCl(%a,%a,%a)"
- print_kind kind
- Cl.print cl1
- Cl.print cl2
- | ExpSubst (cl,_) -> Format.fprintf fmt "Subst(%a)" Cl.print cl
-*)
- | ExpCombi (id,t,n) -> Format.fprintf fmt "Combi(%i,%a,%a)"
- id Th.print t print_combi n
- | ExpCstDiff (q,n) ->
- Format.fprintf fmt "ExpCstDiff(%a,%a)"
- Q.pp_print q
- print_combi n
- | ExpMult (p,g,f,own) ->
- Format.fprintf fmt "ExpMult(%a,%a,%a,%a)"
- Q.pp_print p Cl.print g Cl.print f Cl.print own
-
-(*
- let iterexp t age x =
- let iter t age (pexp,clo,clr) cl1 cl2 =
- need_cl_repr t age clo;
- need_cl_repr t age clr;
- need_pexp t pexp;
- Opt.iter (fun x -> need_dom t age x dom) cl1;
- Opt.iter (fun x -> need_dom t age x dom) cl2 in
- let rec iternorm t age = function
- | SubstCl(_,cl,n) -> need_cl_repr t age cl; iternorm t age n
- | SubstSem(_,cl,n) -> need_dom t age cl dom; iternorm t age n
- | SubstNil -> () in
- let iter_kind t age = function
- | ExpSolve(pexp,_,cl1,cl2)
- | ExpMerge(pexp,_,_,cl1,cl2) ->
- iter t age pexp cl1 cl2 in
- match x with
- | ExpSem(kind,_)
- | ExpCl(kind,_,_) ->
- iter_kind t age kind
- | ExpSubst (cl,n) ->
- need_dom t age cl dom;
- iternorm t age n
- | ExpNorm (v,n) ->
- need_sem t age sem v;
- iternorm t age n
- | ExpCstDiff(pexp,cl1,cl2) ->
- iter t age pexp cl1 cl2
-*)
-
-
- let rec analyse_combi t age combi =
- Debug.dprintf2 debug_todo "@[analyse_combi? %a@]@\n"
- print_combi1 combi;
- let p = match combi with
- | CombiNull -> zero_conpoly
- | CombiPexp(q,th,pexp,n) ->
- let n = analyse_combi t age n in
- x_p_cy_conpoly n q
- (match get_pexp_conpoly t pexp with
- | None -> {imp=th;exp=th}
- | Some p -> assert (Th.equal p.exp th); p)
- | CombiDom(q,cl,n) ->
- let n = analyse_combi t age n in
- let mod_dom = get_dom_last t age cl dom in
- let p = x_p_cy_conpoly n
- (** dom -> modcl *)
- q (Opt.get (get_pexp_conpoly t mod_dom.Explanation.modpexp)) in
- let modcl = mod_dom.Explanation.modcl in
- (** cl -> modcl *)
- x_p_cy_conpoly p q (get_rlist_conpoly t age cl modcl)
- | CombiSem(q,v,n) ->
- let n = analyse_combi t age n in
- let cl = ThE.cl (ThE.index v real) in
- let pexp = mk_conpoly (x_p_cy (monome Q.one cl) Q.minus_one v) in
- x_p_cy_conpoly n q pexp
- | CombiRepr(q,cl,n) ->
- let n = analyse_combi t age n in
- let rcl = ComputeConflict.get_repr_at t age cl in
- let p = get_rlist_conpoly t age cl rcl in
- assert (Th.equal p.exp (dist cl rcl));
- x_p_cy_conpoly n q p
- in
- Debug.dprintf4 debug_todo "@[analyse_combi %a: %a@]@\n"
- print_combi1 combi print_conpoly p;
- p
-
-
- let analyse =
- fun t age con exp ->
- match exp with
- | ExpCombi (id,th,combi) ->
- let p = analyse_combi t age combi in
- Debug.dprintf5 debug_todo "ExpCombi:%i @[th=%a; p=%a@]@\n"
- id Th.print th print_conpoly p;
- assert (Th.equal th p.exp);
- Conflict.return con conpoly p
- | ExpCstDiff(q,combi) ->
- let p = analyse_combi t age combi in
- Debug.dprintf4 debug_todo "ExpCstDiff: @[q=%a; p=%a@]@\n"
- Q.pp_print q print_conpoly p;
- let q = cst q in
- let p = {imp = add p.imp q; exp = add p.exp q} in
- assert (is_zero p.exp);
- Conflict.return con conpoly p
- | ExpMult(p,g,f,own) ->
- let q = analyse_combi t age (CombiDom(Q.one,g,CombiNull)) in
- let g' = Polynome.(sub_cst (monome Q.one g) p) in
- let q' = x_p_cy_conpoly q Q.minus_one (mk_conpoly g') in
- assert (is_zero q'.exp);
- let fg = monome Q.one own in
- let pf = monome (Q.neg p) f in
- let fg_pf = add fg pf in
- match Polynome.is_cst q'.imp with
- | Some c ->
- let r = {imp = add fg_pf (monome c f);
- exp = fg_pf} in
- Conflict.return con conpoly r
- | None ->
- (** add a cut: g = p, since g - p - q' = 0; q' = 0 *)
- Conflict.ComputeConflict.unknown_con t conpoly q';
- Conflict.return con conpoly (mk_conpoly fg_pf)
-
- let expdom t age dom' cl con exp =
- match exp with
- | ExpCombi (_,th,_) ->
- let p = th in
- if ComputeConflict.before_first_dec t age
- then Conflict.return con conpoly (mk_conpoly p)
- else Conflict.return con conpoly {imp = Polynome.zero; exp = p}
- | ExpCstDiff(q,combi) ->
- raise Impossible (** only used for last explanation *)
- | ExpMult (p,g,f,own) ->
- assert false (* todo *)
-
-
- let key = expequality
-
-end
-
-module EExpEquality = Conflict.RegisterExp(ExpEquality)
-
-module ExpMulSubst = struct
- open Conflict
- (* open IterExp *)
- open ComputeConflict
-
- type t = expmulsubst
-
- let print fmt v =
- Format.fprintf fmt "Subst(%a)" Mul.print v
-(*
- let iterexp t age = function
- | Mul(f,g) as v ->
- need_sem t age mul_sem v;
- need_cl_repr t age f;
- need_cl_repr t age g
-*)
-
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con exp ->
- let get_con () t = function
- | GRequested () -> ()
- | GOther (con,c) -> ComputeConflict.unknown_con t con c in
- let get_cons = fold_rescon_list t get_con confact in
- let return () : a Conflict.rescon =
- match Explanation.Con.Eq.eq_type confact con with
- | None -> GOther (confact,())
- | Some Types.Eq -> GRequested () in
- begin match exp with
- | Mul(f,g) as v ->
- GenEquality.equality t age f (get_repr_at t age f);
- GenEquality.equality t age g (get_repr_at t age g);
- end;
- return ()
-
- let expdom _ _ _ _ _ _ = raise TODO
-
- let key = expmulsubst
-
-end
-
-module EExpMulsubst = Conflict.RegisterExp(ExpMulSubst)
-
-
-(** API *)
-
-let index x = Cl.index sem x real
-
-let cst c = index (cst c)
-
-let as_cl cl = monome Q.one cl
-
-let add cl1 cl2 =
- index (add (as_cl cl1) (as_cl cl2))
-
-let sub cl1 cl2 =
- index (sub (as_cl cl1) (as_cl cl2))
-
-let mult cl1 cl2 =
- Cl.index mul_sem (make_mul cl1 cl2) real
-
-let mult_cst cst cl =
- index (mult_cst cst (as_cl cl))
diff --git a/src/arith/interval.ml b/src/arith/interval.ml
deleted file mode 100644
index ddfb72166..000000000
--- a/src/arith/interval.ml
+++ /dev/null
@@ -1,311 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-type bound = Strict | Large
-
-
-type interval = { lb : bound; lv: Q.t; rv: Q.t; rb: bound }
-
-let print_q fmt q =
- match Q.classify q with
- | Q.ZERO -> Format.pp_print_char fmt '0'
- | Q.INF -> Format.pp_print_string fmt "+∞"
- | Q.MINF -> Format.pp_print_string fmt "-∞"
- | Q.UNDEF -> Format.pp_print_string fmt "!undef!"
- | Q.NZERO -> Q.pp_print fmt q
-
-let print_inter fmt t =
- let print_bound_left fmt = function
- | Large -> Format.fprintf fmt "["
- | Strict -> Format.fprintf fmt "]" in
- let print_bound_right fmt = function
- | Large -> Format.fprintf fmt "]"
- | Strict -> Format.fprintf fmt "[" in
- Format.fprintf fmt "%a%a;%a%a"
- print_bound_left t.lb
- print_q t.lv
- print_q t.rv
- print_bound_right t.rb
-
-let equal_inter e1 e2 =
- e1.lb == e2.lb && e2.rb == e2.rb && Q.equal e1.lv e2.lv && Q.equal e1.rv e2.rv
-
-type t = interval list
-(** all t returned to the outside should verify this invariant *)
-
-let print fmt l =
- Pp.print_list (Pp.constant_string "∪") print_inter fmt l
-
-let invariant l =
- let rec aux minb minv l =
- match minb, l with
- | Large, [] when Q.equal minv Q.inf -> false
- | _ , [] -> true
- | _ , {lb=Large ; lv}::_ when Q.compare lv minv <= 0 -> false
- | Large , {lb=Strict; lv}::_ when Q.compare lv minv <= 0 -> false
- | Strict, {lb=Strict; lv}::_ when Q.compare lv minv < 0 -> false
- | _, {lb=Strict; lv; rv}::_ when Q.compare rv lv <= 0 -> false
- | _, {lb=Large ; lv; rv; rb=Strict}::_ when Q.compare rv lv <= 0 -> false
- | _, {lb=Large ; lv; rv; rb=Large }::_ when Q.compare rv lv < 0 -> false
- | _, {rv;rb}::l -> aux rb rv l
- in
- aux Strict Q.minus_inf l
-
-
-let empty = []
-let is_empty t = t == []
-let reals = [{lb=Strict; lv=Q.minus_inf; rb=Strict; rv=Q.inf}]
-let is_reals = function
- | [{lb=Strict; lv; rb=Strict; rv}] when Q.equal lv Q.minus_inf &&
- Q.equal rv Q.inf -> true
- | _ -> false
-
-let is_singleton = function
- | [{lv;rv}] when Q.equal lv rv -> Some lv
- | _ -> None
-
-let min_max e1 l1 t1 e2 l2 t2 =
- let c = Q.compare e1.lv e2.lv in
- match e1.lb, e2.lb with
- | Strict, Large
- when c = 0 -> e2,l2,t2,e1,l1,t1
- | _
- when c <= 0 -> e1,l1,t1,e2,l2,t2
- | _ -> e2,l2,t2,e1,l1,t1
-
-let rec is_distinct t1 t2 =
- match t1,t2 with
- | [], _ | _, [] -> true
- | e1::l1, e2::l2 ->
- (** order by the minimum *)
- let emin,lmin,_,emax,_,tmax = min_max e1 l1 t1 e2 l2 t2 in
- (** look for inclusion *)
- let c = Q.compare emin.rv emax.lv in
- match emin.rb, emax.lb with
- | Strict, Strict | Strict, Large | Large, Strict
- when c <= 0 -> is_distinct lmin tmax
- | Large, Large
- when c < 0 -> is_distinct lmin tmax
- | _ -> false
-
-
-let rec union t1 t2 =
- match t1,t2 with
- | [], l | l, [] -> l
- | e1::l1, e2::l2 ->
- (** order by the minimum *)
- let emin,lmin,_,emax,lmax,tmax = min_max e1 l1 t1 e2 l2 t2 in
- (** look for an intersection *)
- let c = Q.compare emin.rv emax.lv in
- match emin.rb, emax.lb with
- | Strict, Strict
- when c <= 0 -> emin::(union lmin tmax)
- | Large,Large | Strict, Large | Large, Strict
- when c < 0 -> emin::(union lmin tmax)
- | _ ->
- (** look for inclusion *)
- let c = Q.compare emax.rv emin.rv in
- match emin.lb, emax.lb with
- (** max included in min *)
- | Strict, Strict | Large, Large | Large, Strict
- when c <= 0 -> emin::(union lmin lmax)
- | Strict, Large
- when c < 0 -> emin::(union lmin lmax)
- (** merge the two *)
- | _ ->
- let e = {lv = emin.lv; lb = emin.lb; rv = emax.rv; rb = emax.rb} in
- union lmin (e::lmax)
-
-
-let rec inter' t1 t2 =
- match t1,t2 with
- | [], _ | _, [] -> []
- | e1::l1, e2::l2 ->
- (** order by the minimum *)
- let emin,lmin,tmin,emax,lmax,tmax = min_max e1 l1 t1 e2 l2 t2 in
- (** look for an intersection *)
- let c = Q.compare emin.rv emax.lv in
- match emin.rb, emax.lb with
- | Strict, Strict
- when c <= 0 -> inter' lmin tmax
- | Large,Large | Strict, Large | Large, Strict
- when c < 0 -> inter' lmin tmax
- | _ ->
- (** look for inclusion *)
- let c = Q.compare emax.rv emin.rv in
- match emin.lb, emax.lb with
- (** max included in min *)
- | Strict, Strict | Large, Large | Large, Strict
- when c <= 0 -> emax::(inter' tmin lmax)
- | Strict, Large
- when c < 0 -> emax::(inter' tmin lmax)
- (** merge the two *)
- | _ ->
- let e = {lv = emax.lv; lb = emax.lb; rv = emin.rv; rb = emin.rb} in
- e::(inter' lmin tmax)
-
-(** special case if the two are equals, return the second *)
-let rec inter t1 t2 =
- match t1, t2 with
- | _ when t1 == t2 -> t2
- | [], _ | _, [] -> []
- | e1::l1, e2::l2 when equal_inter e1 e2 ->
- let l = inter l1 l2 in
- if l == l2 then t2 else e2::l2
- | _ -> inter' t1 t2
-
-let singleton q =
- let t = [{lb=Large; lv = q; rv = q; rb= Large}] in
- assert (invariant t);
- t
-
-let gt q =
- let t = [{lb=Strict; lv = q; rv = Q.inf; rb= Strict}] in
- assert (invariant t);
- t
-
-let ge q =
- let t = [{lb=Large ; lv = q; rv = Q.inf; rb= Strict}] in
- assert (invariant t);
- t
-
-let lt q =
- let t = [{lb=Strict; lv = Q.minus_inf; rv = q; rb= Strict}] in
- assert (invariant t);
- t
-
-let le q =
- let t = [{lb=Strict; lv = Q.minus_inf; rv = q; rb= Large }] in
- assert (invariant t);
- t
-
-let rec add_cst q = function
- | [] -> []
- | a::l -> {a with lv = Q.add a.lv q; rv = Q.add a.rv q}::(add_cst q l)
-
-let add_cst q t =
- if Q.equal Q.zero q then t else add_cst q t
-
-let rec mult_pos q = function
- | [] -> []
- | a::l -> {a with lv = Q.mul a.lv q; rv = Q.mul a.rv q}::(mult_pos q l)
-
-let rec mult_neg acc q = function
- | [] -> acc
- | a::l -> mult_neg ({lb = a.rb; rb = a.lb;
- lv = Q.mul a.rv q;
- rv = Q.mul a.lv q}::acc) q l
-
-let mult_cst q t =
- assert (Q.is_real q);
- let c = Q.sign q in
- if c = 0 then singleton Q.zero
- else if c > 0 then mult_pos q t
- else mult_neg [] q t
-
-
-let mult_bound b1 b2 =
- match b1, b2 with
- | Large , Large -> Large
- | _ -> Strict
-
-(** t is smaller than l but perhaps a merge is needed *)
-let cons t l =
- match t.rb, l with
- | _,[] -> [t]
- | Strict, ({lb=Strict} as e)::_ when Q.compare t.rv e.lv <= 0 ->
- t::l
- | _, e::_ when Q.compare t.rv e.lv < 0 ->
- t::l
- | _, e::l ->
- assert (Q.compare t.lv e.lv < 0);
- assert (Q.compare t.rv e.rv < 0);
- {lb=t.lb; lv = t.rv; rv = e.rv; rb = e.rb}::l
-
-let rec add_interval t = function
- | [] -> []
- | e::l ->
- let e = {lb=mult_bound t.lb e.lb;
- lv=Q.add t.lv e.lv;
- rv=Q.add t.rv e.rv;
- rb=mult_bound t.rb e.rb} in
- cons e (add_interval t l)
-
-let add t1 t2 =
- let res = match is_singleton t1, t1, is_singleton t2, t2 with
- | None,_, None,_ ->
- List.fold_left (fun acc t -> union acc (add_interval t t2)) [] t1
- | Some q, _, None, t
- | None, t, Some q, _ when Q.equal Q.zero q -> t
- | Some q, _, None, t
- | None, t, Some q, _ ->
- add_cst q t
- | Some q1,_, Some q2,_ -> singleton (Q.add q1 q2)
- in
- assert ( invariant res );
- res
-
-(** TODO better heuristic *)
-let choose ?exn = function
- | [] -> raise (Opt.get_def Not_found exn)
- | {lb=Large;lv}::_ -> lv
- | {rb=Large;rv}::_ -> rv
- | {lv;rv}::_ when Q.equal Q.minus_inf lv ->
- Q.make (Z.sub Z.one (Q.to_bigint rv)) Z.one
- | {lv;rv}::_ when Q.equal Q.inf rv ->
- Q.make (Z.add Z.one (Q.to_bigint lv)) Z.one
- | {lv;rv}::_ -> Q.add rv (Q.div_2exp (Q.sub lv rv) 1)
-
-
-let mult_cst q t =
- let res = mult_cst q t in
- assert ( invariant res );
- res
-
-let union t1 t2 =
- let res = union t1 t2 in
- assert ( invariant res );
- res
-
-let inter t1 t2 =
- let res = inter t1 t2 in
- assert ( invariant res );
- res
-
-let unit_test () =
- assert ( invariant empty );
- assert ( is_empty empty );
- assert ( invariant reals );
- assert ( is_reals reals );
- let zero = singleton Q.zero in
- let one = singleton Q.one in
- let two = singleton (Q.of_int 2) in
- let three = singleton (Q.of_int 3) in
- assert (not (is_distinct zero zero));
- assert (is_distinct zero one);
- let one_three = inter (ge Q.one) (lt (Q.of_int 3)) in
- assert (not (is_distinct two one_three));
- assert (is_distinct three one_three);
- assert (not (is_distinct one one_three));
- ()
-
-let () = unit_test ()
diff --git a/src/arith/interval.mli b/src/arith/interval.mli
deleted file mode 100644
index 65169523b..000000000
--- a/src/arith/interval.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-type t
-val print: Format.formatter -> t -> unit
-
-val is_distinct: t -> t -> bool
-
-val mult_cst: Q.t -> t -> t
-val add_cst : Q.t -> t -> t
-val add: t -> t -> t
-
-(** from Q.t *)
-val singleton: Q.t -> t
-val is_singleton: t -> Q.t option
-
-val gt: Q.t -> t
-val ge: Q.t -> t
-val lt: Q.t -> t
-val le: Q.t -> t
-(** > q, >= q, < q, <= q *)
-
-val union: t -> t -> t
-(** union set *)
-
-val inter: t -> t -> t
-(** intersection set.
- if the two arguments are equals, return the second
-*)
-
-
-val reals: t
-(** R *)
-val is_reals: t -> bool
-
-val empty: t
-(** \emptyset *)
-val is_empty: t -> bool
-
-val choose: ?exn:exn -> t -> Q.t
-(** Nothing smart in this choosing *)
diff --git a/src/arith/polynome.ml b/src/arith/polynome.ml
deleted file mode 100644
index 0a01946af..000000000
--- a/src/arith/polynome.ml
+++ /dev/null
@@ -1,172 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
-
-
-module T = struct
- type t = { cst : Q.t; poly : Q.t Cl.M.t}
-
- let equal n m = Q.equal n.cst m.cst && Cl.M.equal Q.equal n.poly m.poly
-
- let hash n = (** number au pif *)
- Cl.M.fold (fun k v acc ->
- Cl.hash k * 101 + Hashtbl.hash v * 107 + acc * 253)
- n.poly (Hashtbl.hash n.cst * 27)
-
- let compare n m =
- let c = Q.compare n.cst m.cst in
- if c <> 0 then c
- else Cl.M.compare Q.compare n.poly m.poly
-
- let print fmt v =
- let print_not_1 first fmt q =
- if not first && Q.compare q Q.zero >= 0
- then Format.pp_print_string fmt "+";
- if Q.equal q Q.zero then Format.pp_print_string fmt "!0!"
- else if Q.equal Q.minus_one q then Format.pp_print_string fmt "-"
- else if not (Q.equal Q.one q) then Q.pp_print fmt q
- in
- let print_not_0 first fmt q =
- if first
- then Q.pp_print fmt q
- else
- if not (Q.equal Q.zero q) then begin
- if Q.compare q Q.zero > 0 then Format.pp_print_string fmt "+";
- Q.pp_print fmt q
- end
- in
- let print_mono k v (fmt,first) =
- Format.fprintf fmt "@[%a%a@]@," (print_not_1 first) v Cl.print k;
- (fmt,false)
- in
- Format.fprintf fmt "@[";
- let _,first = Cl.M.fold print_mono v.poly (fmt,true) in
- Format.fprintf fmt "%a@]" (print_not_0 first) v.cst
-
-end
-
-open T
-include Stdlib.MkDatatype(T)
-
-(** different invariant *)
-
-let invariant p =
- Cl.M.for_all (fun _ q -> not (Q.equal q Q.zero)) p.poly
-
-(** constructor *)
-let cst q = {cst = q; poly = Cl.M.empty}
-let zero = cst Q.zero
-let is_cst p = if Cl.M.is_empty p.poly then Some p.cst else None
-let is_zero p = Q.equal p.cst Q.zero && Cl.M.is_empty p.poly
-
-type extract = Zero | Cst of Q.t | Var of Q.t * Cl.t * t
-let extract p =
- if Cl.M.is_empty p.poly then
- if Q.equal p.cst Q.zero then Zero
- else Cst p.cst
- else
- let x,q = Shuffle.chooseb Cl.M.choose Cl.M.choose_rnd p.poly in
- let p' = {p with poly = Cl.M.remove x p.poly} in
- Var(q,x,p')
-
-type kind = ZERO | CST | VAR
-let classify p =
- if Cl.M.is_empty p.poly then
- if Q.equal p.cst Q.zero then ZERO
- else CST
- else
- VAR
-
-
-let monome c x =
- if Q.equal Q.zero c then cst Q.zero
- else {cst = Q.zero; poly = Cl.M.singleton x c}
-
-let is_one_cl p = (** cst = 0 and one empty monome *)
- if Q.equal Q.zero p.cst && Cl.M.is_num_elt 1 p.poly then
- let cl,k = Cl.M.choose p.poly in
- if Q.equal Q.one k then Some cl
- else None
- else None
-
-let sub_cst p q = {p with cst = Q.sub p.cst q}
-
-let mult_cst c p1 =
- if Q.equal Q.one c then p1
- else
- let poly_mult c m = Cl.M.map (fun c1 -> Q.mul c c1) m in
- if Q.equal Q.zero c then cst Q.zero
- else {cst = Q.mul c p1.cst; poly = poly_mult c p1.poly}
-
-
-let none_zero c = if Q.equal Q.zero c then None else Some c
-
-(** Warning Cl.M.union can be used only for defining an operation [op]
- that verifies [op 0 p = p] and [op p 0 = p] *)
-let add p1 p2 =
- let poly_add m1 m2 =
- Cl.M.union (fun _ c1 c2 -> none_zero (Q.add c1 c2)) m1 m2
- in
- {cst = Q.add p1.cst p2.cst; poly = poly_add p1.poly p2.poly}
-
-let sub p1 p2 =
- let poly_sub m1 m2 =
- Cl.M.union_merge (fun _ c1 c2 ->
- match c1 with
- | None -> Some (Q.neg c2)
- | Some c1 -> none_zero (Q.sub c1 c2))
- m1 m2 in
- {cst = Q.sub p1.cst p2.cst; poly = poly_sub p1.poly p2.poly}
-
-let x_p_cy p1 c p2 =
- assert (not (Q.equal c Q.zero));
- let f a b = Q.add a (Q.mul c b) in
- let poly m1 m2 =
- Cl.M.union_merge (fun _ c1 c2 ->
- match c1 with
- | None -> Some (Q.mul c c2)
- | Some c1 -> none_zero (f c1 c2))
- m1 m2 in
- {cst = f p1.cst p2.cst; poly = poly p1.poly p2.poly}
-
-
-let subst_cl p x y =
- let poly,qo = Cl.M.find_remove x p.poly in
- match qo with
- | None -> p, Q.zero
- | Some q ->
- let poly = Cl.M.change (function
- | None -> qo
- | Some q' -> none_zero (Q.add q q')
- ) y poly in
- {p with poly}, q
-
-let subst p x s =
- let poly,q = Cl.M.find_remove x p.poly in
- match q with
- | None -> p, Q.zero
- | Some q -> x_p_cy {p with poly} q s, q
-
-let fold f acc p = Cl.M.fold_left f acc p.poly
-let iter f p = Cl.M.iter f p.poly
diff --git a/src/bin/dune b/src/bin/dune
new file mode 100644
index 000000000..a168a58d3
--- /dev/null
+++ b/src/bin/dune
@@ -0,0 +1,13 @@
+; main binary
+
+(executable
+ (modes byte exe)
+ (name witan)
+ (public_name witan)
+ (libraries containers gen dolmen cmdliner spelll witan.core
+ witan.solver witan.theories.bool witan.theories.LRA)
+ (preprocess
+ (pps ppx_optcomp))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -color always)
+ (ocamlopt_flags :standard -O3 -color always -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/bin/options.ml b/src/bin/options.ml
new file mode 100644
index 000000000..45c3f932c
--- /dev/null
+++ b/src/bin/options.ml
@@ -0,0 +1,212 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(* Option types *)
+(* ************************************************************************ *)
+
+type language = Witan_solver.Input.language
+
+type input_options = {
+ dir : string;
+ file : string;
+ language : language option;
+}
+
+type t = {
+
+ input : input_options;
+
+ (* typing *)
+ type_only : bool;
+
+ (* Time/Memory options *)
+ time_limit : float;
+ size_limit : float;
+
+ (* Step options *)
+ step_limit : int;
+
+ (* seed for shuffling *)
+ seed_shuffle : int option;
+
+ (* debug flags *)
+ debug_flags : Witan_popop_lib.Debug.flag list;
+}
+
+(* Creating option records *)
+(* ************************************************************************ *)
+
+let mk_input_options f language =
+ let dir = Filename.dirname f in
+ let file = Filename.basename f in
+ { dir; file; language; }
+
+let mk input time_limit size_limit step_limit type_only seed_shuffle debug_flags =
+ { input; time_limit; size_limit; step_limit; type_only; seed_shuffle; debug_flags }
+
+(* Argument converters *)
+(* ************************************************************************ *)
+
+let input = Cmdliner.Arg.enum Witan_solver.Input.enum
+
+(* Argument converter for integer with multiplier suffix *)
+(* ************************************************************************ *)
+
+let nb_sec_minute = 60
+let nb_sec_hour = 60 * nb_sec_minute
+let nb_sec_day = 24 * nb_sec_hour
+
+let print_aux suffix fmt n =
+ if n = 0 then ()
+ else Format.fprintf fmt "%d%s" n suffix
+
+let print_time fmt f =
+ let n = int_of_float f in
+ let aux n div = n / div, n mod div in
+ let n_day, n = aux n nb_sec_day in
+ let n_hour, n = aux n nb_sec_hour in
+ let n_min, n = aux n nb_sec_minute in
+ Format.fprintf fmt "%a%a%a%a"
+ (print_aux "d") n_day
+ (print_aux "h") n_hour
+ (print_aux "m") n_min
+ (print_aux "s") n
+
+let parse_time arg =
+ let l = String.length arg in
+ let multiplier m =
+ let arg1 = String.sub arg 0 (l-1) in
+ `Ok (m *. (float_of_string arg1))
+ in
+ assert (l > 0);
+ try
+ match arg.[l-1] with
+ | 's' -> multiplier 1.
+ | 'm' -> multiplier 60.
+ | 'h' -> multiplier 3600.
+ | 'd' -> multiplier 86400.
+ | '0'..'9' -> `Ok (float_of_string arg)
+ | _ -> `Error "bad numeric argument"
+ with Failure _ -> `Error "bad numeric argument"
+
+let print_size fmt f =
+ let n = int_of_float f in
+ let aux n div = n / div, n mod div in
+ let n_tera, n = aux n 1_000_000_000_000 in
+ let n_giga, n = aux n 1_000_000_000 in
+ let n_mega, n = aux n 1_000_000 in
+ let n_kilo, n = aux n 1_000 in
+ Format.fprintf fmt "%a%a%a%a%a"
+ (print_aux "To") n_tera
+ (print_aux "Go") n_giga
+ (print_aux "Mo") n_mega
+ (print_aux "ko") n_kilo
+ (print_aux "") n
+
+let parse_size arg =
+ let l = String.length arg in
+ let multiplier m =
+ let arg1 = String.sub arg 0 (l-1) in
+ `Ok (m *. (float_of_string arg1))
+ in
+ assert (l > 0);
+ try
+ match arg.[l-1] with
+ | 'k' -> multiplier 1e3
+ | 'M' -> multiplier 1e6
+ | 'G' -> multiplier 1e9
+ | 'T' -> multiplier 1e12
+ | '0'..'9' -> `Ok (float_of_string arg)
+ | _ -> `Error "bad numeric argument"
+ with Failure _ -> `Error "bad numeric argument"
+
+let c_time = parse_time, print_time
+let c_size = parse_size, print_size
+
+(* Debug option *)
+let debug_flags_options = "DEBUG FLAGS"
+
+let debug =
+ let list_flags =
+ List.map (fun (name,flag,_,desc) ->
+ let doc = Format.asprintf "%a" Witan_popop_lib.Pp.formatted desc in
+ let info = Cmdliner.Arg.info ["debug-"^name] ~doc ~docs:debug_flags_options in
+ flag, info
+ )
+ (Witan_popop_lib.Debug.list_flags ())
+
+ in
+ Cmdliner.Arg.(value & vflag_all [] list_flags)
+
+
+(* Command terms *)
+(* ************************************************************************ *)
+
+let common_options = "COMMON OPTIONS"
+
+let man = [
+ `S common_options;
+ `P "Common options for the prover";
+ `S debug_flags_options;
+]
+
+let info = Cmdliner.Term.(info ~man ~sdocs:common_options ~version:"0.1" "witan")
+
+let input_options =
+ let docs = common_options in
+ let fd =
+ let doc = "Input problem file" in
+ Cmdliner.Arg.(required & pos 0 (some non_dir_file) None & info [] ~docv:"FILE" ~doc)
+ in
+ let language =
+ let doc = Format.asprintf
+ "Set the format for the input file to $(docv) (%s)."
+ (Cmdliner.Arg.doc_alts_enum ~quoted:false Witan_solver.Input.enum) in
+ Cmdliner.Arg.(value & opt (some input) None & info ["i"; "input"] ~docs ~docv:"INPUT" ~doc)
+ in
+ Cmdliner.Term.(const mk_input_options $ fd $ language)
+
+let all =
+ let docs = common_options in
+ let time =
+ let doc = {|Stop the program after a time lapse of $(docv).
+ Accepts usual suffixes for durations : s,m,h,d.
+ Without suffix, default to a time in seconds.|} in
+ Cmdliner.Arg.(value & opt c_time 300. & info ["t"; "time"] ~docs ~docv:"TIME" ~doc)
+ in
+ let size =
+ let doc = {|Stop the program if it tries and use more the $(docv) memory space.
+ Accepts usual suffixes for sizes : k,M,G,T.
+ Without suffix, default to a size in octet.|} in
+ Cmdliner.Arg.(value & opt c_size 1_000_000_000. & info ["s"; "size"] ~docs ~docv:"SIZE" ~doc)
+ in
+ let step =
+ let doc = {|Stop the program if it tries and use more the $(docv) steps.|} in
+ Cmdliner.Arg.(value & opt int (-1) & info ["steps"] ~docs ~docv:"STEPS" ~doc)
+ in
+ let seed =
+ let doc = {|Give a seed for the randomness used in the search (default fixed).|} in
+ Cmdliner.Arg.(value & opt (some int) None & info ["seed"] ~docs ~docv:"STEPS" ~doc)
+ in
+ let type_only =
+ let doc = {|Stop the program after parsing and typing.|} in
+ Cmdliner.Arg.(value & flag & info ["type-only"] ~doc)
+ in
+ Cmdliner.Term.(const mk $ input_options $ time $ size $ step $ type_only $ seed $ debug)
diff --git a/src/bin/options.mli b/src/bin/options.mli
new file mode 100644
index 000000000..20224552e
--- /dev/null
+++ b/src/bin/options.mli
@@ -0,0 +1,66 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Command line options *)
+
+
+(** {2 Type definitions} *)
+
+type language = Witan_solver.Input.language
+(** Type of format input (taken from dolmen). *)
+
+type input_options = {
+ dir : string;
+ file : string;
+ language : language option;
+}
+(** The various input options. *)
+
+type t = {
+
+ input : input_options;
+
+ (* typing *)
+ type_only : bool;
+
+ (* Time/Memory options *)
+ time_limit : float;
+ size_limit : float;
+
+ (* Step options *)
+ step_limit : int;
+
+ (* seed for shuffling *)
+ seed_shuffle : int option;
+
+ (* debug flags *)
+ debug_flags : Witan_popop_lib.Debug.flag list;
+}
+(** The aggregate type for all command line options *)
+
+
+(** {2 Parsing command line} *)
+
+val all : t Cmdliner.Term.t
+(** The cdmliner term for parsing all command line options. *)
+
+val info : Cmdliner.Term.info
+(** The cmdliner info for parsing command line (includes bin name, version, etc..) *)
+
diff --git a/src/bin/typecheck.ml b/src/bin/typecheck.ml
new file mode 100644
index 000000000..179c03c98
--- /dev/null
+++ b/src/bin/typecheck.ml
@@ -0,0 +1,936 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(* Log&Module Init *)
+(* ************************************************************************ *)
+
+module Id = Dolmen.Id
+module Ast = Dolmen.Term
+
+module I = Witan_core.Id
+module Term = Witan_core.Term
+
+let get_loc =
+ let default_loc = Dolmen.ParseLocation.mk "<?>" 0 0 0 0 in
+ (fun t -> CCOpt.get_or ~default:default_loc t.Ast.loc)
+
+module E = Map.Make(Term.Id)
+module R = Hashtbl.Make(Term.Id)
+
+(* Fuzzy search maps *)
+(* ************************************************************************ *)
+
+module M = struct
+
+ module S = Spelll
+ module I = S.Index
+
+ (** We use fuzzy maps in order to give suggestions in case of typos.
+ Since such maps are not trivial to extend to Dolmen identifiers,
+ we map strings (identifier names) to list of associations. *)
+ type 'a t = (Id.t * 'a) list I.t
+
+ let eq = Id.equal
+
+ let empty = I.empty
+
+ let get t id =
+ let s = Id.(id.name) in
+ match S.klist_to_list (I.retrieve ~limit:0 t s) with
+ | [l] -> l
+ | [] -> []
+ | _ -> assert false
+
+ let mem id t =
+ CCList.Assoc.mem ~eq id (get t id)
+
+ let find id t =
+ CCList.Assoc.get_exn ~eq id (get t id)
+
+ let add id v t =
+ let l = get t id in
+ let l' = CCList.Assoc.set ~eq id v l in
+ I.add t Dolmen.Id.(id.name) l'
+
+ let iter f t =
+ I.iter (fun _ l -> List.iter (fun (id, v) -> f id v) l) t
+
+ (** Return a list of suggestions for an identifier. *)
+ let suggest ~limit id t =
+ let s = Id.(id.name) in
+ let l = S.klist_to_list (I.retrieve ~limit t s) in
+ CCList.flat_map (List.map fst) l
+
+end
+
+(* Fuzzy search hashtables *)
+(* ************************************************************************ *)
+
+module H = struct
+
+ (** Fuzzy hashtables are just references to fuzzy maps.
+ The reference is registered on the stack to allow backtracking. *)
+ let create () =
+ let r = ref M.empty in
+ r
+
+ let mem r id = M.mem id !r
+
+ let find r id = M.find id !r
+
+ let suggest r id = M.suggest id !r
+
+ let add r id v =
+ r := M.add id v !r
+
+end
+
+(* Types *)
+(* ************************************************************************ *)
+
+(* The type of reasons for constant typing *)
+type reason =
+ | Inferred of Dolmen.ParseLocation.t
+ | Declared of Dolmen.ParseLocation.t
+
+(* The local environments used for type-checking. *)
+type env = {
+
+ (* Map from term identifiers to the reason of their type
+ (either definition location, or inference location) *)
+ locs : reason E.t;
+
+ (* Bound variables, either let-bound, or quantified. *)
+ vars : Term.t M.t;
+
+ (* The current builtin symbols *)
+ builtins : builtin_symbols;
+
+ (* Additional typing info *)
+ expect : Term.t option; (** Expected type of the term to parse *)
+ explain : [ `No | `Yes | `Full ];
+}
+
+(* Builtin symbols, i.e symbols understood by some theories,
+ but which do not have specific syntax, so end up as special
+ cases of application. *)
+and builtin_symbols = env -> Dolmen.Term.t -> Dolmen.Id.t -> Ast.t list -> Term.t option
+
+(* Global Environment *)
+(* ************************************************************************ *)
+
+(* Global identifier table; stores declared types and aliases.
+ global locations : stores reason for typing of identifiers *)
+let global_env = H.create ()
+let global_locs = R.create 4013
+
+let find_global name =
+ try H.find global_env name
+ with Not_found -> `Not_found
+
+(* Symbol declarations *)
+let decl_id id c reason =
+ (* TODO: uncomment
+ if H.mem global_env id then
+ Util.warn ~section
+ "Symbol '%a' has already been defined, overwriting previous definition"
+ Id.print id;
+ *)
+ H.add global_env id (`Id c);
+ R.add global_locs c reason
+
+(* Symbol definitions *)
+let def_id id args body =
+ (* TODO: uncomment
+ if H.mem global_env id then
+ Util.warn ~section
+ "Symbol '%a' has already been defined, overwriting previous definition"
+ Id.print id;
+ *)
+ H.add global_env id (`Alias (args, body))
+
+
+(* Local Environment *)
+(* ************************************************************************ *)
+
+(* Make a new empty environment *)
+let empty_env
+ ?(expect=None)
+ ?(explain=`No)
+ builtins = {
+ locs = E.empty;
+ vars = M.empty;
+ builtins; expect; explain;
+}
+
+let expect ?(force=false) env expect =
+ if env.expect = None && not force then env
+ else { env with expect = expect }
+
+(* Generate new fresh names for shadowed variables *)
+let new_name pre =
+ let i = ref 0 in
+ (fun () -> incr i; pre ^ (string_of_int !i))
+
+let new_term_name = new_name "t#"
+
+(* Add local bound variables to env *)
+let add_let_term env id t =
+ { env with vars = M.add id t env.vars }
+
+(* Add local variables to environment *)
+let add_term_var env id v loc =
+ let v' =
+ if M.mem id env.vars then
+ I.mk (new_term_name ()) (I.ty v)
+ else
+ v
+ in
+ let t = Term.const v' in
+ v', { env with
+ vars = M.add id t env.vars;
+ locs = E.add v' (Declared loc) env.locs;
+ }
+
+let find_var env name =
+ try Some (M.find name env.vars)
+ with Not_found -> None
+
+(* Printing *)
+let print_expect fmt = function
+ | None -> Format.fprintf fmt "<>"
+ | Some ty -> Term.print fmt ty
+
+let print_map print fmt map =
+ let aux k v =
+ Format.fprintf fmt "%a ->@ @[<hov>%a@];@ " Id.print k print v
+ in
+ M.iter aux map
+
+let pp_env fmt env =
+ Format.fprintf fmt "@[<hov 2>(%a) %a%a%a%a@]"
+ print_expect env.expect (print_map Term.print) env.vars
+
+(* Typo suggestion *)
+(* ************************************************************************ *)
+
+let suggest ~limit env fmt id =
+ let l =
+ M.suggest ~limit id env.vars @
+ H.suggest ~limit global_env id
+ in
+ if l = [] then
+ Format.fprintf fmt "coming up empty, sorry, ^^"
+ else
+ CCFormat.list Id.print fmt l
+
+(* Typing explanation *)
+(* ************************************************************************ *)
+
+let get_reason_loc = function Inferred l | Declared l -> l
+
+let pp_reason fmt = function
+ | Inferred loc -> Format.fprintf fmt "inferred at %a" Dolmen.ParseLocation.fmt loc
+ | Declared loc -> Format.fprintf fmt "declared at %a" Dolmen.ParseLocation.fmt loc
+
+let find_reason env v =
+ try E.find v env.locs
+ with Not_found -> R.find global_locs v
+
+let rec explain ~full env fmt t =
+ try
+ begin match t with
+ | { Term.term = Term.Type; _ } ->
+ Format.fprintf fmt "Type: Type"
+ | { Term.term = Term.Id v; _ } ->
+ let reason = find_reason env v in
+ Format.fprintf fmt "%a: %a was %a@\n" I.print v Term.print (I.ty v) pp_reason reason
+ | { Term.term = Term.App (f, t); _ } ->
+ explain ~full env fmt f;
+ if full then explain ~full env fmt t
+ | { Term.term = Term.Let (v, e, body); _ } ->
+ Format.fprintf fmt "Term let-bound to %a was typed %a@\n"
+ I.print v Term.print e.Term.ty
+ | { Term.term = Term.Binder (_, _, t); _ } ->
+ explain ~full env fmt t
+ end with
+ | Not_found ->
+ Format.fprintf fmt "Couldn't find a typing reason (that's a bug !)"
+
+(* Exceptions *)
+(* ************************************************************************ *)
+
+(* Internal exception *)
+exception Found of Ast.t * Term.t option
+
+(* Exception for typing errors *)
+exception Typing_error of string * env * Ast.t
+
+(* Creating explanations *)
+let mk_expl preface env fmt t =
+ match env.explain with
+ | `No -> ()
+ | `Yes ->
+ Format.fprintf fmt "%s\n%a" preface (explain ~full:false env) t
+ | `Full ->
+ Format.fprintf fmt "%s\n%a" preface (explain ~full:true env) t
+
+(* Convenience functions *)
+let _infer_var env t =
+ let msg = Format.asprintf
+ "Inferring type for a variable, please check the scope of your quantifications"
+ in
+ raise (Typing_error (msg, env, t))
+
+let _expected env s t res =
+ let msg = match res with
+ | None -> "the expression doesn't match what was expected"
+ | Some r ->
+ let ty = r.Term.ty in
+ let tmp =
+ match r with
+ | { Term.term = Term.Type; _} -> "the Ttype constant"
+ | _ when Term.equal ty Term._Type -> "a type"
+ | _ when Term.equal ty Term._Prop -> "a first-order formula"
+ | _ -> "a first-order term"
+ in
+ Format.sprintf "got %s" tmp
+ in
+ let msg = Format.asprintf "Expected a %s, but %s" s msg in
+ raise (Typing_error (msg, env, t))
+
+let _bad_op_arity env s n t =
+ let msg = Format.asprintf "Bad arity for operator '%s' (expected %d arguments)" s n in
+ raise (Typing_error (msg, env, t))
+
+let _bad_id_arity env id n t =
+ let msg = Format.asprintf
+ "Bad arity for identifier '%a' (expected %d arguments)" Id.print id n
+ in
+ raise (Typing_error (msg, env, t))
+
+let _bad_term_arity env f n t =
+ let msg = Format.asprintf
+ "Bad arity for function '%a' (expected %d arguments)" I.print f n
+ in
+ raise (Typing_error (msg, env, t))
+
+let _fo_let env s t =
+ let msg = Format.asprintf "Let-bound variable '%a' is applied to terms" Id.print s in
+ raise (Typing_error (msg, env, t))
+
+let _fo_formula env f ast =
+ let msg = Format.asprintf "Cannot apply formula '%a' to arguments" Term.print f in
+ raise (Typing_error (msg, env, ast))
+
+let _type_mismatch env t ty ty' ast =
+ let msg = Format.asprintf
+ "Type Mismatch: an expression of type %a was expected, but '%a' has type %a%a"
+ Term.print ty' Term.print t Term.print ty (mk_expl ", because:" env) t
+ in
+ raise (Typing_error (msg, env, ast))
+
+let _cannot_unify env ast ty t =
+ let msg = Format.asprintf
+ "A term of type '%a'@ was expected, but could not unify it with@ %a:@ %a"
+ Term.print ty Term.print t Term.print t.Term.ty
+ in
+ raise (Typing_error (msg, env, ast))
+
+let _cannot_infer_quant_var env t =
+ raise (Typing_error ("Cannot infer the type of a quantified variable", env, t))
+
+(* Wrappers for expression building *)
+(* ************************************************************************ *)
+
+(* Generate fresh variables for wildcards in types. *)
+let gen_wildcard =
+ let i = ref 0 in
+ (function () -> (* TODO: add location information? *)
+ incr i; I.mk (Format.sprintf "?%d" !i) Term._Type)
+
+let wildcard =
+ (fun env ast id l ->
+ match l with
+ | [] ->
+ let v = gen_wildcard () in
+ Term.const v
+ | _ -> _bad_id_arity env id 0 ast
+ )
+
+(* Wrapper around term application. Since wildcards are allowed in types,
+ there may be some variables in [ty_args], so we have to find an appropriate
+ substitution for these variables. To do that, we try and unify the expected type
+ and the actual argument types. *)
+let term_apply env ast f ty_args t_args =
+ if List.length Expr.(f.id_type.fun_vars) <> List.length ty_args ||
+ List.length Expr.(f.id_type.fun_args) <> List.length t_args then
+ _bad_term_arity env f (arity f) ast
+ else
+ let map =
+ List.fold_left2
+ Mapping.Var.bind_ty Mapping.empty
+ Expr.(f.id_type.fun_vars) ty_args
+ in
+ let expected_types =
+ List.map (Mapping.apply_ty map) Expr.(f.id_type.fun_args)
+ in
+ let subst =
+ List.fold_left2 (fun subst expected term ->
+ try
+ Unif.Robinson.ty subst expected Expr.(term.t_type)
+ with
+ | Unif.Robinson.Impossible_ty _ ->
+ _cannot_unify env ast expected term
+ ) map expected_types t_args
+ in
+ let actual_ty_args = List.map (Mapping.apply_ty subst) ty_args in
+ try
+ Expr.Term.apply ~status:env.status f actual_ty_args t_args
+ with
+ | Expr.Bad_arity _ | Expr.Type_mismatch _ ->
+ Util.debug ~section "%a, typing:@\n %a :: %a :: %a@\nsubst: %a"
+ Dolmen.ParseLocation.fmt (get_loc ast) Expr.Print.const_ty f
+ (CCFormat.list Expr.Print.ty) ty_args
+ (CCFormat.list Expr.Print.term) t_args
+ Mapping.print subst;
+ assert false
+
+let ty_subst env ast_term id args f_args body =
+ match List.fold_left2 Expr.Subst.Id.bind Expr.Subst.empty f_args args with
+ | subst ->
+ Expr.Ty.subst subst Expr.Subst.empty body
+ | exception Invalid_argument _ ->
+ _bad_id_arity env id (List.length f_args) ast_term
+
+let term_subst env ast_term id ty_args t_args f_ty_args f_t_args body =
+ match List.fold_left2 Expr.Subst.Id.bind Expr.Subst.empty f_ty_args ty_args with
+ | ty_subst ->
+ begin
+ match List.fold_left2 Expr.Subst.Id.bind Expr.Subst.empty f_t_args t_args with
+ | t_subst ->
+ Expr.Term.subst ty_subst Expr.Subst.empty t_subst Expr.Subst.empty body
+ | exception Invalid_argument _ ->
+ _bad_id_arity env id (List.length f_ty_args + List.length f_t_args) ast_term
+ end
+ | exception Invalid_argument _ ->
+ _bad_id_arity env id (List.length f_ty_args + List.length f_t_args) ast_term
+
+let make_eq env ast_term a b =
+ try
+ Expr.Formula.eq a b
+ with Expr.Type_mismatch (t, ty, ty') ->
+ _type_mismatch env t ty ty' ast_term
+
+let make_pred env ast_term p =
+ try
+ Expr.Formula.pred p
+ with Expr.Type_mismatch (t, ty, ty') ->
+ _type_mismatch env t ty ty' ast_term
+
+let mk_quant_ty env mk vars body =
+ (* Check that all quantified variables are actually used *)
+ let fv_ty, fv_t = Expr.Formula.fv body in
+ let unused = List.filter (fun v -> not @@ CCList.mem ~eq:Expr.Id.equal v fv_ty) vars in
+ List.iter (fun v ->
+ Util.warn "%a:@\nQuantified variables unused: %a"
+ Dolmen.ParseLocation.fmt (get_reason_loc (E.find v env.type_locs))
+ Expr.Print.id v) unused;
+ mk vars body
+
+let mk_quant_term env mk vars body =
+ (* Check that all quantified variables are actually used *)
+ let fv_ty, fv_t = Expr.Formula.fv body in
+ let unused = List.filter (fun v -> not @@ CCList.mem ~eq:Expr.Id.equal v fv_t) vars in
+ List.iter (fun v ->
+ Util.warn "%a:@\nQuantified variables unused: %a"
+ Dolmen.ParseLocation.fmt (get_reason_loc (F.find v env.term_locs))
+ Expr.Print.id v) unused;
+ mk vars body
+
+let promote env ast t =
+ match t with
+ | Term t when Expr.(Ty.equal Ty.prop t.t_type) ->
+ Formula (make_pred env ast t)
+ | _ -> t
+
+let infer env ast s args loc =
+ if Dolmen.Id.(s.ns = Var) then _infer_var env ast;
+ match env.expect with
+ | Nothing -> None
+ | Type ->
+ let n = List.length args in
+ let ret = Expr.Id.ty_fun (Id.full_name s) n in
+ let res = Ty_fun ret in
+ env.infer_hook env res;
+ decl_ty_cstr s ret (Inferred loc);
+ Some res
+ | Typed ty ->
+ let n = List.length args in
+ let ret = Expr.Id.term_fun (Id.full_name s) [] (CCList.replicate n Expr.Ty.base) ty in
+ let res = Term_fun ret in
+ env.infer_hook env res;
+ decl_term s ret (Inferred loc);
+ Some res
+
+
+(* Tag application *)
+(* ************************************************************************ *)
+
+let apply_tag env ast tag v = function
+ | Ttype -> raise (Typing_error ("Cannot tag Ttype", env, ast))
+ | Tags _ -> raise (Typing_error ("Cannot tag a tag list", env, ast))
+ | Ty ty -> Expr.Ty.tag ty tag v
+ | Term t -> Expr.Term.tag t tag v
+ | Formula f -> Expr.Formula.tag f tag v
+
+(* Expression parsing *)
+(* ************************************************************************ *)
+
+let rec parse_expr (env : env) t =
+ Util.debug ~section
+ "parsing: @[<hov>%a@]@\nin env: @[<hov>%a@]"
+ Ast.print t pp_env env;
+ let res = match t with
+
+ (* Ttype & builtin types *)
+ | { Ast.term = Ast.Builtin Ast.Ttype } ->
+ Ttype
+ | { Ast.term = Ast.Builtin Ast.Prop } ->
+ Ty Expr.Ty.prop
+
+ (* Wildcards (only allowed in types *)
+ | { Ast.term = Ast.Builtin Ast.Wildcard } ->
+ Ty (Expr.Ty.of_id (gen_wildcard ()))
+
+ (* Basic formulas *)
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Builtin Ast.True }, []) }
+ | { Ast.term = Ast.Builtin Ast.True } ->
+ Formula Expr.Formula.f_true
+
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Builtin Ast.False }, []) }
+ | { Ast.term = Ast.Builtin Ast.False } ->
+ Formula Expr.Formula.f_false
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.And}, l) } ->
+ Formula (Expr.Formula.f_and (List.map (parse_formula env) l))
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Or}, l) } ->
+ Formula (Expr.Formula.f_or (List.map (parse_formula env) l))
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Xor}, l) } as t ->
+ begin match l with
+ | [p; q] ->
+ let f = parse_formula env p in
+ let g = parse_formula env q in
+ Formula (Expr.Formula.neg (Expr.Formula.equiv f g))
+ | _ -> _bad_op_arity env "xor" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Imply}, l) } as t ->
+ begin match l with
+ | [p; q] ->
+ let f = parse_formula env p in
+ let g = parse_formula env q in
+ Formula (Expr.Formula.imply f g)
+ | _ -> _bad_op_arity env "=>" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Equiv}, l) } as t ->
+ begin match l with
+ | [p; q] ->
+ let f = parse_formula env p in
+ let g = parse_formula env q in
+ Formula (Expr.Formula.equiv f g)
+ | _ -> _bad_op_arity env "<=>" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Not}, l) } as t ->
+ begin match l with
+ | [p] ->
+ Formula (Expr.Formula.neg (parse_formula env p))
+ | _ -> _bad_op_arity env "not" 1 t
+ end
+
+ (* Binders *)
+ | { Ast.term = Ast.Binder (Ast.All, vars, f) } ->
+ let ttype_vars, ty_vars, env' =
+ parse_quant_vars (expect env (Typed Expr.Ty.base)) vars in
+ Formula (
+ mk_quant_ty env' Expr.Formula.allty ttype_vars
+ (mk_quant_term env' Expr.Formula.all ty_vars
+ (parse_formula env' f)))
+
+ | { Ast.term = Ast.Binder (Ast.Ex, vars, f) } ->
+ let ttype_vars, ty_vars, env' =
+ parse_quant_vars (expect env (Typed Expr.Ty.base)) vars in
+ Formula (
+ mk_quant_ty env' Expr.Formula.exty ttype_vars
+ (mk_quant_term env' Expr.Formula.ex ty_vars
+ (parse_formula env' f)))
+
+ (* (Dis)Equality *)
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Eq}, l) } as t ->
+ begin match l with
+ | [a; b] ->
+ begin match promote env t @@ parse_expr env a,
+ promote env t @@ parse_expr env b with
+ | Term t1, Term t2 ->
+ Formula (make_eq env t t1 t2)
+ | Formula f1, Formula f2 ->
+ Formula (Expr.Formula.equiv f1 f2)
+ | _ ->
+ _expected env "either two terms or two formulas" t None
+ end
+ | _ -> _bad_op_arity env "=" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Distinct}, args) } as t ->
+ let l' = List.map (parse_term env) args in
+ let l'' = CCList.diagonal l' in
+ let l''' = List.map (fun (a, b) -> Expr.Formula.neg (make_eq env t a b)) l'' in
+ let f = match l''' with
+ | [f] -> f
+ | _ -> Expr.Formula.f_and l'''
+ in
+ Formula f
+
+ (* General case: application *)
+ | { Ast.term = Ast.Symbol s } as ast ->
+ parse_app env ast s []
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Symbol s }, l) } as ast ->
+ parse_app env ast s l
+
+ (* Local bindings *)
+ | { Ast.term = Ast.Binder (Ast.Let, vars, f) } ->
+ parse_let env f vars
+
+ (* Other cases *)
+ | ast -> raise (Typing_error ("Unexpected construction", env, ast))
+ in
+ apply_attr env res t t.Ast.attr
+
+and apply_attr env res ast l =
+ let () = List.iter (function
+ | Any (tag, v) ->
+ apply_tag env ast tag v res;
+ ) (parse_attrs env ast [] l) in
+ res
+
+and parse_attr_and env ast =
+ match ast with
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Builtin Ast.And}, l) } ->
+ parse_attrs env ast [] l
+ | _ -> parse_attrs env ast [] [ast]
+
+and parse_attrs env ast acc = function
+ | [] -> acc
+ | a :: r ->
+ begin match parse_expr (expect env Nothing) a with
+ | Tags l ->
+ parse_attrs env ast (l @ acc) r
+ | res ->
+ _expected env "tag" a (Some res)
+ | exception (Typing_error (msg, _, t)) ->
+ Util.warn ~section "%a while parsing an attribute:@\n%s"
+ Dolmen.ParseLocation.fmt (get_loc t) msg;
+ parse_attrs env ast acc r
+ end
+
+and parse_var env = function
+ | { Ast.term = Ast.Colon ({ Ast.term = Ast.Symbol s }, e) } ->
+ begin match parse_expr env e with
+ | Ttype -> `Ty (s, Expr.Id.ttype (Id.full_name s))
+ | Ty ty -> `Term (s, Expr.Id.ty (Id.full_name s) ty)
+ | res -> _expected env "type (or Ttype)" e (Some res)
+ end
+ | { Ast.term = Ast.Symbol s } as t ->
+ begin match env.expect with
+ | Nothing -> _cannot_infer_quant_var env t
+ | Type -> `Ty (s, Expr.Id.ttype (Id.full_name s))
+ | Typed ty -> `Term (s, Expr.Id.ty (Id.full_name s) ty)
+ end
+ | t -> _expected env "(typed) variable" t None
+
+and parse_quant_vars env l =
+ let ttype_vars, typed_vars, env' = List.fold_left (
+ fun (l1, l2, acc) v ->
+ match parse_var acc v with
+ | `Ty (id, v') ->
+ let v'', acc' = add_type_var acc id v' (get_loc v) in
+ (v'' :: l1, l2, acc')
+ | `Term (id, v') ->
+ let v'', acc' = add_term_var acc id v' (get_loc v) in
+ (l1, v'' :: l2, acc')
+ ) ([], [], env) l in
+ List.rev ttype_vars, List.rev typed_vars, env'
+
+and parse_let env f = function
+ | [] -> parse_expr env f
+ | x :: r ->
+ begin match x with
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Eq}, [
+ { Ast.term = Ast.Symbol s }; e]) } ->
+ let t = parse_term env e in
+ let env' = add_let_term env s t in
+ parse_let env' f r
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Equiv}, [
+ { Ast.term = Ast.Symbol s }; e]) } ->
+ let t = parse_formula env e in
+ let env' = add_let_prop env s t in
+ parse_let env' f r
+ | { Ast.term = Ast.Colon ({ Ast.term = Ast.Symbol s }, e) } ->
+ begin match parse_expr env e with
+ | Term t ->
+ let env' = add_let_term env s t in
+ parse_let env' f r
+ | Formula t ->
+ let env' = add_let_prop env s t in
+ parse_let env' f r
+ | res -> _expected env "term or formula" e (Some res)
+ end
+ | t -> _expected env "let-binding" t None
+ end
+
+and parse_app env ast s args =
+ match find_let env s with
+ | `Term t ->
+ if args = [] then Term t
+ else _fo_let env s ast
+ | `Prop p ->
+ if args = [] then Formula p
+ else _fo_let env s ast
+ | `Not_found ->
+ begin match find_var env s with
+ | `Ty f ->
+ if args = [] then Ty (Expr.Ty.of_id f)
+ else _fo_let env s ast
+ | `Term f ->
+ if args = [] then Term (Expr.Term.of_id f)
+ else _fo_let env s ast
+ | `Not_found ->
+ begin match find_global s with
+ | `Ty f ->
+ parse_app_ty env ast f args
+ | `Term f ->
+ parse_app_term env ast f args
+ | `Ty_alias (f_args, body) ->
+ parse_app_subst_ty env ast s args f_args body
+ | `Term_alias (f_ty_args, f_t_args, body) ->
+ parse_app_subst_term env ast s args f_ty_args f_t_args body
+ | `Not_found ->
+ begin match env.builtins env ast s args with
+ | Some res -> res
+ | None ->
+ begin match infer env ast s args (get_loc ast) with
+ | Some Ty_fun f -> parse_app_ty env ast f args
+ | Some Term_fun f -> parse_app_term env ast f args
+ | None ->
+ Util.error ~section
+ "Looking up '%a' failed, possibilities were:@ @[<hov>%a@]"
+ Id.print s (suggest ~limit:1 env) s;
+ raise (Typing_error (
+ Format.asprintf "Scoping error: '%a' not found" Id.print s, env, ast))
+ end
+ end
+ end
+ end
+
+and parse_app_ty env ast f args =
+ let l = List.map (parse_ty env) args in
+ Ty (ty_apply env ast f l)
+
+and parse_app_term env ast f args =
+ let n_args = List.length args in
+ let n_ty = List.length Expr.(f.id_type.fun_vars) in
+ let n_t = List.length Expr.(f.id_type.fun_args) in
+ let ty_l, t_l =
+ if n_args = n_ty + n_t then
+ CCList.take_drop n_ty args
+ else if n_args = n_t then
+ (CCList.replicate n_ty Dolmen.Term.wildcard, args)
+ else
+ _bad_term_arity env f (n_ty + n_t) ast
+ in
+ let ty_args = List.map (parse_ty env) ty_l in
+ let t_args = List.map (parse_term env) t_l in
+ Term (term_apply env ast f ty_args t_args)
+
+and parse_app_formula env ast f args =
+ if args = [] then Formula f
+ else _fo_formula env f ast
+
+and parse_app_subst_ty env ast id args f_args body =
+ let l = List.map (parse_ty env) args in
+ Ty (ty_subst env ast id l f_args body)
+
+and parse_app_subst_term env ast id args f_ty_args f_t_args body =
+ let n = List.length f_ty_args in
+ let ty_l, t_l = CCList.take_drop n args in
+ let ty_args = List.map (parse_ty env) ty_l in
+ let t_args = List.map (parse_term env) t_l in
+ Term (term_subst env ast id ty_args t_args f_ty_args f_t_args body)
+
+and parse_ty env ast =
+ match parse_expr (expect env Type) ast with
+ | Ty ty -> ty
+ | res -> _expected env "type" ast (Some res)
+
+and parse_term env ast =
+ match parse_expr (expect env (Typed Expr.Ty.base)) ast with
+ | Term t -> t
+ | res -> _expected env "term" ast (Some res)
+
+and parse_formula env ast =
+ match promote env ast @@ parse_expr (expect env (Typed Expr.Ty.prop)) ast with
+ | Formula p -> p
+ | res -> _expected env "formula" ast (Some res)
+
+let parse_ttype_var env t =
+ match parse_var (expect ~force:true env Type) t with
+ | `Ty (id, v) -> (id, v, get_loc t)
+ | `Term (_, v) ->
+ _expected env "type variable" t (Some (Term (Expr.Term.of_id v)))
+
+let rec parse_sig_quant env = function
+ | { Ast.term = Ast.Binder (Ast.Pi, vars, t) } ->
+ let ttype_vars = List.map (parse_ttype_var env) vars in
+ let ttype_vars', env' = add_type_vars env ttype_vars in
+ let l = List.combine vars ttype_vars' in
+ parse_sig_arrow l [] env' t
+ | t ->
+ parse_sig_arrow [] [] env t
+
+and parse_sig_arrow ttype_vars (ty_args: (Ast.t * res) list) env = function
+ | { Ast.term = Ast.Binder (Ast.Arrow, args, ret) } ->
+ let t_args = parse_sig_args env args in
+ parse_sig_arrow ttype_vars (ty_args @ t_args) env ret
+ | t ->
+ begin match parse_expr env t with
+ | Ttype ->
+ begin match ttype_vars with
+ | (h, _) :: _ ->
+ raise (Typing_error (
+ "Type constructor signatures cannot have quantified type variables", env, h))
+ | [] ->
+ let aux n = function
+ | (_, Ttype) -> n + 1
+ | (ast, res) -> raise (Found (ast, res))
+ in
+ begin
+ match List.fold_left aux 0 ty_args with
+ | n -> `Ty_cstr n
+ | exception Found (err, _) ->
+ raise (Typing_error (
+ Format.asprintf
+ "Type constructor signatures cannot have non-ttype arguments,", env, err))
+ end
+ end
+ | Ty ret ->
+ let aux acc = function
+ | (_, Ty t) -> t :: acc
+ | (ast, res) -> raise (Found (ast, res))
+ in
+ begin
+ match List.fold_left aux [] ty_args with
+ | exception Found (err, res) -> _expected env "type" err (Some res)
+ | l -> `Fun_ty (List.map snd ttype_vars, List.rev l, ret)
+ end
+ | res -> _expected env "Ttype of type" t (Some res)
+ end
+
+and parse_sig_args env l =
+ CCList.flat_map (parse_sig_arg env) l
+
+and parse_sig_arg env = function
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Builtin Ast.Product}, l) } ->
+ List.map (fun x -> x, parse_expr env x) l
+ | t ->
+ [t, parse_expr env t]
+
+let parse_sig = parse_sig_quant
+
+let rec parse_fun ty_args t_args env = function
+ | { Ast.term = Ast.Binder (Ast.Fun, l, ret) } ->
+ let ty_args', t_args', env' = parse_quant_vars env l in
+ parse_fun (ty_args @ ty_args') (t_args @ t_args') env' ret
+ | ast ->
+ begin match parse_expr env ast with
+ | (Ty body) as res ->
+ if t_args = [] then `Ty (ty_args, body)
+ else _expected env "non_dependant type (or a term)" ast (Some res)
+ | Term body -> `Term (ty_args, t_args, body)
+ | res -> _expected env "term or a type" ast (Some res)
+ end
+
+(* High-level parsing functions *)
+(* ************************************************************************ *)
+
+let new_decl env t ?attr id =
+ Util.enter_prof section;
+ Util.debug ~section "Typing declaration:@ @[<hov>%a :@ %a@]"
+ Id.print id Ast.print t;
+ let aux acc (Any (tag, v)) = Tag.add acc tag v in
+ let tags =
+ CCOpt.map (fun a ->
+ Util.debug ~section "Typing attribute:@ @[<hov>%a@]" Ast.print a;
+ let l = parse_attr_and env a in
+ List.fold_left aux Tag.empty l) attr
+ in
+ let res =
+ match parse_sig env t with
+ | `Ty_cstr n ->
+ let c = Expr.Id.ty_fun ?tags (Id.full_name id) n in
+ decl_ty_cstr id c (Declared (get_loc t));
+ `Type_decl c
+ | `Fun_ty (vars, args, ret) ->
+ let f = Expr.Id.term_fun ?tags (Id.full_name id) vars args ret in
+ decl_term id f (Declared (get_loc t));
+ `Term_decl f
+ in
+ Util.exit_prof section;
+ res
+
+let new_def env t ?attr id =
+ Util.enter_prof section;
+ Util.debug ~section "Typing definition:@ @[<hov>%a =@ %a@]"
+ Id.print id Ast.print t;
+ let res =
+ match parse_fun [] [] env t with
+ | `Ty (ty_args, body) ->
+ def_ty id ty_args body;
+ `Type_def (id, ty_args, body)
+ | `Term (ty_args, t_args, body) ->
+ def_term id ty_args t_args body;
+ `Term_def (id, ty_args, t_args, body)
+ in
+ Util.exit_prof section;
+ res
+
+let new_formula env t =
+ Util.enter_prof section;
+ Util.debug ~section "Typing top-level formula:@ %a" Ast.print t;
+ let res = parse_formula env t in
+ Util.exit_prof section;
+ res
+
diff --git a/src/bin/witan.ml b/src/bin/witan.ml
new file mode 100644
index 000000000..f250b7564
--- /dev/null
+++ b/src/bin/witan.ml
@@ -0,0 +1,61 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+let theories = Witan_theories_bool.[Boolean.th_register; Equality.th_register; Uninterp.th_register ]
+
+
+let () =
+ if not Witan_core.(Egraph.check_initialization () &&
+ Conflict.check_initialization ()) then
+ exit 1
+
+
+let one_file opts file =
+ (* Parse input *)
+ let statements = Witan_solver.Input.read
+ ?language:Options.(opts.input.language)
+ ~dir:Options.(opts.input.dir)
+ file
+ in
+ if opts.Options.type_only then exit 0;
+ let res =
+ Witan_solver.Notypecheck.run
+ ?limit:(if opts.Options.step_limit < 0 then None else Some opts.Options.step_limit)
+ ~theories statements in
+ match res with
+ | `Unsat -> Printf.printf "unsat\n"
+ | `Sat -> Printf.printf "sat\n"
+
+let () =
+ (* Parse command line options *)
+ let opts = match Cmdliner.Term.eval (Options.all, Options.info) with
+ | `Version | `Help -> exit 0
+ | `Error `Parse
+ | `Error `Term
+ | `Error `Exn -> exit 1
+ | `Ok opts -> opts
+ in
+ List.iter (fun f -> Witan_popop_lib.Debug.set_flag f) opts.Options.debug_flags;
+ Witan_popop_lib.Debug.(if test_flag stack_trace then Printexc.record_backtrace true);
+ begin match opts.Options.seed_shuffle with
+ | None -> Witan_stdlib.Shuffle.set_shuffle None;
+ | Some i -> Witan_stdlib.Shuffle.set_shuffle (Some [|i|]);
+ end;
+ one_file opts Options.(opts.input.file)
diff --git a/src/bool.ml b/src/bool.ml
deleted file mode 100644
index dcd6864c7..000000000
--- a/src/bool.ml
+++ /dev/null
@@ -1,850 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Stdlib
-open Types
-open Solver
-
-let lazy_propagation = false
-
-let debug = Debug.register_info_flag
- ~desc:"for the boolean theory"
- "bool"
-
-let ty_ctr = Ty.Constr.create "Bool"
-let ty = Ty.ctr ty_ctr
-let dom : bool dom = Conflict.dom_bool
-let cl_true = Cl.fresh "⊤" ty
-let cl_false = Cl.fresh "⊥" ty
-
-let union_disjoint m1 m2 =
- Cl.M.union (fun _ b1 b2 -> assert (b1 == b2); Some b1) m1 m2
-
-let index sem v = Cl.index sem v ty
-
-let with_other = ref false
-(** TODO not a global variable...
- merge the element that are true instead of using only the dom.
- false by default
-*)
-
-
-let is env cl = Solver.Delayed.get_dom env dom cl
-let is_true env cl = Cl.equal cl cl_true || is env cl = Some true
-let is_false env cl = Cl.equal cl cl_false || is env cl = Some false
-let is_unknown env cl = is env cl = None
-
-module D = struct
- type t = bool
- let merged b1 b2 = Opt.equal (==) b1 b2
-
- type expmerge =
- | Merge of Explanation.pexp * Cl.t * Cl.t
- | DomMerge of Explanation.pexp * Cl.t
-
- let expmerge : expmerge Explanation.exp =
- Explanation.Exp.create_key "Bool.merge"
-
- let true_is_false d cl pexp =
- let pexp = Delayed.mk_pexp d expmerge (DomMerge(pexp,cl)) in
- Delayed.contradiction d pexp
-
- let set_bool env pexp cl b =
- if !with_other then
- Delayed.merge env pexp cl
- (if b then cl_true else cl_false)
- else
- match Delayed.get_dom env dom cl with
- | Some b' when DBool.equal b b' -> ()
- | Some _ ->
- true_is_false env cl pexp
- | None ->
- Delayed.set_dom env pexp dom cl b
-
- let merge d pexp ((b1: t option),cl1) ((b2: t option),cl2) _ =
- match b1,b2 with
- | Some b1, Some b2 when b1 == b2 -> ()
- | Some _, Some _ ->
- let pexp = Delayed.mk_pexp d expmerge (Merge(pexp,cl1,cl2)) in
- Delayed.contradiction d pexp
- | None, Some b ->
- Delayed.set_dom_premerge d dom cl1 b
- | Some b, None ->
- Delayed.set_dom_premerge d dom cl2 b
- | None, None -> assert false
-
- let print fmt b = Format.pp_print_bool fmt b
- let key = dom
-end
-
-let true_is_false = D.true_is_false
-let set_bool = D.set_bool
-module DE = RegisterDom(D)
-
-type t =
- { topnot: bool;
- lits: (Cl.t * bool) IArray.t;
- }
-
-let sem : t sem = Sem.create_key "Prop"
-
-(* let iter f x = IArray.iter f x.lits *)
-
-let fold f acc x = IArray.fold f acc x.lits
-
-let isnot v =
- if IArray.length v.lits == 1 then
- let cl,sign = IArray.get v.lits 0 in
- assert (v.topnot && not sign);
- Some cl
- else
- None
-
-let mulbool b1 b2 = b1 != b2
-
-module T = struct
- type r = t
- type t = r
- let equal n1 n2 =
- let clbool (cl1,b1) (cl2,b2) = Cl.equal cl1 cl2 && DBool.equal b1 b2 in
- n1.topnot == n2.topnot &&
- IArray.equal clbool n1.lits n2.lits
-
- let hash n =
- let clbool (cl,b) = Hashcons.combine (Cl.hash cl) (DBool.hash b) in
- Hashcons.combine (DBool.hash n.topnot) (IArray.hash clbool n.lits)
-
- let compare n1 n2 =
- let c = DBool.compare n1.topnot n2.topnot in
- if c != 0 then c else
- let clbool (cl1,b1) (cl2,b2) =
- let c = Cl.compare cl1 cl2 in
- if c != 0 then c
- else DBool.compare b1 b2 in
- IArray.compare clbool n1.lits n2.lits
-
-
- let print_cl fmt cl b =
- if b
- then Format.fprintf fmt "¬ %a" Cl.print cl
- else Cl.print fmt cl
-
- let print fmt x =
- match isnot x with
- | Some cl ->
- print_cl fmt cl true
- | None ->
- let print_cl topnot fmt (cl,b) = print_cl fmt cl (mulbool topnot b) in
- if x.topnot
- then Format.fprintf fmt "â‹€(%a)"
- (Pp.print_iter1 IArray.iter Pp.comma (print_cl true)) x.lits
- else Format.fprintf fmt "â‹(%a)"
- (Pp.print_iter1 IArray.iter Pp.comma (print_cl false)) x.lits
-
-end
-
-module Th = struct
- include MkDatatype(T)
-
- let key = sem
-
- exception TopKnown of bool
-
- exception Found of Cl.t * bool
- let find_not_known d l =
- IArray.iter (fun (cl,b) ->
- match Delayed.get_dom d dom cl with
- | Some _ -> ()
- | None -> raise (Found (cl,b))
- ) l
-
- let _bcp d l absorbent =
- try
- let res = IArray.fold (fun acc cl ->
- match Delayed.get_dom d dom cl, acc with
- | Some b, _ when b = absorbent -> raise (TopKnown absorbent)
- | Some _, _ -> acc
- | None, Some _ -> raise Exit
- | None, None -> Some cl)
- None l in
- match res with
- | None -> raise (TopKnown (not absorbent))
- | _ -> res
- with Exit -> None
-
-end
-
-module ThE = RegisterSem(Th)
-
-type bcpkind =
- | BCPOwnKnown
- | BCPLeavesKnown
- | BCP
-
-type expprop =
-| ExpBCP of ThE.t (* own *) * Cl.t (* propa *) * bcpkind * bool
-| ExpUp of ThE.t (* own *) * Cl.t (* one leaf to own *)
-| ExpDown of ThE.t (* own *) * Cl.t (* leaf *) * bool (* own to leaf *)
-| ExpNot of (Th.t * Cl.t * Cl.t) * bool
-(* | ExpNot of Th.t * Cl.t * Cl.t (* t <> not t or t = not (not t) *) *)
-
-let expprop : expprop Explanation.exp =
- Explanation.Exp.create_key "Bool.prop"
-
-module DaemonPropaNot = struct
-
- module Data = struct
- type t = Th.t * Cl.t * Cl.t
- let print fmt (v,cl1,cl2) =
- Format.fprintf fmt "%a,%a -> %a" Th.print v Cl.print cl1 Cl.print cl2
- end
-
- let immediate = false
- let key = Demon.Fast.create "Bool.DaemonPropaNot"
- let throttle = 100
- let wakeup d =
- function
- | Events.Fired.EventDom(_,dom',((_,cl,ncl) as x)) ->
- assert (Dom.equal dom dom');
- begin match Delayed.get_dom d dom cl with
- | None -> raise Impossible
- | Some b ->
- let pexp = Delayed.mk_pexp d expprop (ExpNot(x,(not b))) in
- set_bool d pexp ncl (not b)
- end;
- | _ -> raise UnwaitedEvent
-
- let init d clsem cl =
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- match is d own with
- | Some b ->
- let pexp = Delayed.mk_pexp d expprop (ExpNot((v,own,cl),not b)) in
- set_bool d pexp cl (not b)
- | None ->
- match is d cl with
- | Some b ->
- let pexp = Delayed.mk_pexp d expprop
- (ExpNot((v,cl,own),not b)) in
- set_bool d pexp own (not b)
- | None ->
- let events = [Demon.Create.EventDom(own,dom,(v,own,cl));
- Demon.Create.EventDom(cl,dom,(v,cl,own))] in
- Demon.Fast.attach d key events
-
-end
-
-module RDaemonPropaNot = Demon.Fast.Register(DaemonPropaNot)
-
-module DaemonPropa = struct
- type d =
- | Lit of ThE.t (* prop *) * int (* watched *) * int (* otherside *)
- | All of ThE.t
-
- let key = Demon.Fast.create "Bool.DaemonPropa"
-
- module Data = struct
- type t = d
- let print fmt = function
- | Lit (clsem,w,n) ->
- Format.fprintf fmt "Lit(%a,%i,%i,%a)" ThE.print clsem w n
- Cl.print (ThE.cl clsem)
- | All clsem -> Format.fprintf fmt "All(%a)" ThE.print clsem
- end
-
- let immediate = false
- let throttle = 100
-
- let wakeup_lit ~first d clsem watched next =
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- let pexp exp = Delayed.mk_pexp d expprop exp in
- let set_dom_up_true d own leaf _ =
- let b = (not v.topnot) in
- match Delayed.get_dom d dom own with
- | Some b' when b' == b -> ()
- | _ -> set_bool d (pexp (ExpUp(clsem,leaf))) own b in
- let merge_bcp cl sign =
- Debug.dprintf2 debug "[Bool] @[merge_bcp %a@]@\n" Cl.print cl;
- match Delayed.get_dom d dom own with
- | Some b' ->
- let b = mulbool sign (mulbool b' v.topnot) in
- let pexp = pexp (ExpBCP(clsem,cl,BCPOwnKnown,b)) in
- set_bool d pexp cl b
- | None -> (** merge *)
- match Delayed.get_dom d dom cl with
- | Some b' ->
- let b = mulbool sign (mulbool b' v.topnot) in
- let pexp = pexp (ExpBCP(clsem,cl,BCPLeavesKnown,b)) in
- set_bool d pexp own b
- | None -> (** merge *)
- if mulbool v.topnot sign
- then DaemonPropaNot.init d clsem cl
- else Delayed.merge d (pexp (ExpBCP(clsem,cl,BCP,true))) own cl in
- let rec find_watch dir pos bound =
- assert (dir == 1 || dir == -1);
- if pos == bound
- then
- let cl,sign = IArray.get v.lits pos in
- (merge_bcp cl sign; raise Exit)
- else
- let cl,sign = IArray.get v.lits pos in
- match Delayed.get_dom d dom cl with
- | None -> cl,pos
- | Some b when mulbool b sign (** true absorbent of or *) ->
- set_dom_up_true d own cl b; raise Exit
- | Some _ (** false *) -> find_watch dir (dir+pos) bound
- in
- try
- assert (watched <> next);
- let dir = if watched < next then 1 else -1 in
- let clwatched, watched = find_watch dir watched next in
- let clnext , next = find_watch (-dir) next watched in
- let events = [Demon.Create.EventDom(clwatched,dom,
- Lit(clsem,watched,next))] in
- let events =
- if first then
- Demon.Create.EventDom(clnext,dom,
- Lit(clsem,next,watched))::events
- else events in
- Demon.Fast.attach d key events;
- true
- with Exit -> false
-
- let wakeup_own ~first d clsem =
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- let pexp exp = Delayed.mk_pexp d expprop exp in
- begin match Delayed.get_dom d dom own with
- | None -> assert (first);
- Demon.Fast.attach d key
- [Demon.Create.EventDom(own, dom, All clsem)];
- true
- (** \/ c1 c2 = false ==> c1 = false /\ c2 = false *)
- | Some b when not (mulbool v.topnot b) ->
- let set_dom_down_false (cl,sign) =
- set_bool d (pexp (ExpDown(clsem,cl,sign))) cl sign in
- IArray.iter set_dom_down_false v.lits;
- false
- | Some _ -> true
- end
-
- (** return true if things should be propagated *)
- let init d clsem =
- let v = ThE.sem clsem in
- wakeup_own ~first:true d clsem &&
- let last = IArray.length v.lits - 1 in
- wakeup_lit ~first:true d clsem 0 last
-
- let wakeup d = function
- | Events.Fired.EventDom(_,dom',Lit(clsem,watched,next)) ->
- assert( Dom.equal dom dom' );
- ignore (wakeup_lit ~first:false d clsem watched next)
- | Events.Fired.EventDom(_ownr,dom',All clsem) ->
- assert( Dom.equal dom dom' );
- (** use this own because the other is the representant *)
- ignore (wakeup_own ~first:false d clsem)
- | _ -> raise UnwaitedEvent
-
-
-end
-
-module RDaemonPropa = Demon.Fast.Register(DaemonPropa)
-
-module DaemonInit = struct
- let key = Demon.Fast.create "Bool.DaemonInit"
-
- module Data = DUnit
-
- let immediate = false
- let throttle = 100
- let wakeup d = function
- | Events.Fired.EventRegSem(clsem,()) ->
- begin try
- let clsem = ThE.coerce_clsem clsem in
- let v = ThE.sem clsem in
- match isnot v with
- | Some cl ->
- Delayed.register d cl;
- DaemonPropaNot.init d clsem cl
- | None ->
- assert (not lazy_propagation);
- IArray.iter (fun (cl,_) -> Delayed.register d cl) v.lits;
- if DaemonPropa.init d clsem then ()
- (* Delayed.ask_decision d (dec v) *)
- with Exit -> ()
- end
- | _ -> raise UnwaitedEvent
-
-end
-
-module RDaemonInit = Demon.Fast.Register(DaemonInit)
-
-let th_register' with_other_theories env =
- with_other := with_other_theories;
- RDaemonPropaNot.init env;
- RDaemonPropa.init env;
- RDaemonInit.init env;
- Demon.Fast.attach env
- DaemonInit.key [Demon.Create.EventRegSem(sem,())];
- Delayed.register env cl_true;
- Delayed.register env cl_false;
- let pexp = Explanation.pexpfact in
- Delayed.set_dom env pexp dom cl_true true;
- Delayed.set_dom env pexp dom cl_false false;
- ()
-
-let th_register_alone = th_register' false
-let th_register = th_register' true
-
-let _true = cl_true
-let _not cl =
- index sem {topnot = true; lits = IArray.of_list [cl,false]}
-
-
-let filter fold_left =
- let m = fold_left (fun acc (e,b) ->
- Cl.M.add_change (fun b -> b)
- (fun b1 b2 -> if b1 == b2 then b1 else raise Exit) e b acc)
- Cl.M.empty in
- Cl.M.bindings m
-
-let gen topnot l =
- try
- let l = filter (fun f acc -> List.fold_left f acc l) in
- match l with
- | [] -> if topnot then cl_true else cl_false
- | [cl,b] when mulbool topnot b -> _not cl
- | [cl,_] -> cl
- | l ->
- index sem {topnot; lits = IArray.of_list l}
- with Exit -> if topnot then cl_false else cl_true
-
-let _or_and b l =
- try
- let l = filter (fun f acc ->
- List.fold_left (fun acc e -> f acc (e,b)) acc l) in
- match l with
- | [] -> if b then cl_true else cl_false
- | [a,b'] -> assert (b == b'); a
- | l ->
- index sem {topnot = b; lits = IArray.of_list l}
- with Exit -> if b then cl_false else cl_true
-
-let _or = _or_and false
-let _and = _or_and true
-
-let mk_clause m =
- if Cl.M.is_empty m then cl_false
- else let len = Cl.M.cardinal m in
- if len = 1 then
- let cl,b = Cl.M.choose m in
- if b then _not cl else cl
- else
- index sem {topnot=false;
- lits = IArray.of_iter len
- (fun iter -> Cl.M.iter (fun cl b -> iter (cl,b)) m)}
-
-let _false = cl_false
-
-let set_true env pexp cl = set_bool env pexp cl true
-
-let set_false env pexp cl = set_bool env pexp cl false
-
-let chobool = Explanation.Cho.create_key "Bool.cho"
-
-let make_dec cl = Explanation.GCho(chobool,cl)
-
-let () = Variable.register_sort ~dec:make_dec ty
-
-module ChoBool = struct
- open Conflict
-
- module Key = Cl
- module Data = DBool
-
- let make_decision env dec cl b =
- Debug.dprintf5 Conflict.print_decision
- "[Bool] decide %b on %a at %a@\n" b Cl.print cl Explanation.print_dec dec;
- let pexp = Explanation.mk_pcho dec chobool cl b in
- set_bool env pexp cl b
-
- let choose_decision env cl =
- match Solver.Delayed.get_dom env dom cl with
- | Some _ -> DecNo
- | None -> DecTodo true (** why not true? *)
-
- let analyse (type a) t (con: a Explanation.con) cl b =
- let return (s:bool Types.Cl.M.t) : a rescon =
- match Explanation.Con.Eq.eq_type conclause con with
- | None -> GOther (conclause,s)
- | Some Types.Eq -> GRequested s in
- ComputeConflict.set_dec_cho t chobool cl;
- return (Cl.M.singleton cl b)
-
-
- let key = chobool
-
-end
-
-module EChoBool = Conflict.RegisterCho(ChoBool)
-
-let choclause = Explanation.Cho.create_key "Bool.choclause"
-
-module ChoClause = struct
- module Key = Th
- module Data = struct
- type t = Cl.t * bool
- let print fmt (cl,b) =
- Format.fprintf fmt "%a=%b" Cl.print cl b
- end
-
- let choose_decision env c =
- try
- Th.find_not_known env c.lits;
- Conflict.DecNo
- with Th.Found (cl,sign) ->
- Conflict.DecTodo (cl,not sign)
-
- let make_decision env dec _ (cl,b) =
- ChoBool.make_decision env dec cl b
-
- let analyse _ _ _ _ = assert false
-
- let key = choclause
-
-end
-
-module EChoClause = Conflict.RegisterCho(ChoClause)
-
-open Conflict
-type clause_conflict = bool Types.Cl.M.t
-
-let mk_conequal:
- (ComputeConflict.t -> Cl.t -> Cl.t -> clause_conflict rescon) ref =
- ref (fun _ _ -> assert false)
-
-let concat s1 s2 =
- Cl.M.union (fun _ b1 b2 -> assert (DBool.equal b1 b2); Some b1) s1 s2
-
-let get_con acc t rescon =
- Conflict.fold_requested (fun acc _ s -> concat acc s)
- acc t rescon
-
-let get_cons t s rlist = fold_rescon_list t get_con conclause s rlist
-let get_dom t age cl s =
- if Cl.equal cl cl_true || Cl.equal cl cl_false then s
- else
- let l = ComputeConflict.get_dom t age cl dom in
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "[get_dom] @[%a@]@\n" *)
- (* (Pp.print_list Pp.semi Explanation.print_mod_dom) l; *)
- List.fold_left (fun s mod_dom ->
- let rlist =
- ComputeConflict.get_equal t age cl mod_dom.Explanation.modcl in
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "[rlist] @[%a@]@\n" *)
- (* Conflict.print_rlist rlist; *)
- let pexp = mod_dom.Explanation.modpexp in
- let s = get_con s t (ComputeConflict.get_pexp t pexp conclause) in
- let s = get_cons t s rlist in
- s) s l
-
-let get_pexp t s pexp =
- get_con s t (ComputeConflict.get_pexp t pexp conclause)
-
-
-let check_sem v cl =
- let own = ThE.cl (ThE.index v ty) in
- Cl.equal cl own
-
-(** **)
-module ExpMerge = struct
- open D
-
- type t = expmerge
-
- let print fmt = function
- | Merge (pexp,cl1,cl2) ->
- Format.fprintf fmt "Merge!(%a,%a,%a)"
- Conflict.print_pexp pexp Cl.print cl1 Cl.print cl2
- | DomMerge (pexp,cl) ->
- Format.fprintf fmt "DomMerge!(%a,%a)"
- Conflict.print_pexp pexp Cl.print cl
-
-(*
- let need_dom t age cl =
- if not (Cl.equal cl cl_true || Cl.equal cl cl_false) then
- IterExp.need_dom t age cl dom
-
- let iterexp t age = function
- | Merge (pexp,cl1,cl2,_) ->
- IterExp.need_pexp t pexp;
- need_dom t age cl1;
- need_dom t age cl2
- | DomMerge (pexp,cl,_) ->
- IterExp.need_pexp t pexp;
- need_dom t age cl
- *)
-
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con exp ->
- let return (s:bool Types.Cl.M.t) : a Conflict.rescon =
- match Explanation.Con.Eq.eq_type conclause con with
- | None -> GOther (conclause,s)
- | Some Types.Eq -> GRequested s in
- match exp with
- | Merge (pexp,cl1,cl2) ->
- let s = Cl.M.empty in
- let s = get_con s t (ComputeConflict.get_pexp t pexp conclause) in
- let s = get_dom t age cl1 s in
- let s = get_dom t age cl2 s in
- return s
- | DomMerge (pexp,cl) ->
- let s = Cl.M.empty in
- let s = get_con s t (ComputeConflict.get_pexp t pexp conclause) in
- let s = get_dom t age cl s in
- return s
-
- let expdom _ _ _ _ _ _ = raise Impossible (* used only for unsat *)
-
- let key = expmerge
-
-end
-
-module EM = Conflict.RegisterExp(ExpMerge)
-
-module ExpProp = struct
-
- type t = expprop
-
- let print fmt = function
- | ExpBCP (clsem,cl,kind,b) ->
- Format.fprintf fmt "Bcp(%a,%a = %a;%t)"
- ThE.print clsem Cl.print (ThE.cl clsem) Cl.print cl
- (fun _ -> match kind with
- | BCPOwnKnown -> Format.fprintf fmt "Own %b" b
- | BCPLeavesKnown -> Format.fprintf fmt "Leaves %b" b
- | BCP -> ())
- | ExpUp (clsem,leaf) ->
- Format.fprintf fmt "Up(%a,%a <- %a)"
- ThE.print clsem Cl.print (ThE.cl clsem) Cl.print leaf
- | ExpDown (clsem,cl,b) ->
- Format.fprintf fmt "Down(%a,%a,%a,%a ->)"
- ThE.print clsem Cl.print (ThE.cl clsem) Cl.print cl DBool.print b
- | ExpNot ((v,clf,clt),b) ->
- Format.fprintf fmt "Not(%a,%a,%a,%a)"
- Th.print v Cl.print clf Cl.print clt DBool.print b
-
-
-(*
- let iterexp t age = function
- | ExpBCP (v,_,_) when IArray.length v.lits = 1 ->
- raise Impossible
- | ExpBCP (v,_,propa) ->
- IterExp.need_sem t age sem v;
- iter (fun (cl,_) ->
- if not (Cl.equal cl propa) then
- IterExp.need_dom t age cl dom) v
- | ExpUp (v,_,leaf,_) ->
- IterExp.need_sem t age sem v;
- IterExp.need_dom t age leaf dom
- | ExpDown (v,own) ->
- IterExp.need_sem t age sem v;
- IterExp.need_dom t age own dom
- | ExpNot (v,cl,_)->
- IterExp.need_sem t age sem v;
- IterExp.need_dom t age cl dom;
- (** For Top propagation (otherwise need_sem do already the job *)
- let cln,_ = IArray.get v.lits 0 in
- IterExp.need_cl_repr t age cln
-
-*)
-
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con exp ->
- let s =
- match exp with
- | ExpBCP (clsem,_,_,_) when IArray.length (ThE.sem clsem).lits = 1 ->
- raise Impossible
- | ExpBCP (clsem,propa,kind,_) ->
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- let s = Cl.M.empty in
- let s = if kind == BCPOwnKnown then get_dom t age own s else s in
- fold (fun s (cl,_) ->
- if kind != BCPLeavesKnown && (Cl.equal cl propa) then s
- else get_dom t age cl s) s v
- | ExpUp (_,leaf) ->
- let s = Cl.M.empty in
- let s = get_dom t age leaf s in
- s
- | ExpDown (clsem,_,_) ->
- let own = ThE.cl clsem in
- let s = Cl.M.empty in
- let s = get_dom t age own s in
- s
- | ExpNot ((v,clfrom,clto),_)->
- let s = Cl.M.empty in
- assert (check_sem v clto || check_sem v clfrom);
- let s = get_dom t age clfrom s in
- fold (fun s (cl,_) ->
- if (Cl.equal cl clfrom) ||
- (Cl.equal cl clto) then s
- else get_dom t age cl s) s v
- in
- Conflict.return con conclause s
-
- let expdom :
- type a b. Conflict.ComputeConflict.t ->
- Explanation.age -> b dom -> Cl.t ->
- a Explanation.con -> t -> a Conflict.rescon =
- fun t age dom' cl con exp ->
- assert (Dom.equal dom' dom);
- if ComputeConflict.before_first_dec t age
- then Conflict.return con conclause Cl.M.empty
- else
- let s =
- match exp with
- | ExpBCP (_,_,BCP,_) ->
- raise Impossible (** merge ot set dom *)
- | ExpBCP (_,_,BCPOwnKnown,b) ->
- Cl.M.singleton cl b
- | ExpBCP (_,_,BCPLeavesKnown,b) ->
- Cl.M.singleton cl b
- | ExpUp (clsem,_) ->
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- assert (Cl.equal cl own);
- let b = (not v.topnot) in
- Cl.M.singleton cl b
- | ExpDown (_,cl',sign) ->
- assert (Cl.equal cl cl');
- Cl.M.singleton cl sign
- | ExpNot ((_,_,clto),b)->
- assert (Cl.equal cl clto);
- Cl.M.singleton cl b
- in
- Conflict.return con conclause s
-
-
-
- let key = expprop
-
-end
-
-module EP = Conflict.RegisterExp(ExpProp)
-
-module ConClause = struct
- open Conflict
-
- type t = bool Cl.M.t
-
- let print fmt t =
- Format.fprintf fmt "@[%a@]"
- (Pp.print_iter2 Cl.M.iter (Pp.constant_formatted "â‹€@,")
- (Pp.constant_formatted "=") Cl.print
- Format.pp_print_bool)
- t
-
- let key = conclause
-
- class finalized v : Conflict.finalized = object
- method print fmt =
- Pp.print_iter2 Cl.M.iter Pp.semi Pp.comma Cl.print DBool.print fmt v
- method test d =
- try
- Cl.M.fold_left (fun acc cl sign ->
- match is d cl with
- | None -> ToDecide
- | Some b ->
- if mulbool b sign
- then raise Exit
- else acc) False v
- with Exit -> True
- method decide :
- 'a. 'a Conflict.fold_decisions -> Solver.Delayed.t -> 'a -> 'a =
- fun f d acc ->
- Cl.M.fold_left (fun acc cl b ->
- match is d cl with
- | None ->
- f.fold_decisions acc chobool cl (not b)
- | Some _ -> acc) acc v
- method conflict_add _ = v
- end
-
- let finalize _ sl =
- let s = Bag.fold_left union_disjoint Cl.M.empty sl in
- Debug.dprintf2 Conflict.print_conflicts "[Bool] @[conflict: %a@]@\n"
- print s;
- match Cl.M.cardinal s with
- | 0 -> None
- | _ ->
- Some (new finalized s)
-
-
- let same_sem t _age _sem _v pexp2 _cl1 _cl2 =
- let s = Cl.M.empty in
- let s = get_con s t (ComputeConflict.get_pexp t pexp2 conclause) in
- GRequested s
-
- let propacl t age clo rcl =
- if ComputeConflict.before_first_dec t age
- then GRequested Cl.M.empty
- else
- match clo, rcl with
- | (_true, cl) when Cl.equal _true cl_true ->
- ComputeConflict.set_dec_cho t chobool cl;
- GRequested (Cl.M.singleton cl true)
- | (cl, _true) when Cl.equal _true cl_true ->
- ComputeConflict.set_dec_cho t chobool cl;
- GRequested (Cl.M.singleton cl true)
- | (_false, cl) when Cl.equal _false cl_false ->
- ComputeConflict.set_dec_cho t chobool cl;
- GRequested (Cl.M.singleton cl false)
- | (cl, _false) when Cl.equal _false cl_false ->
- ComputeConflict.set_dec_cho t chobool cl;
- GRequested (Cl.M.singleton cl false)
- | _ ->
- !mk_conequal t clo rcl
-
- (* let propadom: *)
- (* type a. ComputeConflict.t -> *)
- (* Explanation.Age.t -> a dom -> Cl.t -> a option -> t rescon = *)
- (* fun t age dom' cl bval -> *)
- (* if ComputeConflict.before_first_dec t age *)
- (* then GRequested Cl.M.empty *)
- (* else *)
- (* match Dom.Eq.coerce_type dom dom' with *)
- (* | Types.Eq -> *)
- (* if Cl.equal cl cl_true || Cl.equal cl cl_false then *)
- (* GRequested Cl.M.empty *)
- (* else *)
- (* GRequested (Cl.M.singleton cl (Opt.get bval)) *)
-end
-
-module EC = Conflict.RegisterCon(ConClause)
diff --git a/src/bool.mli b/src/bool.mli
deleted file mode 100644
index 78e327c76..000000000
--- a/src/bool.mli
+++ /dev/null
@@ -1,82 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Types
-
-type t
-val sem: t sem
-val dom: bool dom
-
-val _true : Cl.t
-val _false : Cl.t
-val _and : Cl.t list -> Cl.t
-val _or : Cl.t list -> Cl.t
-val _not : Cl.t -> Cl.t
-val gen : bool -> (Cl.t * bool) list -> Cl.t
-(** [gen d b0 [cl1,b1;cl2,c2]] is
- not_b0 (or (not_b1 cl1,not_b2 cl2)) with not_x f = if x then not f else f
-*)
-
-val set_true : Solver.d -> Explanation.pexp -> Cl.t -> unit
-val set_false : Solver.d -> Explanation.pexp -> Cl.t -> unit
-
-val is : Solver.d -> Cl.t -> bool option
-val is_true : Solver.d -> Cl.t -> bool
-val is_false : Solver.d -> Cl.t -> bool
-(** is_true t cl = false means the value is not constrained by the
- current constraints or due to incompletness *)
-val is_unknown : Solver.d -> Cl.t -> bool
-
-val true_is_false : Solver.d -> Cl.t -> Explanation.pexp -> 'a
-
-val th_register: Solver.d -> unit
-val th_register_alone: Solver.d -> unit
-
-val chobool: (Cl.t,bool) Explanation.cho
-
-val make_dec: Variable.make_dec
-
-val ty: Ty.t
-val ty_ctr: Ty.Constr.t
-
-(** For conflict *)
-type clause_conflict = bool Types.Cl.M.t
-
-val get_con: clause_conflict -> Conflict.ComputeConflict.t ->
- clause_conflict Conflict.rescon -> clause_conflict
-val get_pexp: Conflict.ComputeConflict.t -> clause_conflict ->
- Explanation.pexp -> clause_conflict
-val get_cons: Conflict.ComputeConflict.t ->
- clause_conflict -> Conflict.rlist -> clause_conflict
-val get_dom:
- Conflict.ComputeConflict.t ->
- Explanation.age ->
- Types.Cl.t -> clause_conflict -> clause_conflict
-
-val union_disjoint: clause_conflict -> clause_conflict -> clause_conflict
-
-val mk_clause: clause_conflict -> Cl.t
-
-(** For equality *)
-val mk_conequal:
- (Conflict.ComputeConflict.t ->
- Cl.t -> Cl.t -> clause_conflict Conflict.rescon) ref
diff --git a/src/bv.ml b/src/bv.ml
deleted file mode 100644
index 5988976d7..000000000
--- a/src/bv.ml
+++ /dev/null
@@ -1,474 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Stdlib
-open Types
-open Solver
-
-let lazy_propagation = false
-
-
-
-let debug = Debug.register_info_flag
- ~desc:"for bit-vectors theory"
- "bv"
-
-(*
- Some sections of the code are tagged, like the following.
- This is used for listing in the documentation
-*)
-
-(* Bit *)
-type binop = | Bxor | Bor | Band | Bsl | Bsr
-type bvexp =
-| Binop of binop * Cl.t * Cl.t
-| Bnot of Cl.t
-| Cst of Z.t
-(* end *)
-
-let hash_bop a b = function
-| Bxor -> 3 * a + 5 * b
-| Bor -> 7 * a + 9 * b
-| Band -> 11 * a + 13 * b
-| Bsl -> 19 * a + 31 * b
-| Bsr -> 23 * a + 33 * b
-
-let sem : bvexp sem = Sem.create_key "bv_sem"
-
-(* BVdomain *)
-type bvdom = {aun : Z.t; azer : Z.t}
-(* end *)
-let dom : bvdom dom = Dom.create_key "bvdom"
-
-let domlen x = max (Z.numbits x.aun) (Z.numbits x.azer)
-let bvmeet x y = Z.({aun = logor x.aun y.aun ; azer = logand x.azer y.azer})
-let bneg x = Z.({aun = lognot x.azer ; azer = lognot x.aun})
-let bveqdom x y = Z.equal x.aun y.aun && Z.equal x.azer y.azer
-let bvconflict x = not (Z.equal Z.(logand (lognot x.azer) x.aun) Z.zero)
-let normalshift shift_op x n =
- Z.({aun = shift_op x.aun n; azer = shift_op x.azer n})
-
-let shifted_ones shift_op x n =
-if (shift_op Z.one 1 == (Z.of_int 2)) then (* it's << *)
- Z.lognot (shift_op Z.minus_one n)
-else (* it's >>, so use << *)
- let len = domlen x in
- Z.shift_left Z.minus_one (len - n)
-
-let unknownshift shift_op x n =
- let ones = shifted_ones shift_op x n in
- Z.({aun = shift_op x.aun n;
- azer = logor (shift_op x.azer n) ones })
-
-let bvfixed x = if Z.equal x.aun x.azer then Some x.aun else None
-
-module D = struct
- type t = bvdom
-
- type expmerge = (* all Copied *)
- | Merge of Explanation.pexp * Cl.t * Cl.t
- | DomMerge of Explanation.pexp * Cl.t
-
- let expmerge : expmerge Explanation.exp =(* nearly all Copied *)
- Explanation.Exp.create_key "Bit-vector.merge"
-
- let set_dom_bv d pexp cl newdom =
- match Delayed.get_dom d dom cl with
- | Some b' when bveqdom b' newdom -> ()
- | _ -> Delayed.set_dom d pexp dom cl newdom
-
- let get_dom_bv d dom cl =
- match Delayed.get_dom d dom cl with
- | Some b -> b
- | None -> {aun = Z.zero; azer = Z.minus_one}
-
- let merge d pexp (b1, cl1) (b2, cl2) _ =
- match b1,b2 with
- | Some v1, Some v2 when bveqdom v1 v2 -> ()
- | Some v1, Some v2 ->
- let newdom = bvmeet v1 v2 in
- if bvconflict newdom then
- let pexp = Delayed.mk_pexp d expmerge (Merge(pexp, cl1, cl2)) in
- Delayed.contradiction d pexp
- else begin
- set_dom_bv d pexp cl1 newdom;
- set_dom_bv d pexp cl2 newdom;
- end
- | None, Some b -> Delayed.set_dom_premerge d dom cl1 b
- | Some b, None -> Delayed.set_dom_premerge d dom cl2 b
- | None, None -> failwith "Should not be possible"
-
- let key = dom
-
- let print_cnst fmt cbv =
- let to_print = "["^ (Z.format "%b" cbv) ^"]" in
- Format.pp_print_string fmt to_print
-
- let print fmt interval =
- let len = 1 + domlen interval in
- (** Here we print most significant bit first *)
- let to_print =
- "["^ String.init len
- (fun i ->
- match Z.testbit interval.aun (len-1-i),
- Z.testbit interval.azer (len-1-i) with
- | true, true -> '1'
- | false, false -> '0'
- | false, true -> '?'
- | true, false -> 'X'
- ) ^ "]" in
- Format.pp_print_string fmt to_print
-
- let merged b1 b2 =
- match b1,b2 with
- | Some v1, Some v2 -> bveqdom v1 v2
- | _, _ -> false
-
-end
-
-module DE = RegisterDom(D)
-
-(* Useful utils: removable *)
-let simpleprint var env str=
- let xd = D.get_dom_bv env dom var in
- Format.print_string ("\n"^ str);
- D.print Format.std_formatter xd;
- Format.print_string "\n"
-let simpledomprint xd str=
- Format.print_string ("\n"^ str);
- D.print Format.std_formatter xd;
- Format.print_string "\n"
-
-module T = struct
- type t = bvexp
- let equal e1 e2 =
- match e1,e2 with
- | Binop (bop, a, b), Binop (bop', aa, bb) ->
- (bop == bop') && Cl.equal a aa && Cl.equal b bb
- | Cst i, Cst j -> Z.equal i j
- | Bnot a , Bnot aa -> Cl.equal a aa
- | _,_ -> false
-
- let hash = function
- | Binop (bop, a, b) -> hash_bop (Cl.hash a) (Cl.hash b) bop
- | Bnot a -> 17 * Cl.hash a
- | Cst i -> Z.hash i
-
- let compare n m =
- match n, m with
- | Binop (bop, a, b), Binop (bop', aa, bb) ->
- let c = compare bop bop' in
- if c <> 0 then c
- else let c = Cl.compare a aa in
- if c <> 0 then c
- else Cl.compare b bb
- | Binop _ , _ -> 1
- | _ , Binop _ -> 1
- | Bnot a, Bnot aa -> Cl.compare a aa
- | Bnot _, _ -> 1
- | _, Bnot _ -> 1
- | Cst i, Cst j -> Z.compare i j
-
- let op_to_string = function
- | Bxor -> "⊕"
- | Bor -> "|"
- | Band -> "&"
- | Bsl -> "<<"
- | Bsr -> ">>"
-
- let print fmt (e : t)=
- match e with
- | Binop (bop, a, b) ->
- Format.fprintf fmt ("(%a) %s (%a)") Cl.print a (op_to_string bop) Cl.print b
- | Bnot a ->
- Format.fprintf fmt "~(%a)" Cl.print a
- | Cst i -> D.print_cnst fmt i
-end
-
-module Th = struct
- include MkDatatype(T)
-
- let key = sem
-
-end
-
-module ThE = RegisterSem(Th)
-
-let and_dirp x y = Z.({aun = x.aun land y.aun ; azer = x.azer land y.azer})
-let and_invp x z = Z.({aun = z.aun ; azer = logor z.azer (lognot x.aun)})
-let or_dirp x y = Z.({aun = x.aun lor y.aun ; azer = x.azer lor y.azer})
-let or_invp x z = Z.({aun = z.aun land (lognot x.azer) ; azer = z.azer})
-let xor_p x y =
- Z.({aun = (((lognot x.azer) land y.aun) lor (x.aun land (lognot y.azer))) ;
- azer = (x.azer lor y.azer) land lognot (x.aun land y.aun)})
-
-let shift_p sh_op inv_op x n z =
- let nx = bvmeet x (unknownshift inv_op z n) in
- let nz = bvmeet z (normalshift sh_op x n) in
- if List.exists bvconflict [nx;nz] then None
- else Some (nx, nz)
-
-let dom_of_cnst i = {aun = i; azer = i}
-
-let or_prop x y z = (* x | y = z *)
- let nz = bvmeet z (or_dirp x y) in
- let nx = bvmeet x (or_invp y z) in
- let ny = bvmeet y (or_invp x z) in
- if List.exists bvconflict [nx;ny;nz] then None
- else Some (nx, ny, nz)
-
-let and_prop x y z = (* x & y = z *)
- let nz = bvmeet z (and_dirp x y) in
- let nx = bvmeet x (and_invp y z) in
- let ny = bvmeet y (and_invp x z) in
- if List.exists bvconflict [nx;ny;nz] then None
- else Some (nx, ny, nz)
-
-let xor_prop x y z =
- let nx = bvmeet x (xor_p y z) in
- let ny = bvmeet y (xor_p x z) in
- let nz = bvmeet z (xor_p x y) in
- if List.exists bvconflict [nx;ny;nz] then None
- else Some (nx, ny, nz)
-
-type side =
-| Left
-| Right
-| Up
-type expprop =
-| ExpDirBV of ThE.t
-| ExpInvBV of ThE.t * side
-| ExpConflictBV of ThE.t
-
-let expprop : expprop Explanation.exp =
- Explanation.Exp.create_key "Bv.prop"
-
-module ExpProp = struct (* TODO *)
- open D
- type t = expprop
- let key = expprop
-
- let analyse _ _ _ _ = failwith "analyse exp"
-
- let print _ = failwith "print expdom"
-
- let expdom _ _ _ _ _ _ = failwith "expdom"
-
-end
-
-module EP = Conflict.RegisterExp(ExpProp)
-
-let ty_ctr = Ty.Constr.create "Bit-vector"
-let ty = Ty.ctr ty_ctr
-
-let index a = Cl.index sem a ty
-
-module DaemonPropa = struct
- type info = ThE.t
-
- module Data = struct
- type t = info
- let print fmt clsem =
- Format.fprintf fmt "Propagating inside %a" ThE.print clsem
- end
-
- let key = Demon.Fast.create "BV.DaemonPropa"
- let immediate = true
- let throttle = 100
-
- let dom_set_or_merge ds exp c domc =
- match bvfixed domc with
- |None -> D.set_dom_bv ds exp c domc
- |Some i ->
- let cst = index (Cst i) in
- Solver.Delayed.register ds cst;
- Solver.Delayed.flush ds;
- (* let pexp = Explanation.pexpfact in *)
- (* D.set_dom_bv ds pexp cst {aun = i; azer = i}; *)
- Delayed.merge ds exp c cst
-
- let generic_shift d sh_op inv_op clsem c off =
- let offset = D.get_dom_bv d dom off in
- match bvfixed offset with
- | None -> ()
- | Some nn ->
- let n = Z.to_int nn in
- let cl = ThE.cl clsem in
- let dc = D.get_dom_bv d dom c in
- let dcl = D.get_dom_bv d dom cl in
- match shift_p sh_op inv_op dc n dcl with
- | None ->
- let pexp = Delayed.mk_pexp d expprop (ExpConflictBV clsem) in
- Delayed.contradiction d pexp
- | Some (ndc, ndcl) ->
- let pexp = Delayed.mk_pexp d expprop (ExpDirBV clsem) in
- let pexp1 = Delayed.mk_pexp d expprop (ExpInvBV (clsem, Left)) in
- (* I also want an explanation that says
- "it's because the offset became fixed" *)
- dom_set_or_merge d pexp1 c ndc;
- dom_set_or_merge d pexp cl ndcl
-
- let generic_prop d prop_fun clsem c1 c2 =
- let cl = ThE.cl clsem in
- let dcl = D.get_dom_bv d dom cl in
- let dc1 = D.get_dom_bv d dom c1 in
- let dc2 = D.get_dom_bv d dom c2 in
- match prop_fun dc1 dc2 dcl with
- | None ->
- let pexp = Delayed.mk_pexp d expprop (ExpConflictBV clsem) in
- Delayed.contradiction d pexp
- | Some (ndc1, ndc2, ndcl) ->
- let pexp = Delayed.mk_pexp d expprop (ExpDirBV clsem) in
- let pexp1 = Delayed.mk_pexp d expprop (ExpInvBV (clsem, Left)) in
- let pexp2 = Delayed.mk_pexp d expprop (ExpInvBV (clsem, Right)) in
- dom_set_or_merge d pexp cl ndcl;
- dom_set_or_merge d pexp1 c1 ndc1;
- dom_set_or_merge d pexp2 c2 ndc2
-
- let wakeup d = function
- | Events.Fired.EventDom(_, dom', clsem) ->
- assert (Dom.equal dom dom');
- begin match ThE.sem clsem with
- | Bnot c ->
- let cl = ThE.cl clsem in
- let dcl = D.get_dom_bv d dom cl in
- let dc = D.get_dom_bv d dom c in
- let ndcl = bvmeet dcl (bneg dc) in
- let ndc = bvmeet dc (bneg dcl) in
- if List.exists bvconflict [ndcl; ndc] then
- let pexp = Delayed.mk_pexp d expprop (ExpConflictBV clsem) in
- Delayed.contradiction d pexp
- else
- let pexp = Delayed.mk_pexp d expprop (ExpDirBV clsem) in
- let pexp1 = Delayed.mk_pexp d expprop (ExpInvBV (clsem, Up)) in
- D.set_dom_bv d pexp cl ndcl;
- D.set_dom_bv d pexp1 c ndc
- | Binop (Bor, a, b) -> generic_prop d or_prop clsem a b
- | Binop (Band, a, b) -> generic_prop d and_prop clsem a b
- | Binop (Bxor, a, b) -> generic_prop d xor_prop clsem a b
- | Binop (Bsl, c, off) -> generic_shift d (Z.shift_left) (Z.shift_right) clsem c off
- | Binop (Bsr, c, off) -> generic_shift d (Z.shift_right) (Z.shift_left) clsem c off
- | _ -> failwith "should be impossible"
- end
- | _ -> raise UnwaitedEvent
-
- let init d clsem =
- let v = ThE.sem clsem in
- let ctxt = ThE.cl clsem in
- match v with
- | Binop (_, a, b) ->
- let events = [Demon.Create.EventDom (a,dom,clsem);
- Demon.Create.EventDom (b,dom,clsem);
- Demon.Create.EventDom (ctxt,dom,clsem)] in
- Demon.Fast.attach d key events;
- wakeup d (Events.Fired.EventDom(ctxt, dom, clsem))
- | Bnot c ->
- let events = [Demon.Create.EventDom (c,dom,clsem);
- Demon.Create.EventDom (ctxt,dom,clsem)] in
- Demon.Fast.attach d key events;
- wakeup d (Events.Fired.EventDom(ctxt, dom, clsem))
- | Cst i ->
- let pexp = Explanation.pexpfact in
- D.set_dom_bv d pexp ctxt {aun = i; azer = i}
-end
-
-module RDaemonPropa = Demon.Fast.Register(DaemonPropa)
-
-module DaemonInit = struct
-
- let key = Demon.Fast.create "BV.DaemonInit"
- type d = unit
- module Data = DUnit
- let immediate = true
- let throttle = 100
-
- let wakeup d = function
- | Events.Fired.EventRegSem(clsem,()) ->
- let clsem = ThE.coerce_clsem clsem in
- begin
- try
- DaemonPropa.init d clsem
- with Exit -> ()
- end
- | _ -> raise UnwaitedEvent
-end
-
-module RDaemonInit = Demon.Fast.Register(DaemonInit)
-
-module ExpMerge = struct (* TODO *)
- open D
-
- type t = expmerge
- let key = expmerge
-
- let expdom _ _ _ _ _ _ = raise Impossible (* used only for unsat *)
- let analyse _ _ = failwith "Zak: analyse in Exp"
-
- let print fmt = function
- | Merge (pexp,cl1,cl2) ->
- Format.fprintf fmt "Merge!(%a,%a,%a)"
- Conflict.print_pexp pexp Cl.print cl1 Cl.print cl2
- | DomMerge (pexp,cl) ->
- Format.fprintf fmt "DomMerge!(%a,%a)"
- Conflict.print_pexp pexp Cl.print cl
-end
-
-module EM = Conflict.RegisterExp(ExpMerge)
-
-let chobv = Explanation.Cho.create_key "Bv.cho"
-
-module ChoBv = struct (* TODO ? *)
- open Conflict
-
- module Key = Cl
- module Data = D
- let key = chobv
- let analyse (type a) t (con: a Explanation.con) cl b = failwith "todo"
- let make_decision env dec cl b = () (* failwith "todo Decision" *)
- let choose_decision env cl =
- let dcl= D.get_dom_bv env dom cl in
- match Z.(dcl.aun lxor dcl.azer) with
- |i when Z.equal i Z.zero -> DecNo
- |n -> DecTodo Z.({aun = n lor dcl.aun; azer = dcl.azer})
-end
-
-module EChoBv = Conflict.RegisterCho(ChoBv)
-
-let make_dec cl = Explanation.GCho (chobv,cl)
-let () = Variable.register_sort ~dec:make_dec ty
-
-let th_register ?(with_other_theories=false) env =
- RDaemonPropa.init env;
- RDaemonInit.init env;
- Demon.Fast.attach env
- DaemonInit.key [Demon.Create.EventRegSem(sem,())];
- ()
-
-(* Utilities *)
-
-let cnst c = index (Cst (Z.of_int c))
-let band a b = index (Binop (Band ,a, b))
-let bor a b = index (Binop (Bor, a, b))
-let bxor a b = index (Binop (Bxor, a, b))
-let bsr a b = index (Binop (Bsr, a, b))
-let bsl a b = index (Binop (Bsl, a, b))
-let bnot a = index (Bnot a)
diff --git a/src/cmd/popop_cmd.ml b/src/cmd/popop_cmd.ml
deleted file mode 100644
index 65072521d..000000000
--- a/src/cmd/popop_cmd.ml
+++ /dev/null
@@ -1,82 +0,0 @@
-type format =
- [ `Altergo
- | `Dimacs
- | `Smtlib2 ]
-
-let format = ref `Extension
-
-let set_format = function
- | "alt-ergo" -> format := `Altergo
- | "dimacs" -> format := `Dimacs
- | "smtlib2" -> format := `Smtlib2
- | _ -> assert false
-
-let dimacs f =
- match Dimacs.check_file f with
- | Dimacs.Sat -> Format.printf "Sat@."
- | Dimacs.Unsat -> Format.printf "Unsat@."
-
-let altergo f =
- let parsed = Popop_of_altergo.read_file f in
- match Popop_of_altergo.check_goal parsed with
- | Popop_of_altergo.Sat | Popop_of_altergo.Idontknow ->
- Format.printf "I don't know@."
- | Popop_of_altergo.Valid ->
- Format.printf "Valid@."
-
-let smtlib2 f =
- let cmds = Popop_of_smtlib2.read_file f in
- let res = Popop_of_smtlib2.check_file cmds in
- Format.printf "%a@." Popop_of_smtlib2.print_status res
-
-let get_extension file =
- let s = try Filename.chop_extension file
- with Invalid_argument _ -> invalid_arg "unspecified extension" in
- let n = String.length s + 1 in
- String.sub file n (String.length file - n)
-
-let args = [Debug.Args.desc_debug_list;
- Debug.Args.desc_debug;
- Debug.Args.desc_debug_all;
- ("--lang", Arg.Symbol(["alt-ergo";"dimacs";"smtlib2"], set_format),
- "Set the input format (default use the extension)");
- ("--seed", Arg.Int (fun i -> Shuffle.set_shuffle (Some [|i|])),
- "For debugging set the seed used")
- ]
-
-let get_format filename =
- match !format with
- | #format as x -> x
- | `Extension ->
- let ext = get_extension filename in
- match ext with
- | "mlw" | "why" -> `Altergo
- | "cnf" -> `Dimacs
- | "smt2" -> `Smtlib2
- | _ -> Printf.printf "Unknwon extension %s\n" ext; exit 1
-
-let do_file f =
- match get_format f with
- | `Altergo -> altergo f
- | `Dimacs -> dimacs f
- | `Smtlib2 -> smtlib2 f
-
-let files =
- let files = Queue.create () in
- Arg.parse args (fun f -> Queue.add f files)
- "popop [file.why|file.cnf|file.smt2]";
- Debug.Args.set_flags_selected ();
- if Debug.Args.option_list () then exit 0;
- files
-
-let () =
- if not (Solver.check_initialization ()) ||
- not (Conflict.check_initialization ()) then
- exit 1
-
-let () =
- try
- Queue.iter do_file files
- with e when not (Debug.test_flag Debug.stack_trace) ->
- Format.eprintf "%a@." Exn_printer.exn_printer e;
- exit 1
diff --git a/src/cmd/popop_dimacs.ml b/src/cmd/popop_dimacs.ml
deleted file mode 100644
index 501e90c2b..000000000
--- a/src/cmd/popop_dimacs.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-let () =
- try
- let f = Sys.argv.(1) in
- match Dimacs.check_file f with
- | Dimacs.Sat -> Format.printf "Sat@."
- | Dimacs.Unsat -> Format.printf "Unsat@."
- with e when not (Debug.test_flag Debug.stack_trace) ->
- Format.eprintf "%a@." Exn_printer.exn_printer e;
- exit 1
-
diff --git a/src/cmd/popop_lib.ml b/src/cmd/popop_lib.ml
deleted file mode 100644
index 5ec310ffe..000000000
--- a/src/cmd/popop_lib.ml
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Popop_of_altergo
-open Popop_of_smtlib2
-open Interval
diff --git a/src/conflict.ml b/src/conflict.ml
deleted file mode 100644
index fffcbaa80..000000000
--- a/src/conflict.ml
+++ /dev/null
@@ -1,1477 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Stdlib
-open Types
-open Explanation
-
-
-exception DontKnowThisCon
-exception DontKnowThisDec of Dom.K.t * Cl.t
-
-exception DomNeverSet
-exception ClNotEqual
-
-let debug = Debug.register_info_flag
- ~desc:"for@ the@ main@ part@ of@ conflicts."
- "Conflict.core"
-
-type 'a rescon = 'a Explanation.rescon =
-| GRequested: 'a -> 'a rescon
-| GOther: 'b con * 'b -> 'a rescon
-
-let return : type a b. a con -> b con -> b -> a rescon = fun con con' v ->
- match Explanation.Con.Eq.eq_type con con' with
- | Some Types.Eq -> GRequested v
- | None -> GOther(con',v)
-
-type explearnt =
-| ExpLearnt: Tags.t -> explearnt
-
-let explearnt : explearnt exp = Exp.create_key "Explanation.learnt_exp"
-let dom_bool : bool dom = Dom.create_key "bool"
-
-exception NotMarkedExp
-
-(*
-module type SemH = sig
- type k
- type v
- module S : Types.Sem with type t = k
- val h : v S.H.t
-end
-
-module SemH = Sem.MkVector(struct
- type ('a,'b) t = (module SemH with type k = 'a and type v = 'b)
- end)
-*)
-
-(** *)
-let hash_chogen = ref (fun _ -> assert false)
-let equal_chogen = ref (fun _ _ -> assert false)
-
-module ChoH = Stdlib.XHashtbl.Make(struct
- type t = chogen
- let hash chogen = !hash_chogen chogen
- let equal chogen1 chogen2 = !equal_chogen chogen1 chogen2
- end)
-
-(** Needed *)
-(*
-module AgeCache = struct
- module KeyCache = Types.Make_key(struct end)
- module Cache = KeyCache.MkVector(struct type ('a,'b) t = 'a end)
- type t = unit Cache.t Age.M.t
-
- let no_cache : unit KeyCache.k = KeyCache.create_key "no cache"
-
- let new_cache () = Cache.create (KeyCache.hint_size ())
-
- let empty = Age.M.empty
- let copy m = Age.M.map (fun _ -> new_cache ()) m
- let add_age m age = Age.M.add_new Impossible age (new_cache ()) m
-
- let get_cache m age =
- match Age.M.find_smaller_opt age m with
- | None -> assert false (** The age must be added in advance then used *)
- | Some (_,c) -> c
-
- let is_cached c key = not (Cache.is_uninitialized c key)
- let get_cached c key =
- if Cache.is_uninitialized c key
- then None else Some (Cache.get c key)
- let set_cached c key v =
- if KeyCache.equal key no_cache then () else
- Cache.set c key v
-
- let nb_hit = Debug.register_stats_int ~name:"Rlist.Cache.hit" ~init:0
- let nb_miss = Debug.register_stats_int ~name:"Rlist.Cache.miss" ~init:0
-
- let memoise f agecache key age x =
- let agecache = get_cache agecache age in
- match get_cached agecache key with
- | None ->
- Debug.incr nb_miss;
- let r = f age x in
- (** f can run for the same key and an age in the same interval *)
- if Cache.is_uninitialized agecache key then
- set_cached agecache key r
- else
- Debug.dprintf0 debug "[memoise] @[memoise: cycle?@]@\n";
- r
- | Some r ->
- Debug.incr nb_hit;
- r
-
- type 'a cache = 'a KeyCache.k
- let create_cache = KeyCache.create_key
-
-end
-*)
-type edge = {
- eto : Cl.t; (** equals to *)
- epexp : pexp (** explication for this merge *);
- einv : bool; (** which way was pexp *)
-}
-
-let print_edge fmt e =
- Format.fprintf fmt "M(%a,@,%a,@,%b)"
- Cl.print e.eto !print_pexp e.epexp e.einv
-
-type rlist = edge list
-
-let print_rlist fmt l = Pp.print_list Pp.semi print_edge fmt l
-
-(** Con_iter *)
-type con_iter = {
- csolver : Solver.t; (** state before the last dec *)
- csolver_unsat : Solver.t;
- (** state at unsat (* TODO remove just for first_sem *)*)
- mutable cdeps : Explanation.Deps.t;
- ctrail : Explanation.t;
- cinvclhist: Explanation.invclhist;
- cdomcho: chogen Cl.H.t Dom.Vector.t;
- cdomage: Age.t Cl.H.t Dom.Vector.t;
- cseen : Explanation.concache Simple_vector.t; (** to clear at the end *)
-}
-
-let create_con_iter solver solver_unsat trail =
- let con_iter = {
- csolver = solver;
- csolver_unsat = solver_unsat;
- cdeps = Deps.empty;
- ctrail = trail;
- cinvclhist = Explanation.invclhist trail;
- cseen = Simple_vector.create 0;
- cdomcho = Dom.Vector.create (Dom.hint_size ());
- cdomage = Dom.Vector.create (Dom.hint_size ());
- } in
- (*
- Debug.dprintf4 debug "@[invclhist:%a@\ndomhist:%a@]@\n"
- Explanation.print_invclhist con_iter.cinvclhist
- Explanation.print_domhist trail.domhist;
- *)
- (** initialization of cdomage *)
- Dom.iter {Dom.iter = (fun dom ->
- Dom.Vector.set con_iter.cdomage dom (Cl.H.create 10))};
- (** initialization of ccdomcho *)
- Dom.iter {Dom.iter = (fun dom ->
- Dom.Vector.set con_iter.cdomcho dom (Cl.H.create 10))};
- con_iter
-
-let confact : unit con = Con.create_key "Core.fact"
-let conclause: bool Cl.M.t Explanation.con =
- Explanation.Con.create_key "Bool.clause"
-
-
-
-let return_rescon (type a) (type b) (con : a con) (x:a)
- (conrequested : b con) : b rescon =
- match Con.Eq.eq_type con conrequested with
- | None -> (GOther (con,x) : b rescon)
- | Some Types.Eq -> GRequested x
-
-
-let mk_confact con = return_rescon confact () con
-
-let return_nothing con = return con confact ()
-
-let _print_dom_can_be_at_current fmt v =
- Dom.Vector.print Pp.newline Pp.space
- {Dom.Vector.printk = Dom.print}
- (Pp.print_iter2 Cl.H.iter Pp.semi Pp.comma Cl.print DBool.print) fmt v
-
-
-type testconflict =
- | False (* false in this context *)
- | True (* true in this context *)
- | ToDecide (* can be decided *)
-
-
-type 'a fold_decisions =
- {fold_decisions : 'k 'd. ('a -> ('k,'d) cho -> 'k -> 'd -> 'a) }
-
-class type finalized = object
- method print: Format.formatter -> unit
- method conflict_add: Solver.Delayed.t -> bool Cl.M.t
- method test: Solver.Delayed.t -> testconflict
- method decide: 'a. 'a fold_decisions -> Solver.Delayed.t -> 'a -> 'a
- (** to call only when test is [Todecide] *)
-end
-
-let print_finalized fmt fin = fin#print fmt
-
-(** Con *)
-module type Con' = sig
-
- type t
-
- val print: t Pp.printer
-
- val same_sem:
- con_iter -> age -> 'a sem -> 'a ->
- pexp -> Cl.t -> Cl.t -> t rescon
-
- val propacl : con_iter -> Age.t -> Cl.t -> Cl.t -> t rescon
-
- val finalize: con_iter -> t Bag.t -> finalized option
-
-end
-
-module VCon = Con.MkVector
- (struct type ('a,'unedeed) t =
- (module Con' with type t = 'a)
- end)
-
-let defined_con : unit VCon.t = VCon.create 8
-
-let get_con k =
- assert (if VCon.is_uninitialized defined_con k
- then raise UnregisteredKey else true);
- VCon.get defined_con k
-
-let print_con (type a) (con : a con) fmt (k:a) =
- let module C = (val get_con con) in
- C.print fmt k
-
-let print_rescon (type a) (con : a con) fmt (r:a rescon) =
- match r with
- | GRequested k -> print_con con fmt k
- | GOther (cono,k) -> Format.fprintf fmt "%a of %a"
- (print_con cono) k
- Con.print cono
-
-
-(** Exp con Registration *)
-module type Exp' = sig
-
- type t
-
- val print: t Pp.printer
-
- (* val iterexp: exp_iter -> age -> t -> unit *)
-
- val analyse : con_iter -> age ->
- 'a con -> t -> 'a rescon
-
- val expdom : con_iter -> age ->
- 'b dom -> Cl.t ->
- 'a con -> t -> 'a rescon
-
-end
-
-module VExp = Exp.MkVector
- (struct type ('a,'unedeed) t =
- (module Exp' with type t = 'a)
- end)
-
-let defined_exp : unit VExp.t = VExp.create 8
-
-let get_exp k =
- assert (if VExp.is_uninitialized defined_exp k
- then raise UnregisteredKey else true);
- VExp.get defined_exp k
-
-let print_pexp fmt (Pexp(age,k,exp,_tag,_)) =
- let f (type b) k exp =
- let s = get_exp k in
- let module S = (val s : Exp' with type t = b) in
- Format.fprintf fmt "exp %a:%a@ at %a"
- Exp.print k S.print exp Age.print age
- in
- f k exp
-
-let () = Explanation.print_pexp := print_pexp
-
-(** Choice *)
-type 'd decdone =
-| DecNo (** no decision to do *)
-| DecTodo of 'd (** this decision should be done *)
-
-module type Cho' = sig
-
- type k
- type d
-
- module Key : Stdlib.Datatype with type t = k
- module Data: sig
- type t = d
- val print: t Pp.printer
- end
-
- val choose_decision:
- Solver.Delayed.t -> Key.t -> Data.t decdone
-
- val make_decision:
- Solver.Delayed.t -> dec -> Key.t -> Data.t -> unit
-
- val analyse:
- con_iter -> 'a con -> Key.t -> Data.t -> 'a rescon
-
-end
-
-
-let print_modif fmt = function
- | Cl (cl1,cl2) -> Format.fprintf fmt "Cl %a -> %a" Cl.print cl1 Cl.print cl2
- | Dom (cl,dom,_,cl0) -> Format.fprintf fmt "Dom %a for %a(%a)"
- Dom.print dom Cl.print cl0 Cl.print cl;
- | Dec _ -> Format.fprintf fmt "Dec"
- | DomL (cl,dom,v,_,_,cl0) ->
- Format.fprintf fmt "DomL %a for %a(%a) with value %a"
- Dom.print dom Cl.print cl0 Cl.print cl (Pp.print_option_or_default "None"
- (Solver.print_dom dom)) v;;
-
-let () = Explanation.print_modif_ref := print_modif
-
-(** Give for explanation that something is the last before the limit.
- So we generalize on that. *)
-type explimit =
- | LCl: Cl.t * Cl.t -> explimit
- (** At the limit the first cl is represented by this cl *)
- | LDom: 'a dom * Explanation.mod_dom -> explimit
- (** At the limit this class have this value for this dom *)
-
-let print_explimit fmt = function
- | LCl (cl,rcl) -> Format.fprintf fmt "LCl(%a,%a)" Cl.print cl Cl.print rcl
- | LDom (dom,moddom) ->
- Format.fprintf fmt "LDom(%a,%a)" Dom.print dom
- Explanation.print_mod_dom moddom
-
-let explimit : explimit exp = Exp.create_key "Conflict.explimit"
-
-let is_explimit (Pexp(_,exp,k,_,_)) =
- match Exp.Eq.eq_type explimit exp with
- | Some Types.Eq -> Some (k : explimit)
- | None -> None
-
-
-module ComputeConflict = struct
- let debug = Debug.register_info_flag
- ~desc:"for@ the@ computation@ part@ of@ conflicts."
- "Conflict.compute"
-
- type t = con_iter
-
- let before_first_dec t age = Explanation.before_first_dec t.ctrail age
- let _after_last_dec t age = Age.compare t.ctrail.last_dec age <= 0
-
- type get_equal_aux =
- | GEANoPath
- | GEAAfterDec of rlist
- | GEABeforeDec of Age.t * Cl.t * rlist
-
- let get_equal t age cl1 cl2 =
- let rec aux last_dec dest clgraph age prev cl = function
- | [] -> GEANoPath
- | node::l when Cl.equal node.ncl prev ->
- aux last_dec dest clgraph age prev cl l
- | node::l ->
- let r =
- if Cl.equal node.ncl dest
- then GEAAfterDec []
- else
- let edge = Cl.M.find node.ncl clgraph in
- aux last_dec dest clgraph age cl node.ncl edge
- in
- let after = Age.compare last_dec node.nage <= 0 in
- match r with
- | GEANoPath -> aux last_dec dest clgraph age prev cl l
- | GEAAfterDec l when after ->
- GEAAfterDec ({eto=node.ncl;epexp=node.npexp;einv=node.ninv}::l)
- | GEAAfterDec l -> (** limit before -> after *)
- GEABeforeDec (node.nage,node.ncl,l)
- | GEABeforeDec (age,ncl,l) when not after ->
- GEABeforeDec (Age.max node.nage age,ncl,l)
- | GEABeforeDec (age,cln,l) -> (** limit after -> before *)
- let pexp =
- Explanation.mk_pexp_direct
- ~age:age
- explimit (LCl (node.ncl,cln)) in
- GEAAfterDec({eto=node.ncl;epexp=node.npexp;einv=node.ninv}::
- {eto=cln;epexp=pexp;einv=false}::l)
- in
- if Cl.equal cl2 cl1
- then []
- else
- let clgraph = t.ctrail.clgraph in
- let edge = Cl.M.find cl1 clgraph in
- let r = aux t.ctrail.last_dec cl2 clgraph age cl1 cl1 edge in
- match r with
- | GEANoPath -> raise ClNotEqual
- | GEABeforeDec (age,cln,l) ->
- let pexp =
- Explanation.mk_pexp_direct
- ~age:age
- explimit (LCl (cl1,cln)) in
- {eto=cln;epexp=pexp;einv=false}::l
- | GEAAfterDec l -> l
-
- let rec get_repr_at t age cl =
- try
- let (agemerge,cl') = Cl.M.find cl t.ctrail.clhist in
- if Age.compare age agemerge < 0 then cl
- else get_repr_at t age cl'
- with Not_found -> cl
-
- let rec get_repr_at_hist t age acc cl =
- try
- let (agemerge,cl') = Cl.M.find cl t.ctrail.clhist in
- if Age.compare age agemerge < 0 then cl,acc
- else get_repr_at_hist t age (agemerge::acc) cl'
- with Not_found -> cl,acc
-
- let get_dom t age cl0 dom =
- let rec go_down ~ismergedone age acc = function
- | Explanation.DomNeverSet -> acc
- | Explanation.DomSet(moddom,n)
- when Explanation.Age.compare
- moddom.Explanation.modage t.ctrail.last_dec < 0 ->
- let pexp =
- Explanation.mk_pexp_direct
- ~age:moddom.Explanation.modage
- explimit (LDom (dom,moddom)) in
- go_down ~ismergedone age ({moddom with modpexp = pexp}::acc) n
- | Explanation.DomSet(moddom,n)
- when Explanation.Age.compare moddom.Explanation.modage age <= 0 ->
- go_down ~ismergedone age (moddom::acc) n
- | Explanation.DomMerge(agemerge,n1,n2) ->
- let applicable = Explanation.Age.compare agemerge age <= 0 in
- assert (not ismergedone || applicable );
- let acc = if applicable
- then go_down ~ismergedone:true age acc n1 else acc in
- go_down ~ismergedone:applicable age acc n2
- | Explanation.DomPreMerge(agemerge,_,n1,n2) ->
- let applicable = Explanation.Age.compare agemerge age <= 0 in
- assert (not ismergedone || applicable );
- let acc = if not ismergedone && applicable
- then go_down ~ismergedone:true age acc n1 else acc in
- go_down ~ismergedone:applicable age acc n2
- | Explanation.DomSet(_,n) ->
- (** The age is not reached, go down further *)
- assert (acc == []);
- assert (not ismergedone);
- go_down ~ismergedone:false age acc n in
- assert (Explanation.Age.compare t.ctrail.last_dec age <= 0);
- let clr = (get_repr_at t age cl0) in
- let domhist_node =
- Cl.M.find_def
- Explanation.DomNeverSet
- clr
- (Dom.Vector.get t.ctrail.domhist dom) in
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "@[get_repr_at %a %a = %a@, domhist %a@]@\n" *)
- (* Age.print age Cl.print cl0 Cl.print clr print_domhist_node
- domhist_node; *)
- let acc = go_down ~ismergedone:false age [] domhist_node in
- if acc == [] then raise DomNeverSet else acc
-
- let get_dom_path t age cl0 dom =
- let rec go_down age acc hcl hdom =
- match hdom,hcl with
- | Explanation.DomNeverSet, _ -> acc
- | Explanation.DomSet(moddom,n), _
- when Explanation.Age.compare
- moddom.Explanation.modage t.ctrail.last_dec < 0 ->
- let pexp =
- Explanation.mk_pexp_direct
- ~age:moddom.Explanation.modage
- explimit (LDom (dom,moddom)) in
- go_down age ({moddom with modpexp = pexp}::acc) hcl n
- | Explanation.DomSet(moddom,n), _
- when Explanation.Age.compare moddom.Explanation.modage age <= 0 ->
- go_down age (moddom::acc) hcl n
- | Explanation.DomMerge(agemerge,_,n2), _
- when Explanation.Age.compare agemerge age > 0 ->
- (** before age *)
- go_down age acc hcl n2
- | Explanation.DomMerge(agemerge,n1,_), agemerge'::hcl when
- Age.equal agemerge agemerge' ->
- (** merged from not representative *)
- go_down age acc hcl n1
- | Explanation.DomMerge(_,_,n2), _ ->
- go_down age acc hcl n2
- | Explanation.DomPreMerge(_,cl,n1,_), _ ->
- let _,hcl = get_repr_at_hist t age [] cl in
- go_down age acc hcl n1
- | Explanation.DomSet(_,n), _ ->
- assert (acc == []); go_down age acc hcl n in
- assert (Explanation.Age.compare t.ctrail.last_dec age <= 0);
- let clr,clhist = get_repr_at_hist t age [] cl0 in
- let domhist_node =
- Cl.M.find_def
- Explanation.DomNeverSet
- clr
- (Dom.Vector.get t.ctrail.domhist dom) in
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "@[get_repr_at %a %a = %a@, domhist %a@]@\n" *)
- (* Age.print age Cl.print cl0 Cl.print clr print_domhist_node
- domhist_node; *)
- let acc = go_down age [] clhist domhist_node in
- if acc == [] then raise DomNeverSet else acc
-
-
- let get_dom_last t age cl0 dom =
- let rec go_down age hcl hdom =
- match hdom,hcl with
- | Explanation.DomNeverSet, _ -> raise DomNeverSet
- | Explanation.DomSet(moddom,_), _
- when Explanation.Age.compare
- moddom.Explanation.modage t.ctrail.last_dec < 0 ->
- let pexp =
- Explanation.mk_pexp_direct
- ~age:moddom.Explanation.modage
- explimit (LDom (dom,moddom)) in
- {moddom with modpexp = pexp}
- | Explanation.DomSet(moddom,_), _
- when Explanation.Age.compare moddom.Explanation.modage age <= 0 ->
- moddom
- | Explanation.DomMerge(agemerge,_,n2), _
- when Explanation.Age.compare agemerge age > 0 ->
- (** before age *)
- go_down age hcl n2
- | Explanation.DomMerge(agemerge,n1,_), agemerge'::hcl when
- Age.equal agemerge agemerge' ->
- (** merged from not representative *)
- go_down age hcl n1
- | Explanation.DomMerge(_,_,n2), _ ->
- go_down age hcl n2
- | Explanation.DomPreMerge(_,cl,n1,_), _ ->
- let _,hcl = get_repr_at_hist t age [] cl in
- go_down age hcl n1
- | Explanation.DomSet(_,n), _ ->
- go_down age hcl n in
- assert (Explanation.Age.compare t.ctrail.last_dec age <= 0);
- let clr,clhist = get_repr_at_hist t age [] cl0 in
- let domhist_node =
- Cl.M.find_def
- Explanation.DomNeverSet
- clr
- (Dom.Vector.get t.ctrail.domhist dom) in
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "@[get_repr_at %a %a = %a@, domhist %a@]@\n" *)
- (* Age.print age Cl.print cl0 Cl.print clr print_domhist_node
- domhist_node; *)
- go_down age clhist domhist_node
-
-
- let unknown_con t con a : unit =
- t.cdeps <- Deps.add_unknown_con t.cdeps con a
-
- let add_deps t deps =
- t.cdeps <- Deps.concat t.cdeps deps
-
-
- let get_current_deps t = t.cdeps
-
- let get_pexp_aux (type a) t pexp (con: a con) : a rescon * Deps.t =
- let Pexp(age,k,exp,tags,concache) = pexp in
- Debug.dprintf4 debug
- "analyse@ pexp %a@ into@ con %a@\n @["
- print_pexp pexp Con.print con;
- assert (Exp.equal k explimit ||
- Exp.equal k expcho ||
- Exp.equal k explearnt ||
- Explanation.Age.compare t.ctrail.last_dec age <= 0);
- let f (type b) (k : b exp) (exp: b) =
- let s = get_exp k in
- let module S = (val s : Exp' with type t = b) in
- let r = S.analyse t age con exp in
- Debug.dprintf2 debug "Done:@,%a@]@\n" (print_rescon con) r;
- t.cdeps <- Deps.add_tags t.cdeps tags;
- r
- in
- if Concache.is_set concache con
- then
- let (r,_ as rdeps) = Concache.get concache con in
- Debug.dprintf2 debug "Cached:@,%a@]@\n" (print_rescon con) r;
- rdeps
- else
- let cdeps_saved = t.cdeps in
- t.cdeps <- Deps.empty;
- let r = f k exp in
- let rdeps = r,t.cdeps in
- Concache.set concache con rdeps;
- Simple_vector.push t.cseen concache;
- t.cdeps <- cdeps_saved;
- rdeps
-
- let get_pexp_deps :
- type a. con_iter -> pexp -> a con -> a rescon * Deps.t =
- fun t pexp (con: a con) ->
- get_pexp_aux t pexp con
-(* let Pexp(age,k,exp,_,_) = pexp in
- match Exp.Eq.eq_type k expdirect with
- | None -> get_pexp_aux t pexp con
- | Some Types.Eq ->
- match exp with
- | DirectDom(dom,cl) ->
- match get_dom t age cl dom with
- | , _ when Age.compare age agemerge >= 0 ->
- assert false (** Because directdom is possible only when the
- class is a representative *)
- | _, pexp -> get_pexp_deps t pexp con
-*)
-
- let get_pexp t pexp con =
- let r,deps = get_pexp_deps t pexp con in
- (* Format.fprintf (Debug.get_debug_formatter ()) "("; *)
- add_deps t deps;
- (* Format.fprintf (Debug.get_debug_formatter ()) ")"; *)
- r
-
- (** add because we will have multiple value *)
- let set_dec_cho t cho k =
- t.cdeps <- Deps.add_chogen t.cdeps (GCho(cho,k))
-
- let set_dec_cho_cond t dom cl cho k =
- Cl.H.add (Dom.Vector.get t.cdomcho dom) cl (GCho(cho,k))
-
- let compute_con_iter solver solver_unsat trail pexp =
- let state = create_con_iter solver solver_unsat trail in
- let rescon = get_pexp state pexp conclause in
- begin match rescon with
- | GRequested s -> unknown_con state conclause s
- | GOther (con,c) -> unknown_con state con c
- end;
- (** clear the cache *)
- Simple_vector.iter_initialized Concache.clear state.cseen;
- state
-
- type iter = con_iter
- let dep_dec (type a) iter (dom: a dom) cl : unit =
- let lchogen =
- Cl.H.find_all (Dom.Vector.get iter.cdomcho dom) cl in
- let lchoage =
- Cl.H.find_all (Dom.Vector.get iter.cdomage dom) cl in
- if lchogen == [] && lchoage == [] then
- raise (DontKnowThisDec (((dom : a Dom.k) :> Dom.K.t),cl));
- iter.cdeps <- List.fold_left Deps.add_chogen iter.cdeps lchogen
-
- class wrapp (l:finalized list) : finalized = object
- method print fmt = (Pp.print_list Pp.semi (fun fmt c -> c#print fmt)) fmt l
- method test d =
- try
- List.fold_left (fun acc c ->
- match c#test d with
- | False -> acc
- | True -> raise Exit
- | ToDecide -> ToDecide) False l
- with Exit -> True
-
- method decide:
- 'a. 'a fold_decisions -> Solver.Delayed.t -> 'a -> 'a =
- fun f d acc ->
- List.fold_left (fun acc (c:finalized) -> c#decide f d acc) acc l
-
- method conflict_add d =
- List.fold_left
- (fun acc c -> Cl.M.union (fun _ b1 b2 -> assert (b1 == b2); Some b1)
- (c#conflict_add d) acc) Cl.M.empty l
- end
-
-
- let finalize state =
- let fold (type b) acc con l =
- if Con.equal con confact then acc
- else
- let con = get_con con in
- let module C = (val con : Con' with type t = b) in
- match C.finalize state l with
- | None -> acc
- | Some mcl -> mcl::acc
- in
- let deps = Deps.compute_deps state.cdeps in
- let acc =
- Conunknown.fold {Conunknown.fold} [] deps.Deps.unknown in
- match acc with
- | [] -> None,deps.Deps.tags, deps.Deps.decs
- | l -> Some (new wrapp l), deps.Deps.tags, deps.Deps.decs
-
-end
-
-
-(*
-module IterExp = struct
- let debug = Debug.register_info_flag
- ~desc:"for@ the@ explanation@ part@ of@ conflicts."
- "Conflict.exp"
-
- exception AgeTooYoung
- exception AgeTooOld
- open Tmp
- let rec get_repr_at age cl = function
- | CMerge(rcl,agemerge,_rpexp,l,_) when Age.compare age agemerge >= 0 ->
- (** get_trl can't fail since it have been completed for this age *)
- get_repr_at age rcl (get_trl l)
- | CRepr | CMerge _ -> cl
-
- type t = exp_iter
-
- (** This function must record what we must look for in the trail at
- the current level, or when the modification occured at a lower
- level we must create an explimit. Said differently it record the
- reason of the modification between the conflict and
- the state at the last decision *)
-
- let check_age t age =
- assert (if Age.compare age t.tage > 0 then raise AgeTooYoung
- else if not (Explanation.at_current_level t.etrail age)
- then raise AgeTooOld
- else true)
-
- let merge_at_current_level t = function
- | CRepr -> true
- | CMerge(_,agemerge,_,_,_) -> Explanation.at_current_level t.etrail agemerge
-
- let rec add_needed_cl' t age cl =
- match Cl.M.find_opt cl t.tclhist with
- | Some (agemerge,rcl) when Age.compare age agemerge >= 0 ->
- Debug.dprintf4 debug "[Exp] to look for cl %a at %a@\n"
- Cl.print cl Age.print agemerge;
- if Explanation.at_current_level t.etrail agemerge then begin
- (** We look for the explication in the trail *)
- let l = add_needed_cl t age rcl in
- let l = CMerge(rcl,agemerge,create_po (),init_trl l,AgeCache.empty) in
- Age.H.replace t.lookforcl agemerge l;
- l
- end else begin
- let l = add_needed_cl t age rcl in
- let rcl,agemerge,l =
- match l with
- | CRepr -> rcl,agemerge,l
- | CMerge(_,age,_,_,_)
- when Explanation.at_current_level t.etrail age ->
- rcl,agemerge,l
- (** Not None because it is a previously added explimit*)
- (** replace the head with a one for this cl *)
- | CMerge(rcl,agemerge,pexp,rl,_) ->
- assert ( match Rlist.Tmp.get_opt_po pexp with
- | None -> false
- | Some {em_pexp = Pexp(_,exp,_,_,_)} ->
- Exp.equal exp explimit);
- rcl,agemerge,Rlist.Tmp.get_trl rl in
- (** rcl is the representative at the limit *)
- let pexp = Explanation.mk_pexp_direct
- ~age:agemerge
- explimit (LCl (cl,rcl)) in
- let pexp = {em_other_cl = rcl; em_other_rl = CRepr;
- em_pexp = pexp;
- em_repr_cl = rcl; em_repr_rl = CRepr;
- } in
- CMerge(rcl,agemerge,init_po pexp,init_trl l,AgeCache.empty)
- end
- | Some (agemerge,rcl) ->
- assert (Age.compare age agemerge < 0);
- assert (Explanation.at_current_level t.etrail agemerge);
- CMerge (rcl, agemerge, create_po (), create_trl (),AgeCache.empty)
- | None -> CRepr
-
- and complete_needed_cl t age cl l =
- assert (Cl.H.find t.needed.ncl cl == l);
- match l with
- | CRepr -> ()
- | CMerge(rcl,agemerge,rpexp,rl',_) ->
- match get_opt_trl rl' with
- | Some l' -> complete_needed_cl t age rcl l'
- | None when Age.compare age agemerge >= 0 ->
- let l' = add_needed_cl t age rcl in
- Age.H.replace t.lookforcl agemerge l;
- set_trl l l'
- | None -> ()
-
- and add_needed_cl t age cl =
- try
- let l = Cl.H.find t.needed.ncl cl in
- complete_needed_cl t age cl l;
- l
- with Not_found ->
- let l = add_needed_cl' t age cl in
- assert (not (Cl.H.mem t.needed.ncl cl));
- Cl.H.add t.needed.ncl cl l;
- l
-
- let need_cl_repr t age cl =
- check_age t age;
- let l = add_needed_cl t age cl in
- Debug.dprintf2 debug "[Exp] @[need_cl_repr: %a@]@\n" Rlist.Tmp.print l
-
-
- (** What about none at limit? What is none for a value of a dom *)
- let dom_not_none_at_limit = function
- | None -> raise DomNoneAtLimit
- | Some v -> v
-
- let save_dom_at_limit t lastlevel rcl dom v =
- let hcl = Dom.Vector.get t.needed.ndom dom in
- let mage = Cl.H.find_def hcl Age.M.empty rcl in
- Debug.dprintf6 debug "[Exp] @[save dom at limit %a for %a at %a@]@\n"
- Dom.print dom Cl.print rcl Age.print lastlevel;
- let pexp =
- Explanation.mk_pexp_direct
- ~age:lastlevel
- explimit (LDom (dom,rcl,v)) in
- let mage = Age.M.add_new Impossible lastlevel pexp mage in
- Cl.H.add hcl rcl mage
-
- let dom_at_limit_saved t rcl dom =
- let hcl = Dom.Vector.get t.needed.ndom dom in
- let ages = Cl.H.find_def hcl Age.M.empty rcl in
- Age.M.find_smaller_opt (Explanation.last_dec t.etrail) ages != None
-
- let need_dom t age cl dom =
- Debug.dprintf6 debug "[Exp] @[need_dom %a for %a at %a@]@\n"
- Dom.print dom Cl.print cl Age.print age;
- check_age t age;
- let l = add_needed_cl t age cl in
- let rcl = get_repr_at age cl l in
- Debug.dprintf4 debug "[Exp] @[ repr:%a rl: %a@]@\n"
- Cl.print rcl Rlist.Tmp.print l;
- let dom_can_be_at_current_level =
- let hcl = Dom.Vector.get t.dom_can_be_at_current dom in
- try
- let b = Cl.H.find hcl rcl in
- assert (b
- || dom_at_limit_saved t rcl dom
- || raise DomNeverSet );
- b
- with Not_found ->
- let lastlevel = Explanation.last_dom DomNeverSet t.etrail dom rcl in
- Debug.dprintf4 debug "[Exp] @[ lastlevel: %a; rcl: %a@]@\n"
- Age.print lastlevel Cl.print rcl;
- if Explanation.at_current_level t.etrail lastlevel
- then begin Cl.H.add hcl rcl true; true end
- else begin
- (** rcl is the representative at the limit *)
- (** the domain is not at the current level, we do the needing
- book keeping *)
- Cl.H.add hcl rcl false;
- (** since lastlevel is before the current level what is
- currently associated in the state of the solver is the value of
- the domain at the limit for this cl *)
- let v = dom_not_none_at_limit
- (Solver.get_direct_dom t.solver dom rcl) in
- save_dom_at_limit t lastlevel rcl dom v;
- false
- end in
- Debug.dprintf1 debug "[Exp] @[dcbacl:%b@]@\n"
- dom_can_be_at_current_level;
- if dom_can_be_at_current_level then
- t.older.(Age.to_int age) <-
- FDom (rcl,dom)::t.older.(Age.to_int age)
-
-
- let need_sem (type a) t age (sem : a sem) v =
- Debug.dprintf6 debug "[Exp] @[need sem %a with value %a at %a@]@\n"
- Sem.print sem (Solver.print_sem sem) v Age.print age;
- check_age t age;
- let module Sem = (val (SemH.get t.needed.nsem sem)) in
- try
- let l = Sem.S.H.find Sem.h v in
- match l with
- | CRepr -> assert false
- | CMerge(rcl,agemerge,rpexp,l',_) when Age.compare age agemerge >= 0 ->
- assert (is_init_trl l');
- Debug.dprintf4 debug "[Exp] @[rcl=%a l=%a@]@\n"
- Cl.print rcl
- Rlist.Tmp.print l;
- complete_needed_cl t age rcl (get_trl l')
- | CMerge _ -> ()
- with Not_found ->
- match Solver.get_sem_first t.solver sem v with
- | None -> raise SemNeverSet
- | Some (rcl,agemerge,pexp) ->
- assert (Age.compare age agemerge >= 0);
- let l =
- if Explanation.at_current_level t.etrail agemerge then begin
- (** We look for the explication in the trail *)
- let l = add_needed_cl t age rcl in
- let l = CMerge(rcl, agemerge, create_po (), init_trl l,
- AgeCache.empty) in
- Age.H.replace t.lookforsem agemerge l;
- l
- end else begin
- let l = add_needed_cl t age rcl in
- let rcl,agemerge,l =
- match l with
- | CRepr -> rcl,agemerge,l
- | CMerge(_,age,_,_,_)
- when Explanation.at_current_level t.etrail age ->
- rcl,agemerge,l
- (** Not None because it is a previously added explimit*)
- (** replace the head with a one for this sem *)
- | CMerge(rcl,agemerge,pexp,rl,_) ->
- assert ( match Rlist.Tmp.get_opt_po pexp with
- | None -> false
- | Some {em_pexp = Pexp(_,exp,_,_,_)} ->
- Exp.equal exp explimit);
- rcl,agemerge,Rlist.Tmp.get_trl rl in
- (** rcl is the representative at the limit *)
- let pexp = Explanation.mk_pexp_direct
- ~age:agemerge
- explimit (LSem (sem,v,rcl)) in
- let pexp = {em_other_cl = rcl; em_other_rl = CRepr;
- em_pexp = pexp;
- em_repr_cl = rcl; em_repr_rl = CRepr;
- } in
- CMerge(rcl,agemerge,init_po pexp,init_trl l,AgeCache.empty)
- end
- in
- Debug.dprintf2 debug "[Exp] @[need_sem: %a@]@\n" Rlist.Tmp.print l;
- Sem.S.H.add Sem.h v l
-
- let doexp state (type a) (k : a exp) (exp : a ) age =
- let module Exp = (val (get_exp k) : Exp' with type t = a) in
- Exp.iterexp state age exp
-
-
- let need_pexp t (Pexp(age,k,exp,_,_)) =
- (** because explearnt is used for adding the conflict *)
- if not (Exp.equal k explearnt) &&
- not (Exp.equal k expfact) then begin
- check_age t age;
- doexp t k exp age
- end
-
-
- let rec find_now t = function
- | Cl(clo0,clr0,(Pexp(age,kexp,exp,_,_concache) as pexp)) -> begin
- match Age.H.find_opt t.lookforcl t.tage with
- | Some trl ->
- Age.H.remove t.lookforcl t.tage;
- let pexpmerge = {
- em_other_cl = clo0;
- em_other_rl = add_needed_cl t (Age.pred t.tage) clo0;
- em_pexp = pexp;
- em_repr_cl = clr0;
- em_repr_rl = add_needed_cl t (Age.pred t.tage) clr0;
- } in
- Debug.dprintf2 debug "[Exp] @[find_now cl %a@]@\n"
- Rlist.Tmp.print_pexpmerge pexpmerge;
- doexp t kexp exp age;
- set_po trl pexpmerge;
- | None -> () end;
- true
- | Sem(cl,sem,v,(Pexp(age,kexp,exp,_,_concache) as pexp)) -> begin
- match Age.H.find_opt t.lookforsem t.tage with
- | Some trl ->
- Age.H.remove t.lookforsem t.tage;
- Debug.dprintf8 debug
- "[Exp] @[find_now sem %a for %a with value %a by %a@]@\n"
- Sem.print sem Cl.print cl (Solver.print_sem sem) v
- print_pexp pexp;
- doexp t kexp exp age;
- let pexpmerge = {
- em_other_cl = cl;
- em_other_rl = CRepr;
- em_pexp = pexp;
- em_repr_cl = cl;
- em_repr_rl = CRepr;
- } in
- set_po trl pexpmerge
- | None -> () end;
- true
- | Dom(cl,dom,(Pexp(age,kexp,exp,_,_concache) as pexp)) ->
- let hcl = Dom.Vector.get t.lookfordom dom in
- let found = Cl.H.find_opt hcl cl in
- begin match found with
- | None -> ()
- | Some () ->
- Cl.H.remove hcl cl;
- Debug.dprintf6 debug "[Exp] @[find_now dom %a for %a by %a@]@\n"
- Dom.print dom Cl.print cl print_pexp pexp;
- doexp t kexp exp age;
- let hcl = Dom.Vector.get t.needed.ndom dom in
- let ages = Cl.H.find_def hcl Age.M.empty cl in
- assert (not (Age.M.mem t.tage ages));
- let ages = Age.M.add t.tage pexp ages in
- Cl.H.replace hcl cl ages
- end;
- true
- | DomL(cl,dom,v,lastlevel,pexp) ->
- Debug.dprintf4 debug "[Exp] @[find_now domL %a for %a@]@\n"
- Dom.print dom Cl.print cl;
- let hcl = Dom.Vector.get t.dom_can_be_at_current dom in
- if Cl.H.mem hcl cl then begin
- assert (Cl.H.find hcl cl);
- ignore(find_now t (Dom(cl,dom,pexp)))
- end;
- begin match v with
- | None -> () (** TODO what about this none?
- there is an assert in need_dom for it but...*)
- | Some v -> save_dom_at_limit t lastlevel cl dom v
- end;
- Cl.H.replace hcl cl false;
- true
- | Dec _ -> assert (t.tage == (Explanation.last_dec t.etrail));
- false
-
- let get_needed :
- Solver.t ->
- Explanation.t -> pexp -> rlist needed
- = fun solver t pexp ->
- let tage = current_age t in
- let state = {
- older = Array.make (Age.to_int tage + 1) [];
- lookforcl = Age.H.create 10;
- lookforsem = Age.H.create 10;
- tage;
- tclhist = clhist t;
- lookfordom = Dom.Vector.create (Dom.hint_size ());
- needed = { ncl = Cl.H.create 17;
- ndom = Dom.Vector.create (Dom.hint_size ());
- nsem = SemH.create (Sem.hint_size ())
- };
- solver;
- etrail = Solver.get_trail solver;
- dom_can_be_at_current = Dom.Vector.create (Dom.hint_size ());
- } in
-
- (** initialization of lookfor *)
- Dom.iter {Dom.iter = (fun dom ->
- Dom.Vector.set state.lookfordom dom (Cl.H.create 10))};
- (** initialization of needed *)
- Dom.iter {Dom.iter = (fun dom ->
- Dom.Vector.set state.needed.ndom dom (Cl.H.create 10))};
- Sem.iter {Sem.iter = (fun (type a) (sem : a sem) ->
- (** initialization of dom_can_be_at_current *)
- Dom.iter {Dom.iter = (fun dom ->
- Dom.Vector.set state.dom_can_be_at_current dom (Cl.H.create 10))};
- let module Sem = (val (Solver.get_sem sem)) in
- let module S = struct
- type k = a
- type v = Rlist.Tmp.tmprlist
- module S = Sem
- let h = S.H.create 5
- end in
- SemH.set state.needed.nsem sem (module S))};
-
- (** start from the conflict *)
- Debug.dprintf4 debug "[Exp] look at conflict age %a pexp %a@\n"
- Age.print tage print_pexp pexp;
- need_pexp state pexp;
-
- let add_current_to_look_for t =
- let iter = function
- | FDom (rcl, dom) ->
- Debug.dprintf6 debug "[Exp] @[to look for dom %a of %a at %a@]@\n"
- Dom.print dom Cl.print rcl Age.print t.tage;
- let hcl = Dom.Vector.get t.dom_can_be_at_current dom in
- if Cl.H.find_exn hcl Impossible rcl then
- Cl.H.replace (Dom.Vector.get t.lookfordom dom) rcl ()
- (** otherwise DomL have been previously reached *)
- in
- let current_one = t.older.(Age.to_int t.tage) in
- List.iter iter current_one
- in
-
- let rec lookdownthetrail state = function
- | [] ->
- assert (Age.equal state.tage (Age.pred Age.min));
- | modif::trail ->
- Debug.dprintf4 debug
- "[Exp] @[lookdownthetrail age %a@ trail %a@]@\n"
- Age.print state.tage print_modif modif;
- Debug.dprintf2 debug
- "[Exp] @[state.dom_can_be_at_current: %a@]@\n"
- print_dom_can_be_at_current state.dom_can_be_at_current;
- add_current_to_look_for state;
- if find_now state modif then begin
- state.tage <- Age.pred state.tage;
- lookdownthetrail state trail
- end
- in
-
- lookdownthetrail state (trail t);
- (** Check nothing remains *)
- assert (Dom.Vector.fold_initialized
- (fun acc h -> acc && Cl.H.is_empty h)
- true state.lookfordom);
- Rlist.conv state.needed
-
-
-
-end
-*)
-module type Exp = sig
-
- type t
-
- val print: t Pp.printer
-
- val key: t exp
-
- (* val iterexp: IterExp.t -> age -> t -> unit *)
-
- val analyse : ComputeConflict.t -> age ->
- 'a con -> t -> 'a rescon
-
- val expdom : ComputeConflict.t -> age ->
- 'b dom -> Cl.t ->
- 'a con -> t -> 'a rescon
-
- end
-
-module RegisterExp (D:Exp) = struct
-
- let () =
- VExp.inc_size D.key defined_exp;
- assert (if not (VExp.is_uninitialized defined_exp D.key)
- then raise AlreadyRegisteredKey else true);
- let exp = (module D: Exp' with type t = D.t) in
- VExp.set defined_exp D.key exp
-end
-
-module type Con = sig
-
- type t
-
- val print: t Pp.printer
-
- val key: t con
-
- val same_sem:
- ComputeConflict.t -> age -> 'a sem -> 'a ->
- pexp -> Cl.t -> Cl.t -> t rescon
-
- val propacl : con_iter -> Age.t -> Cl.t -> Cl.t -> t rescon
-
- val finalize: ComputeConflict.iter -> t Bag.t -> finalized option
-
-end
-
-module RegisterCon (D:Con) = struct
-
- let () =
- VCon.inc_size D.key defined_con;
- assert (if not (VCon.is_uninitialized defined_con D.key)
- then raise AlreadyRegisteredKey else true);
- let con = (module D: Con' with type t = D.t) in
- VCon.set defined_con D.key con
-
-end
-
-
-let analyse solver solver_unsat trail pexp =
- (* Debug.dprintf0 debug "[Conflict] 1) find explanation@\n"; *)
- (* let needed = IterExp.get_needed solver t pexp in *)
- Debug.dprintf0 debug "[Conflict] 2) Computation generate conflict@\n";
- let coniter =
- ComputeConflict.compute_con_iter solver solver_unsat trail pexp in
- Debug.dprintf0 debug "[Conflict] 3) Finalize conflict@\n";
- ComputeConflict.finalize coniter
-
-module type Cho = sig
- module Key : Stdlib.Datatype
- module Data: sig
- type t
- val print: t Pp.printer
- end
-
- val choose_decision:
- Solver.Delayed.t -> Key.t -> Data.t decdone
-
- val make_decision:
- Solver.Delayed.t -> dec -> Key.t -> Data.t -> unit
-
- val analyse:
- ComputeConflict.t -> 'a con -> Key.t -> Data.t -> 'a rescon
-
- val key: (Key.t,Data.t) cho
-
-end
-
-
-module VCho = Cho.MkVector
- (struct type ('k,'d,'unedeed) t =
- (module Cho' with type k = 'k and type d = 'd)
- end)
-
-let defined_cho : unit VCho.t = VCho.create 8
-
-let get_cho k =
- assert (if VCho.is_uninitialized defined_cho k
- then raise UnregisteredKey else true);
- VCho.get defined_cho k
-
-let () =
- hash_chogen := (function
- | Explanation.GCho (cho,k) ->
- let module C = (val get_cho cho) in
- Hashcons.combine (Cho.hash cho) (C.Key.hash k)
- );
- equal_chogen :=
- (fun (Explanation.GCho(cho1,k1)) (Explanation.GCho(cho2,k2)) ->
- match Cho.Eq.eq_type cho1 cho2 with
- | Some (Types.Eq, Types.Eq) ->
- let module C = (val get_cho cho1) in
- C.Key.equal k1 k2
- | None -> false
- )
-
-
-module RegisterCho(C:Cho) = struct
-
- let () =
- VCho.inc_size C.key defined_cho;
- assert (if not (VCho.is_uninitialized defined_cho C.key)
- then raise AlreadyRegisteredKey else true);
- let module C = struct include C type k = Key.t type d = Data.t end in
- let cho = (module C: Cho' with type k = C.Key.t and type d = C.Data.t) in
- VCho.set defined_cho C.key cho
-
-end
-
-let choose_decision (type k) (type d) d (cho : (k,d) cho) k =
- let module Cho = (val (get_cho cho)) in
- match Cho.choose_decision d k with
- | DecNo -> DecNo
- | DecTodo v ->
- DecTodo (fun d dec -> Cho.make_decision d dec k v)
-
-let make_decision (type k) (type d) d (cho : (k,d) cho) k v dec =
- let module Cho = (val (get_cho cho)) in
- Cho.make_decision d dec k v
-
-let print_pcho fmt = function
- | Pcho(dec,cho,k,d) ->
- let module C = (val get_cho cho) in
- Format.fprintf fmt "Pcho(%a,%a,%a,%a)"
- Age.print (age_of_dec dec)
- Cho.print cho
- C.Key.print k
- C.Data.print d
-
-let print_chogen fmt = function
- | GCho(cho,k) ->
- let module C = (val get_cho cho) in
- Format.fprintf fmt "GCho(%a,%a)"
- Cho.print cho
- C.Key.print k
-
-module ExpCho = struct
- type t = pcho
-
- let print = print_pcho
-
- let key = expcho
-
- let analyse (type a) t _ (con: a con) (Pcho(_,cho,k,v)) =
- let f (type k) (type d) t con (cho : (k,d) cho) k v =
- let module C = (val get_cho cho) in
- C.analyse t con k v in
- f t con cho k v
-
- let expdom t age _ _ con pcho =
- analyse t age con pcho
-
-end
-
-module EExpCho = RegisterExp(ExpCho)
-
-let fold_rescon_list t f con acc l =
- List.fold_left (fun acc e ->
- let c = ComputeConflict.get_pexp t e.epexp con in
- f acc t c) acc l
-
-let fold_rescon_list_deps t f con acc l =
- List.fold_left (fun (acc,deps) e ->
- let c,deps' = ComputeConflict.get_pexp_deps t e.epexp con in
- let deps = Deps.concat deps' deps in
- f (acc,deps) t c) acc l
-
-let fold_requested f acc t = function
- | GRequested s -> f acc t s
- | GOther (con,c) -> ComputeConflict.unknown_con t con c; acc
-
-let fold_requested_deps f ((acc,deps) as accdeps) t = function
- | GRequested s -> f accdeps t s
- | GOther (con,c) -> acc, Deps.add_unknown_con deps con c
-
-module ConFact = struct
- type t = unit
- let print = DUnit.print
-
- let key = confact
-
- let finalize _ = assert false (** catched before *)
-
- let same_sem t _ _ _ pexp2 _ _ =
- let get_con () t = function
- | GRequested () -> ()
- | GOther (con,c) -> ComputeConflict.unknown_con t con c
- in
- get_con () t (ComputeConflict.get_pexp t pexp2 confact);
- GRequested ()
-
- let propacl _ _ _ _ = raise Impossible
- let _propadom _ _ dom cl v =
- Debug.dprintf6 debug
- "[Conflict] @[Error: Ask ConFact for the limit for %a with %a of %a @]@\n"
- Cl.print cl Dom.print dom (Solver.print_dom_opt dom) v;
- raise Impossible
-
-end
-
-module EConFact = RegisterCon(ConFact)
-
-module ExpFact = struct
- type t = unit
-
- let print = DUnit.print
-
- let key = expfact
-
- let analyse (type a) _t _age (con: a con) () =
- mk_confact con
-
-
- let expdom t age _ _ con x =
- analyse t age con x
-
-
-end
-
-module EExpFact = RegisterExp(ExpFact)
-
-module ExpLimit = struct
- type t = explimit
-
- let print = print_explimit
-
- let key = explimit
-
- let analyse (type a) t age (con: a con) limit =
- match limit with
- | LCl (cl,rcl) ->
- let module C = (val (get_con con)) in
- C.propacl t age cl rcl
- | LDom (dom,{modcl;modage;modpexp}) ->
- let f (type b) (k : b exp) (exp: b) =
- let module S = (val (get_exp k) : Exp' with type t = b) in
- S.expdom t modage dom modcl con exp
- in
- let Pexp(_,k,exp,_,_) = modpexp in
- f k exp
-
- (** explimit only created in conflict and on pexp that are not from
- conflict *)
- let expdom _ _ _ _ _ _ = raise Impossible
-
-end
-
-module EExpLimit = RegisterExp(ExpLimit)
-
-module ExpSameSem = struct
- type t = Solver.exp_same_sem
-
- let print fmt = function
- | Solver.ExpSameSem(pexp,cl1,clsem2) ->
- Format.fprintf fmt "ExpSameSem(%a,%a,%a:%a)"
- print_pexp pexp
- Cl.print cl1
- Cl.print (ClSem.cl clsem2)
- ClSem.print clsem2
-
-
- let key = Solver.exp_same_sem
-(*
- let iterexp t age = function
- | Solver.ExpSameSem(pexp,_,_,k,sem) ->
- IterExp.need_sem t age k sem;
- IterExp.need_pexp t pexp
-*)
- let analyse (type b) t age (con : b con) = function
- | Solver.ExpSameSem(pexp,cl1,clsem2) ->
- assert (Ty.equal (Cl.ty cl1) (ClSem.ty clsem2));
- let module C = (val get_con con) in
- match Only_for_solver.sem_of_cl clsem2 with
- | Only_for_solver.Sem(sem,v) ->
- C.same_sem t age sem v pexp cl1 (ClSem.cl clsem2)
-
- (** not used for dom *)
- let expdom _ _ _ _ _ _ = raise Impossible
-
-end
-
-module EExpSameSem = RegisterExp(ExpSameSem)
-
-module ExpLearnt = struct
- type t = explearnt
-
- let print fmt = function
- | ExpLearnt(tags) ->
- Format.fprintf fmt "ExpLearnt(%a)"
- Tags.print tags
-
- let key = explearnt
-
- let analyse (type a) t _age (con: a con) (ExpLearnt(tags)) =
- t.cdeps <- Deps.add_tags t.cdeps tags;
- return con ConFact.key ()
-
- let expdom _ _ _ _ con _ =
- return con ConFact.key ()
-
-end
-
-module EExpLearnt = RegisterExp(ExpLearnt)
-
-let check_initialization () =
- let well_initialized = ref true in
-
- Exp.iter {Exp.iter = fun exp ->
- if VExp.is_uninitialized defined_exp exp then begin
- Format.eprintf
- "[Warning] The explanation %a is not registered@." Exp.print exp;
- well_initialized := false;
- end};
-
- Con.iter {Con.iter = fun con ->
- if VCon.is_uninitialized defined_con con then begin
- Format.eprintf
- "[Warning] The conflicts %a is not registered@." Con.print con;
- well_initialized := false;
- end};
-
- !well_initialized
-
-let print_conflicts = Debug.register_info_flag
- ~desc:"for@ the@ printing@ of@ the@ conflicts@ found."
- "conflicts"
-
-
-let print_decision = Debug.register_info_flag
- ~desc:"for@ the@ printing@ of@ the@ decisions@ done."
- "decisions"
-
-(** Helpers *)
-module ChoGenH = ChoH
-
-
-(** Exception printer *)
-let () = Exn_printer.register(fun fmt exn ->
- match exn with
- | DontKnowThisDec(dom,cl) ->
- Format.fprintf fmt "DontKnowThisDec(%a,%a)"
- Dom.K.print dom Cl.print cl
- | exn -> raise exn
- )
diff --git a/src/conflict.mli b/src/conflict.mli
deleted file mode 100644
index 967e434af..000000000
--- a/src/conflict.mli
+++ /dev/null
@@ -1,285 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
-open Explanation
-
-type 'a rescon = 'a Explanation.rescon =
-| GRequested: 'a -> 'a rescon
-| GOther: 'b con * 'b -> 'a rescon
-
-val return: 'a con -> 'b con -> 'b -> 'a rescon
-val return_nothing: 'a con -> 'a rescon
-(*
-module AgeCache: sig
- type t
- type 'a cache
- val create_cache: string -> 'a cache
- val no_cache: unit cache
-end
-*)
-(** An information can depend on a list of merge *)
-
-type edge = {
- eto : Cl.t; (** equals to *)
- epexp : pexp (** explication for this merge *);
- einv : bool; (** which way was pexp *)
-}
-
-val print_edge: edge Pp.printer
-
-type rlist = edge list
-
-val print_rlist: rlist Pp.printer
-(*
-module IterExp : sig
- exception AgeTooYoung
-
- type t
-
- val need_equal : t -> age -> Cl.t -> Cl.t -> unit
- val need_dom : t -> age -> Cl.t -> 'a dom -> unit
- val need_sem : t -> 'a sem -> 'a -> unit
- val need_pexp : t -> pexp -> unit
-
-end
-*)
-exception NotMarkedExp
-
-module ComputeConflict: sig
- type t
-
- val before_first_dec: t -> Age.t -> bool
-
- val get_equal: t -> age -> Cl.t -> Cl.t -> rlist
- (** get the list of merge that make the too classes equal. *)
- val get_repr_at: t -> age -> Cl.t -> Cl.t
- (** get the repr of the class at this age . *)
-
- val get_dom : t -> age -> Cl.t -> 'b dom -> mod_dom list
- (** get the explications for the domain of this class at the given age *)
-
- val get_dom_path : t -> age -> Cl.t -> 'b dom -> mod_dom list
- (** get the explications for the domain of this class at the given age that
- only applied on this cl *)
-
- val get_dom_last : t -> age -> Cl.t -> 'b dom -> mod_dom
- (** get the last explication for the domain of this class at the
- given age that only applied on this cl *)
-
- val get_pexp_deps : t -> pexp -> 'a con -> 'a rescon * Deps.t
- val add_deps: t -> Deps.t -> unit
- val get_current_deps: t -> Deps.t
- (** mostly for debugging or assert checking *)
-
- val get_pexp : t -> pexp -> 'a con -> 'a rescon
- (** same as get_pexp_deps followed by add_deps *)
-
- val unknown_con: t -> 'b con -> 'b -> unit
- (** same as [Deps.add_unknown_con Deps.empty con a] followed by add_deps *)
-
-
- val set_dec_cho : t -> ('k,'d) cho -> 'k -> unit
- val set_dec_cho_cond : t -> 'a dom -> Cl.t -> ('k,'d) cho -> 'k -> unit
-
- type iter
- val dep_dec: iter -> 'a dom -> Cl.t -> unit
-
-end
-
-val fold_requested:
- ('b -> ComputeConflict.t -> 'a -> 'b) ->
- 'b -> ComputeConflict.t -> 'a rescon -> 'b
-(** The other case is applied to {!ComputeConflict.unknown_con} *)
-
-val fold_requested_deps:
- ('b * Deps.t -> ComputeConflict.t -> 'a -> 'b * Deps.t) -> 'b * Deps.t ->
- ComputeConflict.t -> 'a rescon -> 'b * Deps.t
-(** The other case is applied to {!ComputeConflict.unknown_con} *)
-
-val fold_rescon_list:
- ComputeConflict.t -> ('a -> ComputeConflict.t -> 'c rescon -> 'a)
- -> 'c con -> 'a -> rlist -> 'a
-
-val fold_rescon_list_deps:
- ComputeConflict.t ->
- ('a * Deps.t -> ComputeConflict.t -> 'c rescon -> 'a * Deps.t)
- -> 'c con -> 'a * Deps.t -> rlist -> 'a * Deps.t
-
-(* val fold_rescon_list_deps_cache: *)
-(* cache:(('a * Deps.t) AgeCache.cache) -> *)
-(* concat:('a -> 'a -> 'a) -> *)
-(* empty:'a -> *)
-(* ComputeConflict.t -> *)
-(* (ComputeConflict.t -> 'c rescon -> 'a * Deps.t) *)
-(* -> Age.t -> 'c con -> rlist -> 'a * Deps.t *)
-
-
-exception DontKnowThisCon
-
-
-module type Exp = sig
-
- type t
-
- val print: t Pp.printer
-
- val key: t exp
-
- (* val iterexp: IterExp.t -> age -> t -> unit *)
-
- val analyse :
- ComputeConflict.t -> age -> 'a con -> t -> 'a rescon
-
- val expdom : ComputeConflict.t -> age ->
- 'b dom -> Cl.t ->
- 'a con -> t -> 'a rescon
-
-end
-
-module RegisterExp(E:Exp) : sig end
-
-type testconflict =
- | False (* false in this context *)
- | True (* true in this context *)
- | ToDecide (* can be decided *)
-
-type 'a fold_decisions =
- {fold_decisions : 'k 'd. ('a -> ('k,'d) cho -> 'k -> 'd -> 'a) }
-
-class type finalized = object
- method print: Format.formatter -> unit
- method conflict_add: Solver.Delayed.t -> bool Cl.M.t
- method test: Solver.Delayed.t -> testconflict
- method decide: 'a. 'a fold_decisions -> Solver.Delayed.t -> 'a -> 'a
- (** to call only when test is [Todecide] *)
-end
-
-val print_finalized: finalized Pp.printer
-
-module type Con = sig
-
- type t
-
- val print: t Pp.printer
-
- val key: t con
-
- (** Particular conflict computation *)
- val same_sem:
- ComputeConflict.t -> age -> 'a sem -> 'a ->
- pexp -> Cl.t -> Cl.t -> t rescon
-
- val propacl : ComputeConflict.t -> Age.t -> Cl.t -> Cl.t -> t rescon
- (* cl1 -> cl2 repr *)
-
- (** Finalization and propagation of the conflict *)
- val finalize: ComputeConflict.iter -> t Bag.t -> finalized option
- (** None if the conflict is empty (always satisfied constraint)
- TODO better doc we produce the conflcit ro the explication?
- *)
-
-
-
-end
-
-module RegisterCon(C:Con) : sig end
-
-type 'd decdone =
-| DecNo (** no decision to do *)
-| DecTodo of 'd (** this decision should be done *)
-
-module type Cho = sig
- module Key : Stdlib.Datatype
- module Data: sig
- type t
- val print: t Pp.printer
- end
-
- val choose_decision:
- Solver.Delayed.t -> Key.t -> Data.t decdone
- (** Answer the question: Is the decision still needed? *)
-
- val make_decision:
- Solver.Delayed.t -> dec -> Key.t -> Data.t -> unit
- (** If it is ({!DecTodo} returned by choose_decision) the decision
- can be done using the usual {!Solver.Delayed} functions *)
-
- val analyse:
- ComputeConflict.t -> 'a con -> Key.t -> Data.t -> 'a rescon
- (** If a conflict happened when this decision is the last. This
- function is called *)
-
- val key: (Key.t,Data.t) cho
-
-end
-
-module RegisterCho(C:Cho) : sig end
-
-
-val analyse:
- Solver.t -> (** State of the solver before the last dec *)
- Solver.t -> (** State of the solver unsat *)
- Explanation.t -> pexp -> (* 'a must be a conflict *)
- finalized option * tags * chogen Bag.t
- (* maximum age not in conflict *)
-
-val choose_decision:
- Solver.Delayed.t -> ('k,'d) cho -> 'k ->
- (Solver.Delayed.t -> dec -> unit) decdone
-
-
-val make_decision:
- Solver.Delayed.t -> ('k,'d) cho -> 'k -> 'd -> dec -> unit
-
-val print_pexp: pexp Pp.printer
-val print_chogen: Explanation.chogen Pp.printer
-
-val check_initialization: unit -> bool
-(** Check if the initialization of all the exp, con have been done *)
-
-val confact: unit con
-
-type explimit =
- | LCl: Cl.t * Cl.t -> explimit
- (** At the limit the first cl is represented by this cl *)
- | LDom: 'a dom * Explanation.mod_dom -> explimit
- (** At the limit this class have this value for this dom *)
-
-val is_explimit : pexp -> explimit option
-
-(** Stuff common to Boolean *)
-
-val dom_bool: bool dom
-val conclause: bool Cl.M.t Explanation.con
-
-val print_conflicts: Debug.flag
-val print_decision: Debug.flag
-
-(** Helpers for scheduler *)
-module ChoGenH : Exthtbl.Hashtbl.S with type key = chogen
-
-type explearnt =
-| ExpLearnt: Tags.t -> explearnt
-
-val explearnt : explearnt exp
diff --git a/src/core/demon.ml b/src/core/demon.ml
new file mode 100644
index 000000000..09d1ff4d4
--- /dev/null
+++ b/src/core/demon.ml
@@ -0,0 +1,549 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Nodes
+
+let debug = Debug.register_info_flag
+ ~desc:"for the specialized demons"
+ "Demon.all"
+
+
+module Create = struct
+ type 'b event =
+ | EventDom : Node.t * 'a DomKind.t * 'b -> 'b event
+ | EventValue : Node.t * 'a ValueKind.t * 'b -> 'b event
+ | EventAnyValue : Node.t * 'b -> 'b event
+ | EventRegCl : Node.t * 'b -> 'b event
+ | EventChange : Node.t * 'b -> 'b event
+ | EventRegSem : 'a ThTermKind.t * 'b -> 'b event
+ | EventRegValue : 'a ValueKind.t * 'b -> 'b event
+
+
+ let pp fmt = function
+ | EventDom (node, dom, _) ->
+ Format.fprintf fmt "dom:%a of %a" DomKind.pp dom Node.pp node
+ | EventValue (node, value, _) ->
+ Format.fprintf fmt "value:%a of %a" ValueKind.pp value Node.pp node
+ | EventAnyValue (node, _) ->
+ Format.fprintf fmt "any value of %a" Node.pp node
+ | EventRegCl (node, _) ->
+ Format.fprintf fmt "registration of %a" Node.pp node
+ | EventChange (node, _) ->
+ Format.fprintf fmt "changecl of %a" Node.pp node
+ | EventRegSem (sem, _) ->
+ Format.fprintf fmt "regsem for %a" ThTermKind.pp sem
+ | EventRegValue (value, _) ->
+ Format.fprintf fmt "regvalue for %a" ValueKind.pp value
+
+
+ type 'b t = 'b event list
+end
+
+type 'k alive =
+| AliveReattached
+| AliveStopped
+| AliveRedirected of 'k
+
+module Key = struct
+
+ type ('d,'k,'i) daemon_state =
+ | Alive of 'd Events.Fired.t * 'i
+ | Dead
+ | Redirected of 'k
+
+ let print_daemon_state fmt = function
+ | Alive _ -> Format.fprintf fmt "alive"
+ | Dead -> Format.fprintf fmt "dead"
+ | Redirected _ -> Format.fprintf fmt "redirected"
+
+ module type DemTable = sig
+ module Key: Popop_stdlib.Datatype
+ type data
+ type info val default: info
+ val state : (data, Key.t, info) daemon_state Key.M.t
+ end
+
+ type ('k,'d,'i) demtable =
+ (module DemTable with type Key.t = 'k and type data = 'd
+ and type info = 'i)
+
+ type ('k,'d,'i) t = {
+ dk_id : ('k * 'd, 'k) Events.Dem.t;
+ dk_data : ('k,'d,'i) demtable Env.t;
+ }
+
+ let create (type k d i) name =
+ { dk_id = Events.Dem.create_key (module struct
+ type t = k * d
+ type nonrec d = k
+ let name = name
+ end);
+ dk_data = Env.create_key (module struct
+ type t = (k,d,i) demtable
+ let name = name
+ end)
+ }
+
+ module type S = sig
+ module Key: Popop_stdlib.Datatype
+
+ module Data: Popop_stdlib.Printable
+
+ type info
+ val default: info
+
+ val key: (Key.t, Data.t, info) t
+
+ val immediate: bool
+ val wakeup:
+ Egraph.t -> Key.t -> Data.t Events.Fired.t ->
+ info -> Key.t alive
+ (** the Events.t in wakeup is a subset of the one given in watch *)
+ end
+
+ (** mark it attached if it is not already the case *)
+ let mark_dem :
+ type k d i. Egraph.t -> (k,d,i) t -> k -> unit =
+ fun d dem k ->
+ try
+ let module DemTable = (val (Egraph.get_env d dem.dk_data)) in
+ let module DemTable' = struct
+ include DemTable
+ let state = DemTable.Key.M.change (function
+ | None -> Some (Alive([],DemTable.default))
+ | Some Dead -> raise AlreadyDead
+ | Some (Redirected _) -> raise AlreadyRedirected
+ | Some (Alive _) -> raise Exit)
+ k DemTable.state
+ end in
+ Egraph.set_env d dem.dk_data (module DemTable')
+ with Exit -> ()
+
+ module Register(D:S) = struct
+
+ let rec run d k =
+ let module DemTable = (val (Egraph.get_env d D.key.dk_data)) in
+ match DemTable.Key.M.find k (DemTable.state) with
+ | Dead ->
+ Debug.dprintf4 debug "[Demon] @[Daemon %a for %a is dead@]"
+ Events.Dem.pp D.key.dk_id DemTable.Key.pp k;
+ None
+ | Redirected k' ->
+ Debug.dprintf6 debug
+ "[Demon] @[Daemon %a for %a is redirected to %a@]"
+ Events.Dem.pp D.key.dk_id DemTable.Key.pp
+ k DemTable.Key.pp k';
+ run d k'
+ | Alive (events,info) ->
+ Debug.dprintf6 debug "[Demon] @[Run daemon %a for %a:@[%a@]@]"
+ Events.Dem.pp D.key.dk_id DemTable.Key.pp k
+ (Format.list ~sep:Format.newline Events.Fired.pp) events;
+ (** event can be added during wakeup *)
+ let module DemTable' = struct
+ include DemTable
+ let state = DemTable.Key.M.add k (Alive([],info)) (DemTable.state)
+ end
+ in
+ Egraph.set_env d D.key.dk_data (module DemTable');
+ (** wakeup *)
+ let alive = D.wakeup d k events info in
+ (** delayed can be modified *)
+ begin match alive with
+ | AliveStopped | AliveRedirected _ ->
+ let demstate = match alive with
+ | AliveStopped -> Dead
+ | AliveRedirected k' -> mark_dem d D.key k'; Redirected k'
+ | AliveReattached -> assert false in
+ Debug.dprintf4 debug "[Demon] @[Stop daemon %a %a@]"
+ Events.Dem.pp D.key.dk_id DemTable.Key.pp k;
+ begin
+ let module DemTable =
+ (val (Egraph.get_env d D.key.dk_data)) in
+ (** Dead even if event have been added *)
+ let state' = DemTable.Key.M.add k demstate (DemTable.state) in
+ let module DemTable' = struct
+ include DemTable
+ let state = state'
+ end
+ in
+ Egraph.set_env d D.key.dk_data (module DemTable')
+ end
+ | AliveReattached ->
+ Debug.dprintf0 debug "[Demon] @[Reattach daemon@]";
+ end;
+ None
+
+ let enqueue d event =
+ let module DemTable = (val (Egraph.Ro.get_env d D.key.dk_data)) in
+ let change_state k l =
+ Debug.dprintf6 debug
+ "[Demon] @[schedule %a for %a with %a@]"
+ Events.Dem.pp D.key.dk_id D.Key.pp k
+ Events.Fired.pp event;
+ let module DemTable' = struct
+ include DemTable
+ let state = DemTable.Key.M.add k l DemTable.state
+ end in
+ Egraph.Ro.set_env d D.key.dk_data (module DemTable')
+ in
+ let rec update_state k data =
+ match DemTable.Key.M.find_opt k DemTable.state with
+ | None -> assert false (* should have been marked *)
+ | Some Dead ->
+ Debug.dprintf4 debug
+ "[Demon] @[Dem %a is dead for %a@]"
+ Events.Dem.pp D.key.dk_id Events.Fired.pp event;
+ Events.Wait.EnqStopped
+ | Some (Redirected k') -> update_state k' data
+ | (Some Alive([],info)) ->
+ change_state k (Alive([data],info));
+ Events.Wait.EnqRun k
+ | Some Alive(l,info) ->
+ change_state k (Alive(data::l,info));
+ Events.Wait.EnqAlready
+ in
+ let k, event =
+ let open Events.Fired in
+ match event with
+ | EventDom (a, b , (k,d)) -> k, EventDom(a, b, d)
+ | EventValue (a, b , (k,d)) -> k, EventValue(a, b, d)
+ | EventSem (a, b, c, (k,d)) -> k, EventSem(a, b, c, d)
+ | EventReg (a, (k,d)) -> k, EventReg(a, d)
+ | EventRegNode (a, (k,d)) -> k, EventRegNode(a, d)
+ | EventChange (a, (k,d)) -> k, EventChange(a, d)
+ | EventRegSem (a, (k,d)) -> k, EventRegSem(a, d)
+ | EventRegValue (a, (k,d)) -> k, EventRegValue(a, d) in
+ update_state k event
+
+
+ let () =
+ let print_demtable fmt ((module DT): (D.Key.t,D.Data.t,D.info) demtable) =
+ let open Format in
+ let aux = pair ~sep:(const char ';') D.Key.pp print_daemon_state in
+ let l = DT.Key.M.bindings DT.state in
+ Format.list ~sep:newline aux fmt l
+ in
+ Env.register print_demtable D.key.dk_data;
+ (** Interface for generic daemon *)
+ let module Dem = struct
+ type runable = D.Key.t
+ let print_runable = D.Key.pp
+ let run = run
+
+ type event = D.Key.t * D.Data.t
+ let print_event fmt (k,d) =
+ Format.fprintf fmt "(%a: %a)" D.Key.pp k D.Data.pp d
+ let enqueue = enqueue
+
+ let key = D.key.dk_id
+ let immediate = D.immediate
+ end in
+ Egraph.Wait.register_dem (module Dem)
+
+ let init d =
+ let module DemTable = struct
+ module Key = D.Key
+ type data = D.Data.t
+ type info = D.info let default = D.default
+ let state = Key.M.empty
+ end in
+ Egraph.set_env d D.key.dk_data (module DemTable);
+
+ end
+
+ let attach :
+ type k d i. Egraph.t -> (k,d,i) t -> k -> d Create.t -> unit =
+ fun t dem k events ->
+ mark_dem t dem k;
+ (** record waiters *)
+ let iter ev =
+ Debug.dprintf2 debug "[Demon] @[Attach event %a@]"
+ Create.pp ev;
+ match ev with
+ | Create.EventDom (node,dom,data) ->
+ Egraph.attach_dom t node dom dem.dk_id (k,data)
+ | Create.EventValue (node,value,data) ->
+ Egraph.attach_value t node value dem.dk_id (k,data)
+ | Create.EventAnyValue (node,data) ->
+ Egraph.attach_any_value t node dem.dk_id (k,data)
+ | Create.EventChange (node,data) ->
+ Egraph.attach_node t node dem.dk_id (k,data)
+ | Create.EventRegCl (node,data) ->
+ Egraph.attach_reg_node t node dem.dk_id (k,data)
+ | Create.EventRegSem (sem,data) ->
+ Egraph.attach_reg_sem t sem dem.dk_id (k,data)
+ | Create.EventRegValue (value,data) ->
+ Egraph.attach_reg_value t value dem.dk_id (k,data)
+ in
+ List.iter iter events
+
+
+ type ('k,'i) state =
+ | SUnborn
+ | SAlive of 'i
+ | SDead
+ | SRedirected of 'k
+
+ let is_attached (type k) (type d) (type i) t (dem: (k,d,i) t) (k:k) =
+ let module DemTable = (val (Egraph.get_env t dem.dk_data)) in
+ match DemTable.Key.M.find_opt k DemTable.state with
+ | None -> SUnborn
+ | Some (Alive(_,i)) -> SAlive i
+ | Some Dead -> SDead
+ | Some (Redirected k') -> SRedirected k'
+
+ exception NotAlive
+
+ let set_info (type k) (type d) (type i) t (dem: (k,d,i) t) (k:k) (i:i) =
+ let module DemTable = (val (Egraph.get_env t dem.dk_data)) in
+ match DemTable.Key.M.find_exn NotAlive k DemTable.state with
+ | Alive(w,_) ->
+ let module DemTable' = struct
+ include DemTable
+ let state = DemTable.Key.M.add k (Alive(w,i)) DemTable.state
+ end
+ in
+ Egraph.set_env t dem.dk_data (module DemTable')
+ | _ -> raise NotAlive
+
+
+ exception CantBeKilled
+
+ let kill (type k) (type d) (type i) t (dem: (k,d,i) t) (k:k) =
+ try
+ let module DemTable = (val (Egraph.get_env t dem.dk_data)) in
+ Debug.dprintf4 debug "[Demon] @[Kill dem %a %a@]"
+ Events.Dem.pp dem.dk_id DemTable.Key.pp k;
+ let module DemTable' = struct
+ include DemTable
+ let state = DemTable.Key.M.change (function
+ | Some Dead -> raise Exit
+ | _ -> Some Dead)
+ k DemTable.state
+ end in
+ Egraph.set_env t dem.dk_data (module DemTable')
+ with Exit -> ()
+
+end
+
+module Fast = struct
+
+ type 'd t = {
+ dk_id : ('d, unit) Events.Dem.t;
+ dk_data : 'd Events.Fired.event list Env.t;
+ (** for throttling *)
+ mutable dk_remaining: int; (** 0 if the demon is not the current one *)
+ dk_current : 'd Events.Fired.event Queue.t; (** empty if idem *)
+ }
+
+ let create (type d) name
+ = {
+ dk_id = Events.Dem.create_key (module struct
+ type t = d
+ type d = unit
+ let name = name
+ end);
+ dk_data = Env.create_key (module struct
+ type t = d Events.Fired.event list
+ let name = name
+ end);
+ dk_remaining = 0;
+ dk_current = Queue.create ();
+ }
+
+ module type S = sig
+
+ module Data: sig
+ type t
+ val pp: t Format.printer
+ end
+
+ val key: Data.t t
+
+ (** never killed *)
+ val immediate: bool
+ val throttle: int (** todo int ref? *)
+ (** number of time run in a row *)
+ val wakeup: Egraph.t -> Data.t Events.Fired.event -> unit
+
+ end
+
+
+ module Register(D:S) = struct
+
+ let run d () =
+ assert (Equal.physical D.key.dk_remaining 0);
+ assert (Queue.is_empty D.key.dk_current);
+ let rec last_rev q n = function
+ | [] -> [],n
+ | a::l ->
+ let rem,n = last_rev q n l in
+ if n > 0 then begin
+ assert (Equal.physical rem []);
+ Queue.add a q;
+ rem,(n-1)
+ end
+ else a::rem, n in
+ let events = Egraph.get_env d D.key.dk_data in
+ let events,n = last_rev D.key.dk_current D.throttle events in
+ D.key.dk_remaining <- n;
+ Egraph.set_env d D.key.dk_data events;
+ let new_runable = match events with [] -> None | _::_ -> Some () in
+ let rec run_one () =
+ if not (Queue.is_empty D.key.dk_current) then
+ let event = Queue.pop D.key.dk_current in
+ Debug.dprintf6 debug
+ "[Demon] @[Run daemon fast %a:@[%a@ %a@]@]"
+ Events.Dem.pp D.key.dk_id Events.Fired.pp event
+ D.Data.pp (Events.Fired.get_data event);
+ D.wakeup d event;
+ Debug.dprintf0 debug "[Demon] @[Done@]";
+ if not D.immediate then Egraph.flush_internal d;
+ run_one () in
+ try
+ run_one ();
+ assert (D.key.dk_remaining >= 0);
+ assert (Queue.is_empty D.key.dk_current);
+ D.key.dk_remaining <- 0;
+ new_runable
+ with exn -> (** Normally Contradiction *)
+ assert (D.key.dk_remaining >= 0);
+ D.key.dk_remaining <- 0;
+ Queue.clear D.key.dk_current;
+ raise exn
+
+ let enqueue d event =
+ assert (D.key.dk_remaining >= 0);
+ if D.key.dk_remaining = 0 then
+ let events = Egraph.Ro.get_env d D.key.dk_data in
+ Debug.dprintf4 debug
+ "[Demon] @[schedule %a for %a@]"
+ Events.Dem.pp D.key.dk_id Events.Fired.pp event;
+ Egraph.Ro.set_env d D.key.dk_data (event::events);
+ match events with [] -> Events.Wait.EnqRun () | _::_ -> Events.Wait.EnqAlready
+ else begin
+ Debug.dprintf4 debug
+ "[Demon] @[schedule %a for %a now@]"
+ Events.Dem.pp D.key.dk_id Events.Fired.pp event;
+ Queue.add event D.key.dk_current;
+ D.key.dk_remaining <- D.key.dk_remaining - 1;
+ assert (D.key.dk_remaining >= 0);
+ Events.Wait.EnqAlready
+ end
+
+
+ let () =
+ let print_demtable = Format.(list ~sep:(const char ',') Events.Fired.pp) in
+ Env.register print_demtable D.key.dk_data;
+ (** Interface for generic daemon *)
+ let module Dem = struct
+ type runable = unit
+ let print_runable = Popop_stdlib.DUnit.pp
+ let run = run
+
+ type event = D.Data.t
+ let print_event = D.Data.pp
+ let enqueue = enqueue
+
+ let key = D.key.dk_id
+ let immediate = D.immediate
+ end in
+ Egraph.Wait.register_dem (module Dem)
+
+ let init d =
+ Egraph.set_env d D.key.dk_data [];
+
+ end
+
+ let attach d dem events =
+ let open Create in
+ let iter ev =
+ Debug.dprintf2 debug "[Demon] @[Attach event %a@]" Create.pp ev;
+ match ev with
+ | EventDom (node,dom,data) ->
+ Egraph.attach_dom d node dom dem.dk_id data
+ | EventValue (node,value,data) ->
+ Egraph.attach_value d node value dem.dk_id data
+ | EventAnyValue (node,data) ->
+ Egraph.attach_any_value d node dem.dk_id data
+ | EventRegCl (node,data) ->
+ Egraph.attach_reg_node d node dem.dk_id data
+ | EventChange (node,data) ->
+ Egraph.attach_node d node dem.dk_id data
+ | EventRegSem (sem,data) ->
+ Egraph.attach_reg_sem d sem dem.dk_id data
+ | EventRegValue (value,data) ->
+ Egraph.attach_reg_value d value dem.dk_id data
+ in
+ List.iter iter events
+
+ let register_init_daemon
+ (type a)
+ ~name
+ ?(immediate=false)
+ ?(throttle=100)
+ (thterm: (module Nodes.RegisteredThTerm with type t = a) )
+ (f:Egraph.t -> a -> unit)
+ (init_d:Egraph.t)
+ =
+ let module ThTerm = (val thterm) in
+ let module DaemonInit = struct
+ let key = create name
+ module Data = Popop_stdlib.DUnit
+ let immediate = immediate
+ let throttle = throttle
+ let wakeup d = function
+ | Events.Fired.EventRegSem(thterm,()) ->
+ let thterm = ThTerm.coerce_thterm thterm in
+ f d thterm
+ | _ -> raise UnwaitedEvent
+ end in
+ let module RDaemonInit = Register(DaemonInit) in
+ RDaemonInit.init init_d;
+ attach init_d DaemonInit.key [Create.EventRegSem(ThTerm.key,())]
+
+ let register_init_daemon_value
+ (type a)
+ ~name
+ ?(immediate=false)
+ ?(throttle=100)
+ (value: (module Nodes.RegisteredValue with type t = a) )
+ (f:Egraph.t -> a -> unit)
+ (init_d:Egraph.t)
+ =
+ let module Val = (val value) in
+ let module DaemonInit = struct
+ let key = create name
+ module Data = Popop_stdlib.DUnit
+ let immediate = immediate
+ let throttle = throttle
+ let wakeup d = function
+ | Events.Fired.EventRegValue(value,()) ->
+ let thterm = Val.coerce_nodevalue value in
+ f d thterm
+ | _ -> raise UnwaitedEvent
+ end in
+ let module RDaemonInit = Register(DaemonInit) in
+ RDaemonInit.init init_d;
+ attach init_d DaemonInit.key [Create.EventRegValue(Val.key,())]
+
+
+end
diff --git a/src/demon.mli b/src/core/demon.mli
similarity index 50%
rename from src/demon.mli
rename to src/core/demon.mli
index e16f4eb85..6e35c272e 100644
--- a/src/demon.mli
+++ b/src/core/demon.mli
@@ -1,41 +1,45 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Nodes
module Create : sig
type 'b event =
(** the domain dom of the class is watched *)
- | EventDom : Cl.t * 'a dom * 'b -> 'b event
+ | EventDom : Node.t * 'a DomKind.t * 'b -> 'b event
+ (** the value of the class is watched *)
+ | EventValue : Node.t * 'a ValueKind.t * 'b -> 'b event
+ (** the values of the class is watched *)
+ | EventAnyValue : Node.t * 'b -> 'b event
(** we want to register this class *)
- | EventRegCl : Cl.t * 'b -> 'b event
+ | EventRegCl : Node.t * 'b -> 'b event
(** Warn when the class is not the representant of its eq-class anymore *)
- | EventChange : Cl.t * 'b -> 'b event
- (** a new semantical value 'a appear *)
- | EventRegSem : 'a sem * 'b -> 'b event
+ | EventChange : Node.t * 'b -> 'b event
+ (** a new theory term 'a appear *)
+ | EventRegSem : 'a ThTermKind.t * 'b -> 'b event
+ (** a new value 'a appear *)
+ | EventRegValue : 'a ValueKind.t * 'b -> 'b event
- val print: 'b event Pp.printer
+ val pp: 'b event Format.printer
type 'b t = 'b event list
end
@@ -52,9 +56,9 @@ module Key: sig
val create: string -> ('k,'d,'i) t
module type S = sig
- module Key: Stdlib.Datatype
+ module Key: Popop_stdlib.Datatype
- module Data: Stdlib.Printable
+ module Data: Popop_stdlib.Printable
type info val default: info
@@ -62,13 +66,13 @@ module Key: sig
val immediate: bool
val wakeup:
- Solver.Delayed.t -> Key.t -> Data.t Solver.Events.Fired.t ->
+ Egraph.t -> Key.t -> Data.t Events.Fired.t ->
info -> Key.t alive
(** the Events.t in wakeup is a subset of the one given in watch *)
end
module Register (D:S): sig
- val init: Solver.Delayed.t -> unit
+ val init: Egraph.t -> unit
(** to run for each new delayed *)
end
@@ -78,15 +82,15 @@ module Key: sig
| SDead
| SRedirected of 'k
- val attach: Solver.Delayed.t -> ('k,'d,'i) t -> 'k -> 'd Create.t -> unit
+ val attach: Egraph.t -> ('k,'d,'i) t -> 'k -> 'd Create.t -> unit
(** raise AlreadyDead if this key is already dead *)
- val is_attached: Solver.d -> ('k,'d,'i) t -> 'k -> ('k,'i) state
+ val is_attached: Egraph.t -> ('k,'d,'i) t -> 'k -> ('k,'i) state
- val set_info: Solver.d -> ('k, 'd, 'i) t -> 'k -> 'i -> unit
+ val set_info: Egraph.t -> ('k, 'd, 'i) t -> 'k -> 'i -> unit
exception CantBeKilled
- val kill : Solver.d -> ('a, 'b,'c) t -> 'a -> unit
+ val kill : Egraph.t -> ('a, 'b,'c) t -> 'a -> unit
end
@@ -101,7 +105,7 @@ module Fast: sig
module Data: sig
type t
- val print: t Pp.printer
+ val pp: t Format.printer
end
val key: Data.t t
@@ -110,18 +114,36 @@ module Fast: sig
val immediate: bool
val throttle: int (** todo int ref? *)
(** number of time run in a row *)
- val wakeup: Solver.Delayed.t -> Data.t Solver.Events.Fired.event -> unit
+ val wakeup: Egraph.t -> Data.t Events.Fired.event -> unit
end
module Register (D:S): sig
- val init: Solver.Delayed.t -> unit
+ val init: Egraph.t -> unit
(** to run for each new delayed *)
end
- val attach: Solver.Delayed.t -> 'd t -> 'd Create.t -> unit
- (** raise AlreadyDead if this key is already dead *)
-
- val fresh_with_reg_cl: 'd t -> string -> Ty.t -> 'd -> Cl.t
-
+ val attach: Egraph.t -> 'd t -> 'd Create.t -> unit
+
+ (** helper *)
+ val register_init_daemon:
+ name:string ->
+ ?immediate:bool ->
+ ?throttle:int ->
+ (module RegisteredThTerm with type t = 'a) ->
+ (Egraph.t -> 'a -> unit) ->
+ Egraph.t ->
+ unit
+ (** *)
+
+ (** helper *)
+ val register_init_daemon_value:
+ name:string ->
+ ?immediate:bool ->
+ ?throttle:int ->
+ (module RegisteredValue with type t = 'a) ->
+ (Egraph.t -> 'a -> unit) ->
+ Egraph.t ->
+ unit
+ (** *)
end
diff --git a/src/core/dune b/src/core/dune
new file mode 100644
index 000000000..8d1fbe7c8
--- /dev/null
+++ b/src/core/dune
@@ -0,0 +1,12 @@
+(library
+ (name witan_core)
+ (public_name witan.core)
+ (synopsis "core for witan, e.g. trail, egraph")
+ (libraries containers ocamlgraph str witan.stdlib witan.popop_lib
+ witan_core_structures)
+ (preprocess
+ (pps ppx_deriving.std))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always -open
+ Containers -open Witan_stdlib -open Std -open Witan_core_structures)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/core/egraph.ml b/src/core/egraph.ml
new file mode 100644
index 000000000..a17c16ddf
--- /dev/null
+++ b/src/core/egraph.ml
@@ -0,0 +1,1186 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Popop_stdlib
+open Nodes
+
+exception Contradiction of Trail.Pexp.t
+
+let debug = Debug.register_info_flag
+ ~desc:"for the core solver"
+ "Egraph.all"
+let debug_few = Debug.register_info_flag
+ ~desc:"for the core solver"
+ "Egraph.few"
+
+let stats_set_dom =
+ Debug.register_stats_int ~name:"Egraph.set_dom/merge" ~init:0
+let stats_set_value =
+ Debug.register_stats_int ~name:"Egraph.set_value/merge" ~init:0
+
+module DecTag = DInt
+
+type 'a domtable = {
+ table : 'a Node.M.t;
+ events : Events.Wait.t Bag.t Node.M.t
+}
+
+type semtable = Events.Wait.t list
+
+module VDomTable = DomKind.MkVector (struct type ('a,'unused) t = 'a domtable end)
+
+module VSemTable = ThTermKind.Vector
+
+type 'a valuetable = {
+ table : 'a Node.M.t;
+ events : Events.Wait.t Bag.t Node.M.t;
+ reg_events : Events.Wait.t list;
+}
+module VValueTable = ValueKind.MkVector (struct type ('a,'unit) t = 'a valuetable end)
+
+(** Environnement *)
+
+(** mutable but only contain persistent structure *)
+(** Just for easy qualification *)
+module Def = struct
+
+ type saved = {
+ saved_repr : Node.t Node.M.t;
+ saved_rang : int Node.M.t;
+ saved_event_repr : Events.Wait.t Bag.t Node.M.t;
+ saved_event_value : Events.Wait.t Bag.t Node.M.t;
+ saved_event_reg : Events.Wait.t list Node.M.t;
+ saved_event_any_reg : Events.Wait.t list;
+ saved_dom : delayed_t VDomTable.t;
+ saved_sem : semtable VSemTable.t;
+ saved_value : unit VValueTable.t;
+ saved_envs : Env.VectorH.t;
+ }
+
+
+ and t = {
+ mutable repr : Node.t Node.M.t;
+ mutable rang : int Node.M.t;
+ mutable event_repr : Events.Wait.t Bag.t Node.M.t;
+ mutable event_value : Events.Wait.t Bag.t Node.M.t;
+ mutable event_reg : Events.Wait.t list Node.M.t;
+ mutable event_any_reg : Events.Wait.t list;
+ (** extensible "number of fields" *)
+ dom : delayed_t VDomTable.t;
+ sem : semtable VSemTable.t;
+ value : unit VValueTable.t;
+ envs : Env.VectorH.t;
+ trail : Trail.t;
+ mutable current_delayed : delayed_t; (** For assert-check *)
+ history : saved Context.history;
+ }
+
+ (** delayed_t is used *)
+ and delayed_t = {
+ env : t;
+ todo_immediate_dem : action_immediate_dem Queue.t;
+ todo_merge_dom : action_merge_dom Queue.t;
+ mutable todo_delayed_merge : (Trail.Pexp.t * Node.t * Node.t * bool) option;
+ todo_merge : action_merge Queue.t;
+ todo_ext_action : action_ext Queue.t;
+ sched_daemon : Events.Wait.daemon_key -> unit;
+ sched_decision : Trail.chogen -> unit;
+ }
+
+ and action_immediate_dem =
+ | RunDem : Events.Wait.daemon_key -> action_immediate_dem
+
+ and action_merge_dom =
+ | SetMergeDomNode :
+ Trail.Pexp.t * 'a DomKind.t * Node.t * Node.t * bool -> action_merge_dom
+
+ and action_merge =
+ | Merge of Trail.Pexp.t * Node.t * Node.t
+
+ and action_ext =
+ | ExtDem : Events.Wait.daemon_key -> action_ext
+
+end
+
+open Def
+(** {2 Define events} *)
+
+module WaitDef = struct
+ type delayed = delayed_t
+ let schedule_immediate t d = Queue.push (RunDem d) t.todo_immediate_dem
+ let schedule t d = t.sched_daemon d
+
+ type delayed_ro = delayed_t
+ let readonly x = x
+end
+module Wait : Events.Wait.S with type delayed = delayed_t and type delayed_ro = delayed_t =
+ Events.Wait.Make(WaitDef)
+
+(** {2 Define domain registration} *)
+module VDom = DomKind.Make(struct type delayed = delayed_t type pexp = Trail.Pexp.t end)
+include VDom
+
+let mk_dumb_delayed () = { env = Obj.magic 0;
+ todo_immediate_dem = Queue.create ();
+ todo_merge_dom = Queue.create ();
+ todo_delayed_merge = None;
+ todo_merge = Queue.create ();
+ todo_ext_action = Queue.create ();
+ sched_daemon = (fun _ -> (assert false : unit));
+ (* should never be called *)
+ sched_decision = (fun _ -> (assert false : unit));
+ }
+
+let dumb_delayed = mk_dumb_delayed ()
+let unsat_delayed = mk_dumb_delayed ()
+
+module Hidden = Context.Make(struct
+ type saved = Def.saved
+ type t = Def.t
+
+ let save (t:t) : saved =
+ assert (Equal.physical t.current_delayed dumb_delayed); {
+ saved_repr = t.repr;
+ saved_rang = t.rang;
+ saved_event_repr = t.event_repr;
+ saved_event_value = t.event_value;
+ saved_event_reg = t.event_reg;
+ saved_event_any_reg = t.event_any_reg;
+ saved_dom = VDomTable.copy t.dom;
+ saved_sem = VSemTable.copy t.sem;
+ saved_value = VValueTable.copy t.value;
+ saved_envs = Env.VectorH.copy t.envs;
+ }
+
+ let restore (s:saved) (t:t) =
+ t.repr <- s.saved_repr;
+ t.rang <- s.saved_rang;
+ t.event_repr <- s.saved_event_repr ;
+ t.event_value <- s.saved_event_value ;
+ t.event_reg <- s.saved_event_reg ;
+ t.event_any_reg <- s.saved_event_any_reg;
+ VDomTable.move ~from:s.saved_dom ~to_:t.dom;
+ VSemTable.move ~from:s.saved_sem ~to_:t.sem;
+ VValueTable.move ~from:s.saved_value ~to_:t.value;
+ Env.VectorH.move ~from:s.saved_envs ~to_:t.envs;
+ t.current_delayed <- dumb_delayed
+
+ let get_history t = t.history
+ end)
+
+(** {2 Table access in the environment } *)
+
+let get_table_dom t k =
+ VDom.check_is_registered k;
+ VDomTable.get_def t.dom k
+ { table = Node.M.empty;
+ events = Node.M.empty }
+
+let get_table_sem t k =
+ Nodes.check_thterm_registered k;
+ ThTermKind.Vector.get_def t.sem k []
+
+let get_table_value t k =
+ Nodes.check_value_registered k;
+ VValueTable.get_def t.value k
+ { table = Node.M.empty;
+ events = Node.M.empty;
+ reg_events = [] }
+
+exception UninitializedEnv of string
+
+exception NotRegistered
+
+(** Just used for being able to qualify these function on t *)
+module T = struct
+ let rec find t node =
+ let node' = Node.M.find_exn NotRegistered node t.repr in
+ if Node.equal node node' then node else
+ let r = find t node' in
+ t.repr <- Node.M.add node r t.repr;
+ r
+
+ let find_def t node =
+ let node' = Node.M.find_def node node t.repr in
+ if Node.equal node node' then node else
+ let r = find t node' in
+ t.repr <- Node.M.add node r t.repr;
+ r
+
+ let is_repr t node =
+ try Node.equal (Node.M.find node t.repr) node
+ with Not_found -> true
+
+ let is_equal t node1 node2 =
+ let node1 = find_def t node1 in
+ let node2 = find_def t node2 in
+ Node.equal node1 node2
+
+ let get_direct_dom (type a) t (dom : a DomKind.t) node =
+ Node.M.find_opt node (get_table_dom t dom).table
+
+ let get_dom t dom node =
+ let node = find_def t node in
+ get_direct_dom t dom node
+
+ let get_direct_value t value node =
+ Node.M.find_opt node (get_table_value t value).table
+
+ let get_value t value node =
+ let node = find_def t node in
+ get_direct_value t value node
+
+ let get_env : type a. t -> a Env.t -> a
+ = fun t k ->
+ Env.check_is_registered k;
+ if Env.VectorH.is_uninitialized t.envs k then
+ raise (UninitializedEnv (Env.name k))
+ else
+ Env.VectorH.get t.envs k
+
+ let set_env : type a. t -> a Env.t -> a -> unit
+ = fun t k ->
+ Env.check_is_registered k;
+ Env.VectorH.set t.envs k
+
+ let is_registered t node =
+ Node.M.mem node t.repr
+
+
+end
+open T
+
+(** {2 For debugging and display} *)
+let _print_env fmt t =
+ let printd (type a) dom fmt (domtable:a domtable) =
+ let aux =
+ Format.(pair ~sep:(const char ';') Node.pp (Bag.pp (const char ',') Events.Wait.pp))
+ in
+ let aux fmt m = Node.M.bindings m |> Format.(list ~sep:newline aux) fmt in
+ Format.fprintf fmt "%a:@[%a@]" DomKind.pp dom aux domtable.events
+ in
+ VDomTable.pp Format.newline Format.silent
+ {VDomTable.printk = Format.silent}
+ {VDomTable.printd} fmt t.dom
+
+
+let dot_to_escape = Str.regexp "[{}|<>]"
+
+let escape_for_dot pp v =
+ let s = Format.to_string pp v in
+ let s = Str.global_replace dot_to_escape "\\\\\\0" s in
+ s
+
+let output_graph filename t =
+ let open Graph in
+ let module G = struct
+ include Imperative.Digraph.Concrete(Node)
+ let graph_attributes _ = []
+ let default_vertex_attributes _ = [`Shape `Record]
+ let vertex_name node = string_of_int (Node.hash node)
+
+ let pp fmt node =
+ let iter_dom dom fmt (domtable: _ domtable) =
+ try
+ let s = Node.M.find node domtable.table in
+ Format.fprintf fmt "| {%a | %s}"
+ DomKind.pp dom (escape_for_dot (VDom.print_dom dom) s);
+ with Not_found -> ()
+ in
+ let iter_value value fmt (valuetable: _ valuetable) =
+ try
+ let s = Node.M.find node valuetable.table in
+ Format.fprintf fmt "| {%a | %s}"
+ ValueKind.pp value (escape_for_dot (print_value value) s);
+ with Not_found -> ()
+ in
+ let print_ty fmt node =
+ if is_repr t node
+ then Format.fprintf fmt ": %a" Ty.pp (Node.ty node)
+ in
+ let print_sem fmt node =
+ match Only_for_solver.thterm node with
+ | None -> ()
+ | Some thterm ->
+ match Only_for_solver.sem_of_node thterm with
+ | Only_for_solver.ThTerm(sem,v) ->
+ let (module S) = get_thterm sem in
+ Format.fprintf fmt "| {%a | %s}"
+ ThTermKind.pp sem (escape_for_dot S.pp v)
+ in
+ Format.fprintf fmt "{%a %a %a %a %a}" (* "{%a | %a | %a}" *)
+ Node.pp node
+ print_ty node
+ print_sem node
+ (if is_repr t node
+ then VDomTable.pp Format.silent Format.silent
+ {VDomTable.printk=Format.silent}
+ {VDomTable.printd=iter_dom}
+ else Format.silent)
+ t.dom
+ (if is_repr t node
+ then VValueTable.pp Format.silent Format.silent
+ {VValueTable.printk=Format.silent}
+ {VValueTable.printd=iter_value}
+ else Format.silent)
+ t.value
+
+ let vertex_attributes node =
+ let label = Format.to_string pp node in
+ [`Label label]
+ let default_edge_attributes _ = []
+ let edge_attributes _ = []
+ let get_subgraph _ = None
+ end in
+ let g = G.create () in
+ Node.M.iter (fun node1 node2 ->
+ if Node.equal node1 node2
+ then G.add_vertex g node1
+ else G.add_edge g node1 (find_def t node2)) t.repr;
+ let cout = open_out filename in
+ let module Dot = Graphviz.Dot(G) in
+ Dot.output_graph cout g;
+ close_out cout
+
+let show_graph = Debug.register_flag
+ ~desc:"Show each step in a gui"
+ "dotgui"
+
+let draw_graph =
+ let c = ref 0 in
+ fun ?(force=false) t ->
+ if force || Debug.test_flag show_graph then
+ let dir = "debug_graph.tmp" in
+ if not (Sys.file_exists dir) then Unix.mkdir dir 0o700;
+ let filename = Format.sprintf "%s/debug_graph%i.dot" dir !c in
+ incr c;
+ Debug.dprintf1 Debug._true "[DotGui] output dot file: %s" filename;
+ output_graph filename t
+
+
+(** {2 Delayed} *)
+
+module Delayed = struct
+ open T
+ type t = delayed_t
+
+ let context t = Hidden.creator t.env.history
+
+ let is_current_env t = Equal.physical t.env.current_delayed t
+
+ let find t node =
+ assert (is_current_env t);
+ find t.env node
+
+ let find_def t node =
+ assert (is_current_env t);
+ find_def t.env node
+
+ let is_repr t node =
+ assert (is_current_env t);
+ is_repr t.env node
+
+ let is_equal t node1 node2 =
+ assert (is_current_env t);
+ is_equal t.env node1 node2
+
+ let get_dom t dom node =
+ assert (is_current_env t);
+ get_dom t.env dom node
+
+ let get_value t value node =
+ assert (is_current_env t);
+ get_value t.env value node
+
+ let get_env t env =
+ assert (is_current_env t);
+ get_env t.env env
+
+ let set_env t env v =
+ assert (is_current_env t);
+ set_env t.env env v
+
+ let is_registered t node =
+ assert (is_current_env t);
+ is_registered t.env node
+
+ let set_value_direct (type a) t (value : a ValueKind.t) node0 new_v =
+ Debug.incr stats_set_value;
+ let node = find t node0 in
+ let valuetable = get_table_value t.env value in
+ let valuetable = {
+ valuetable with
+ table = Node.M.add node new_v valuetable.table;
+ } in
+ VValueTable.set t.env.value value valuetable;
+ let events = Node.M.find_opt node valuetable.events in
+ Wait.wakeup_events_bag Events.Wait.translate_value t events (node,value);
+ let events = Node.M.find_opt node t.env.event_value in
+ Wait.wakeup_events_bag Events.Wait.translate_value t events (node,value)
+
+ let add_pending_merge (t : t) pexp node node' =
+ Debug.dprintf4 debug "[Egraph] @[add_pending_merge for %a and %a@]"
+ Node.pp node Node.pp node';
+ assert (is_registered t node);
+ assert (is_registered t node');
+ assert (not (Node.equal (find t node) (find t node')));
+ assert (Ty.equal (Node.ty node) (Node.ty node'));
+ (* Add the actual merge for later *)
+ Queue.add (Merge (pexp,node,node')) t.todo_merge
+
+ let check_no_dom t node =
+ let foldi acc _dom (domtable: _ domtable) =
+ acc &&
+ not (Node.M.mem node domtable.table)
+ in
+ VDomTable.fold_initializedi {VDomTable.foldi} true t.env.dom
+
+ let register t node =
+ assert (is_current_env t);
+ if not (is_registered t node) then begin
+ if Debug.test_flag debug_few then begin
+ match Only_for_solver.thterm node with
+ | None ->
+ Debug.dprintf2 debug "[Egraph] @[register %a@]" Node.pp node
+ | Some thterm ->
+ Debug.dprintf4 debug "[Egraph] @[register %a: %a@]"
+ Node.pp node ThTerm.pp thterm
+ end;
+ assert ( check_no_dom t node );
+ t.env.repr <- Node.M.add node node t.env.repr;
+ (** reg_node *)
+ let new_events, node_events = Node.M.find_remove node t.env.event_reg in
+ t.env.event_reg <- new_events;
+ Wait.wakeup_events_list Events.Wait.translate_regnode t node_events node;
+ (** reg *)
+ Wait.wakeup_events_list Events.Wait.translate_reg
+ t (Some t.env.event_any_reg) node;
+ (** reg_sem *)
+ match Only_for_solver.open_node node with
+ | Only_for_solver.ThTerm thterm ->
+ begin match Only_for_solver.sem_of_node thterm with
+ | Only_for_solver.ThTerm(sem,_) ->
+ let reg_events = get_table_sem t.env sem in
+ Wait.wakeup_events_list Events.Wait.translate_regsem
+ t (Some reg_events) (thterm)
+ end
+ | Only_for_solver.Value nodevalue ->
+ begin match Only_for_solver.value_of_node nodevalue with
+ | Only_for_solver.Value(value,v) ->
+ let valuetable = get_table_value t.env value in
+ let reg_events = valuetable.reg_events in
+ Wait.wakeup_events_list Events.Wait.translate_regvalue
+ t (Some reg_events) (nodevalue);
+ set_value_direct t value node v
+ end
+ end
+
+ let set_semvalue_pending t pexp node0 node0' =
+ let node = find t node0 in
+ assert (Ty.equal (Node.ty node) (Node.ty node0'));
+ begin
+ if not (is_registered t node0') then begin
+ register t node0';
+ (* Here the important part of this function the representative
+ is forced to be node. The goal is to not grow the number of
+ classes that can be used for representative for
+ termination.
+ *)
+ t.env.repr <- Node.M.add node0' node t.env.repr;
+ let pexp = pexp () in
+ Trail.add_merge_start t.env.trail pexp
+ ~node1:node0 ~node2:node0'
+ ~node1_repr:node ~node2_repr:node0'
+ ~new_repr:node;
+ Trail.add_merge_finish t.env.trail pexp
+ ~node1:node0 ~node2:node0'
+ ~node1_repr:node ~node2_repr:node0'
+ ~new_repr:node;
+ (** wakeup the daemons register_node *)
+ let event, other_event = Node.M.find_remove node0' t.env.event_repr in
+ Wait.wakeup_events_bag Events.Wait.translate_change t other_event node0';
+ t.env.event_repr <- event;
+ (** set the value if node0' is one *)
+ match Nodes.Only_for_solver.nodevalue node0' with
+ | None -> ()
+ | Some value ->
+ match Nodes.Only_for_solver.value_of_node value with
+ | Nodes.Only_for_solver.Value(value,v) ->
+ set_value_direct t value node0 v
+ end
+ (** node' is already registered *)
+ else if Node.equal node (find t node0') then
+ (** if node is the representant of node' then we have nothing to do *)
+ ()
+ else
+ (** merge node and node0' *)
+ let pexp = pexp () in
+ add_pending_merge t pexp node0 node0'
+ end
+
+ let set_sem_pending t pexp node0 thterm =
+ let node0' = ThTerm.node thterm in
+ let pexp () =
+ Trail.mk_pexp t.env.trail Trail.exp_same_sem
+ (ExpSameSem(pexp,node0,thterm)) in
+ set_semvalue_pending t pexp node0 node0'
+
+ let set_value_pending t pexp node0 nodevalue =
+ let node0' = Value.node nodevalue in
+ let pexp () =
+ Trail.mk_pexp t.env.trail Trail.exp_same_sem
+ (ExpSameValue(pexp,node0,nodevalue)) in
+ set_semvalue_pending t pexp node0 node0'
+
+ let set_dom_pending (type a) t (dom : a DomKind.t) node0 new_v =
+ Debug.incr stats_set_dom;
+ let node = find t node0 in
+ let domtable = (get_table_dom t.env dom) in
+ let new_table = Node.M.add_opt node new_v domtable.table in
+ let domtable = { domtable with table = new_table } in
+ VDomTable.set t.env.dom dom domtable;
+ let events = Node.M.find_opt node domtable.events in
+ Wait.wakeup_events_bag Events.Wait.translate_dom t events (node,dom)
+
+ let set_dom_premerge_pending (type a) t (dom : a DomKind.t) ~from:_ node0 (new_v:a) =
+ Debug.incr stats_set_dom;
+ let node = find t node0 in
+ let domtable = (get_table_dom t.env dom) in
+ let new_table = Node.M.add node new_v domtable.table in
+ let domtable = { domtable with table = new_table } in
+ VDomTable.set t.env.dom dom domtable;
+ let events = Node.M.find_opt node domtable.events in
+ Wait.wakeup_events_bag Events.Wait.translate_dom t events (node0,dom)
+
+ let flag_choose_repr_no_value =
+ Debug.register_flag
+ ~desc:"Accept to use value as representative"
+ "choose_repr_no_value"
+ let choose_repr t ((_,a) as pa) ((_,b) as pb) =
+ let heuristic () =
+ if Shuffle.is_shuffle () then
+ Shuffle.shuffle2 (pa,pb)
+ else
+ let ra = Node.M.find_def 0 a t.rang in
+ let rb = Node.M.find_def 0 b t.rang in
+ if ra = rb then begin
+ t.rang <- Node.M.add a (ra+1) t.rang;
+ (pa,pb)
+ end else
+ if ra < rb then (pb,pa)
+ else (pa,pb)
+ in
+ if Debug.test_noflag flag_choose_repr_no_value then
+ let va = Nodes.Only_for_solver.is_value a in
+ let vb = Nodes.Only_for_solver.is_value b in
+ if va && not vb then (pb,pa)
+ else if va && not vb then (pa,pb)
+ else heuristic ()
+ else
+ heuristic ()
+
+ let merge_dom_pending (type a) t pexp (dom : a DomKind.t) node1_0 node2_0 inv =
+ let node1 = find t node1_0 in
+ let node2 = find t node2_0 in
+ let domtable = (get_table_dom t.env dom) in
+ let old_other_s = Node.M.find_opt node1 domtable.table in
+ let old_repr_s = Node.M.find_opt node2 domtable.table in
+ let (module Dom) = VDom.get_dom dom in
+ Debug.dprintf12 debug_few
+ "[Egraph] @[merge dom (%a(%a),%a)@ and (%a(%a),%a)@]"
+ Node.pp node1 Node.pp node1_0
+ (Format.opt Dom.pp) old_other_s
+ Node.pp node2 Node.pp node2_0
+ (Format.opt Dom.pp) old_repr_s;
+ match old_other_s, old_repr_s with
+ | None, None -> ()
+ | _ ->
+ Dom.merge t pexp
+ (old_other_s,node1_0)
+ (old_repr_s,node2_0)
+ inv
+
+
+ let merge_dom ?(dry_run=false) t pexp node1_0 node2_0 inv =
+ let node1 = find t node1_0 in
+ let node2 = find t node2_0 in
+ let dom_not_done = ref false in
+ let iteri (type a) (dom : a DomKind.t) (domtable : a domtable) =
+ let s1 = Node.M.find_opt node1 domtable.table in
+ let s2 = Node.M.find_opt node2 domtable.table in
+ let (module Dom) = VDom.get_dom dom in
+ if not (Dom.merged s1 s2)
+ then begin
+ dom_not_done := true;
+ if not dry_run then
+ Queue.push
+ (SetMergeDomNode(pexp,dom,node1_0,node2_0,inv)) t.todo_merge_dom
+ end
+ in
+ VDomTable.iter_initializedi {VDomTable.iteri} t.env.dom;
+ !dom_not_done
+
+ let merge_values t pexp node0 node0' =
+ let node = find t node0 in
+ let node' = find t node0' in
+ let iteri (type a) (value:a ValueKind.t) (valuetable:a valuetable) =
+ let old_s = Node.M.find_opt node valuetable.table in
+ let old_s' = Node.M.find_opt node' valuetable.table in
+ let (module V) = Nodes.get_value value in
+ Debug.dprintf14 debug
+ "[Egraph] @[merge value %a (%a(%a),%a)@ and (%a(%a),%a)@]"
+ ValueKind.pp value
+ Node.pp node Node.pp node0
+ (Format.opt (print_value value)) old_s
+ Node.pp node' Node.pp node0'
+ (Format.opt (print_value value)) old_s';
+ match old_s, old_s' with
+ | None, None -> ()
+ | Some v, None ->
+ set_value_direct t value node0' v
+ | None, Some v' ->
+ set_value_direct t value node0 v'
+ | Some v, Some v' ->
+ if V.equal v v'
+ then
+ (* already same value. Does that really happen? *)
+ ()
+ else
+ let ty = Node.ty node in
+ let v = Value.index value v ty in
+ let v' = Value.index value v' ty in
+ let pexp = Trail.mk_pexp t.env.trail Trail.exp_diff_value (v,node0,node0',v',pexp) in
+ raise (Contradiction pexp)
+ in
+ VValueTable.iter_initializedi {VValueTable.iteri} t.env.value
+
+ let finalize_merge t pexp node1_0 node2_0 inv =
+ let node1 = find t node1_0 in
+ let node2 = find t node2_0 in
+ let other_node0,other_node,repr_node0,repr_node =
+ if inv
+ then node2_0,node2, node1_0, node1
+ else node1_0, node1, node2_0, node2 in
+ merge_values t pexp node1_0 node2_0;
+ t.env.repr <- Node.M.add other_node repr_node t.env.repr;
+ Trail.add_merge_finish t.env.trail pexp
+ ~node1:node1_0 ~node2:node2_0
+ ~node1_repr:node1 ~node2_repr:node2
+ ~new_repr:repr_node;
+ Debug.dprintf10 debug_few "[Egraph.few] [%a] merge %a(%a) -> %a(%a)"
+ Trail.print_current_age t.env.trail
+ Node.pp other_node Node.pp other_node0
+ Node.pp repr_node Node.pp repr_node0;
+ let event, other_event = Node.M.find_remove other_node t.env.event_repr in
+
+ (** move node events *)
+ begin match other_event with
+ | None -> ()
+ | Some other_event ->
+ t.env.event_repr <-
+ Node.M.add_change (fun x -> x) Bag.concat repr_node other_event
+ event
+ end;
+
+ (** move dom events *)
+ let iteri (type a) (dom : a DomKind.t) (domtable: a domtable) =
+ match Node.M.find_opt other_node domtable.events with
+ | None -> ()
+ | Some other_events ->
+ let new_events =
+ Node.M.add_change (fun x -> x) Bag.concat repr_node other_events
+ domtable.events in
+ let domtable = { domtable with events = new_events } in
+ VDomTable.set t.env.dom dom domtable
+ in
+ VDomTable.iter_initializedi {VDomTable.iteri} t.env.dom;
+
+ (** move value events *)
+ let iteri (type a) (value : a ValueKind.t) (valuetable: a valuetable) =
+ match Node.M.find_opt other_node valuetable.events with
+ | None -> ()
+ | Some other_events ->
+ let new_events =
+ Node.M.add_change (fun x -> x) Bag.concat repr_node other_events
+ valuetable.events in
+ let valuetable = { valuetable with events = new_events } in
+ VValueTable.set t.env.value value valuetable
+ in
+ VValueTable.iter_initializedi {VValueTable.iteri} t.env.value;
+
+ (** wakeup the daemons *)
+ Wait.wakeup_events_bag
+ Events.Wait.translate_change t other_event other_node
+
+ let do_delayed_merge t pexp node1_0 node2_0 inv =
+ let dom_not_done = merge_dom t pexp node1_0 node2_0 inv in
+ if dom_not_done
+ then begin
+ Debug.dprintf4 debug "[Egraph] @[merge %a %a dom not done@]"
+ Node.pp node1_0 Node.pp node2_0;
+ t.todo_delayed_merge <- Some (pexp,node1_0,node2_0,inv)
+ end
+ else
+ finalize_merge t pexp node1_0 node2_0 inv
+
+ (** merge two pending actions *)
+ let merge_pending t pexp node1_0 node2_0 =
+ let node1 = find t node1_0 in
+ let node2 = find t node2_0 in
+ if not (Node.equal node1 node2) then begin
+ let ((other_node0,_),(_,repr_node)) =
+ choose_repr t.env (node1_0,node1) (node2_0,node2) in
+ let inv = not (Node.equal node1_0 other_node0) in
+ Trail.add_merge_start t.env.trail pexp
+ ~node1:node1_0 ~node2:node2_0
+ ~node1_repr:node1 ~node2_repr:node2
+ ~new_repr:repr_node;
+ do_delayed_merge t pexp node1_0 node2_0 inv
+ end
+
+ (** {2 Internal scheduler} *)
+
+ (**
+ - Set dom, set value are done immediately
+ - daemon immediate
+ - merge domain
+ - end merging (the class are really merged)
+ - start merging (+ merge value)
+ - daemon not immediate
+ *)
+
+ let rec do_pending_daemon delayed (Events.Wait.DaemonKey (dem,runable)) =
+ let (module Dem) = Wait.get_dem dem in
+ match Dem.run delayed runable with
+ | None -> ()
+ | Some runable -> Wait.new_pending_daemon delayed dem runable
+
+ and nothing_todo t =
+ Queue.is_empty t.todo_immediate_dem
+ && Queue.is_empty t.todo_merge_dom
+ && Equal.physical t.todo_delayed_merge None
+ && Queue.is_empty t.todo_merge
+ && Queue.is_empty t.todo_ext_action
+
+ and do_pending t =
+ draw_graph t.env;
+ if not (Queue.is_empty t.todo_immediate_dem) then
+ match Queue.pop t.todo_immediate_dem with
+ | RunDem att ->
+ Debug.dprintf0 debug "[Egraph] @[do_pending RunDem immediate@]";
+ do_pending_daemon t att;
+ do_pending t
+ else if not (Queue.is_empty t.todo_merge_dom) then
+ match Queue.pop t.todo_merge_dom with
+ | SetMergeDomNode(pexp,dom,node1,node2,inv) ->
+ Debug.dprintf6 debug "[Egraph] @[do_pending SetDomNode %a %a %a@]"
+ DomKind.pp dom Node.pp node1 Node.pp node2;
+ merge_dom_pending t pexp dom node1 node2 inv;
+ do_pending t
+ else match t.todo_delayed_merge with
+ | Some(pexp,node1_0,node2_0,inv) ->
+ t.todo_delayed_merge <- None;
+ assert (not (merge_dom ~dry_run:true t pexp node1_0 node2_0 inv));
+ (** understand why that happend.
+ Is it really needed to do a fixpoint? *)
+ do_delayed_merge t pexp node1_0 node2_0 inv;
+ do_pending t
+ | None ->
+ if not (Queue.is_empty t.todo_merge) then
+ match Queue.pop t.todo_merge with
+ | Merge (pexp,node1,node2) ->
+ Debug.dprintf4 debug "[Egraph] @[do_pending Merge %a %a@]"
+ Node.pp node1 Node.pp node2;
+ merge_pending t pexp node1 node2;
+ do_pending t
+ else if not (Queue.is_empty t.todo_ext_action) then
+ (begin match Queue.pop t.todo_ext_action with
+ | ExtDem att ->
+ Debug.dprintf0 debug "[Egraph] @[do_pending RunDem@]";
+ let store_ext_action = Queue.create () in
+ Queue.transfer t.todo_ext_action store_ext_action;
+ do_pending_daemon t att;
+ Queue.transfer store_ext_action t.todo_ext_action;
+ end;
+ do_pending t)
+ else
+ Debug.dprintf0 debug "[Egraph] Nothing to do"
+
+ and flush_internal d =
+ assert (Equal.physical d.env.current_delayed d);
+ Debug.dprintf0 debug "[Egraph] @[flush delayed@]";
+ try
+ if not (Queue.is_empty d.todo_ext_action) then
+ let saved_ext_action = Queue.create () in
+ Queue.transfer d.todo_ext_action saved_ext_action;
+ do_pending d;
+ assert (nothing_todo d);
+ Queue.transfer saved_ext_action d.todo_ext_action;
+ else begin
+ do_pending d;
+ assert (nothing_todo d);
+ end;
+ Debug.dprintf0 debug "[Egraph] @[flush delayed end@]"
+ with e when Debug.test_flag debug &&
+ not (Debug.test_flag Debug.stack_trace) ->
+ raise e
+
+ (** {2 API} *)
+
+ let merge t pexp node1_0 node2_0 =
+ assert (is_current_env t);
+ if not (Node.equal
+ (find t node1_0)
+ (find t node2_0)) then
+ add_pending_merge t pexp node1_0 node2_0
+
+ let check d node =
+ assert (Equal.physical d.env.current_delayed d);
+ assert (is_registered d node)
+
+ let set_thterm d pexp node thterm =
+ Debug.dprintf4 debug "[Egraph] @[add_pending_set_thterm for %a and %a@]"
+ Node.pp node ThTerm.pp thterm;
+ check d node;
+ set_sem_pending d pexp node thterm
+
+ let set_value d pexp node nodevalue =
+ Debug.dprintf4 debug_few
+ "[Egraph] @[set_value for %a with %a@]"
+ Node.pp node Value.pp nodevalue;
+ check d node;
+ set_value_pending d pexp node nodevalue
+
+ let set_dom d dom node v =
+ Debug.dprintf4 debug_few
+ "[Egraph] @[set_dom for %a with %a@]"
+ Node.pp node (print_dom dom) v;
+ check d node;
+ set_dom_pending d dom node (Some v)
+
+ let set_dom_premerge d dom node v =
+ Debug.dprintf4 debug
+ "[Egraph] @[set_dom_premerge for %a with %a@]"
+ Node.pp node (print_dom dom) v;
+ check d node;
+ let node' = match d.todo_delayed_merge with
+ | Some(_,node1,node2,_) when Node.equal node1 node -> node2
+ | Some(_,node1,node2,_) when Node.equal node2 node -> node1
+ | _ -> raise (BrokenInvariant(
+ "set_dom_premerge should be used only on the \
+ nodeasses currently merged")) in
+ set_dom_premerge_pending d dom ~from:node' node v
+
+ let unset_dom d dom node =
+ Debug.dprintf2 debug
+ "[Egraph] @[unset_dom for %a@]"
+ Node.pp node;
+ check d node;
+ set_dom_pending d dom node None
+
+ let register_decision t chogen =
+ t.sched_decision chogen
+
+ let mk_pexp t ?age kexp exp = Trail.mk_pexp ?age t.env.trail kexp exp
+ let current_age t = Trail.current_age t.env.trail
+ let add_pexp t pexp = Trail.add_pexp t.env.trail pexp
+
+ let contradiction d pexp =
+ d.env.current_delayed <- unsat_delayed;
+ raise (Contradiction pexp)
+
+ (** {2 API for attaching event} *)
+
+ let attach_dom (type a) t node (dom : a DomKind.t) dem event =
+ let node = find_def t node in
+ let event = Events.Wait.Event (dem,event) in
+ let domtable = get_table_dom t.env dom in
+ let domtable = {
+ domtable with
+ events = Node.M.add_change Bag.elt Bag.add node event domtable.events
+ }
+ in
+ VDomTable.set t.env.dom dom domtable
+
+ let attach_value (type a) t node (value : a ValueKind.t) dem event =
+ let node = find_def t node in
+ let event = Events.Wait.Event (dem,event) in
+ let valuetable = (get_table_value t.env value) in
+ let valuetable = {
+ valuetable with
+ events = Node.M.add_change Bag.elt Bag.add node event valuetable.events
+ } in
+ VValueTable.set t.env.value value valuetable
+
+ let attach_node t node dem event =
+ let node = find_def t node in
+ let event = Events.Wait.Event (dem,event) in
+ t.env.event_repr <- Node.M.add_change Bag.elt Bag.add node event t.env.event_repr
+
+ let attach_any_value t node dem event =
+ let node = find_def t node in
+ let event = Events.Wait.Event (dem,event) in
+ t.env.event_value <- Node.M.add_change Bag.elt Bag.add node event t.env.event_value
+
+ let attach_reg_node t node dem event =
+ let event = Events.Wait.Event (dem,event) in
+ match find t node with
+ | node -> (** already registered *)
+ Wait.wakeup_events_list Events.Wait.translate_regnode t (Some [event]) node
+ | exception NotRegistered ->
+ t.env.event_reg <-
+ Node.M.add_change Lists.singleton Lists.add node event t.env.event_reg
+
+ let attach_reg_sem (type a) t (sem : a ThTermKind.t) dem event =
+ let event = Events.Wait.Event (dem,event) in
+ let reg_events = get_table_sem t.env sem in
+ let reg_events = event::reg_events in
+ ThTermKind.Vector.set t.env.sem sem reg_events
+
+ let attach_reg_value (type a) t (value : a ValueKind.t) dem event =
+ let event = Events.Wait.Event (dem,event) in
+ let value_table = get_table_value t.env value in
+ let reg_events = event::value_table.reg_events in
+ VValueTable.set t.env.value value {value_table with reg_events}
+
+ let attached_reg_node
+ (type k) (type d) d node (dem:(k,d) Events.Dem.t) : k Enum.t =
+ Enum.from_list
+ ~filter:(function
+ | Events.Wait.Event(dem',_) ->
+ Events.Dem.equal dem dem'
+ )
+ ~map:(fun (Events.Wait.Event(dem',event)) ->
+ let Poly.Eq = Events.Dem.Eq.coerce_type dem dem' in (event:k)
+ )
+ (Node.M.find_def [] node d.env.event_reg)
+
+ let attached_node
+ (type k) (type d) d node (dem:(k,d) Events.Dem.t) : k Enum.t =
+ Enum.from_bag
+ ~filter:(fun (Events.Wait.Event(dem',_)) -> Events.Dem.equal dem dem')
+ ~map:(fun (Events.Wait.Event(dem',event)) ->
+ let Poly.Eq = Events.Dem.Eq.coerce_type dem dem' in (event:k) )
+ (Node.M.find_def Bag.empty node d.env.event_repr)
+
+
+end
+
+include Delayed
+
+module Backtrackable = struct
+
+ let check_disabled_delayed t =
+ Equal.physical t.current_delayed dumb_delayed
+ || Equal.physical t.current_delayed unsat_delayed
+
+ type delayed = t
+ type t = Hidden.hidden
+
+ let new_t context =
+ Hidden.hide {
+ repr = Node.M.empty;
+ rang = Node.M.empty;
+ event_repr = Node.M.empty;
+ event_value = Node.M.empty;
+ event_reg = Node.M.empty;
+ event_any_reg = [];
+ dom = VDomTable.create 5;
+ sem = VSemTable.create 5;
+ value = VValueTable.create 5;
+ envs = Env.VectorH.create 5;
+ trail = Trail.create context;
+ current_delayed = dumb_delayed;
+ history = Hidden.create context;
+ }
+
+ (* let new_handle t =
+ * assert (Equal.physical t.current_delayed dumb_delayed);
+ * {
+ * repr = t.repr;
+ * rang = t.rang;
+ * event_repr = t.event_repr;
+ * event_value = t.event_value;
+ * event_reg = t.event_reg;
+ * event_any_reg = t.event_any_reg;
+ * dom = VDomTable.copy t.dom;
+ * sem = VSemTable.copy t.sem;
+ * value = VValueTable.copy t.value;
+ * envs = Env.VectorH.copy t.envs;
+ * trail = Trail.new_handle t.trail;
+ * current_delayed = t.current_delayed;
+ * } *)
+
+ let context t =
+ let t = Hidden.ro t in
+ Hidden.creator t.history
+
+ let new_delayed ~sched_daemon ~sched_decision t =
+ let t = Hidden.rw t in
+ assert (Equal.physical t.current_delayed dumb_delayed);
+ let d = { env = t;
+ todo_immediate_dem = Queue.create ();
+ todo_merge_dom = Queue.create ();
+ todo_delayed_merge = None;
+ todo_merge = Queue.create ();
+ todo_ext_action = Queue.create ();
+ sched_daemon; sched_decision;
+ } in
+ t.current_delayed <- d;
+ d
+
+ let delayed_stop d =
+ assert (Equal.physical d.env.current_delayed d);
+ assert (Delayed.nothing_todo d);
+ d.env.current_delayed <- dumb_delayed
+
+ let flush d =
+ assert (Equal.physical d.env.current_delayed d);
+ Delayed.do_pending d;
+ assert (Delayed.nothing_todo d)
+
+ let run_daemon d dem =
+ Queue.push (ExtDem dem) d.todo_ext_action
+
+ let is_registered t node =
+ let t = Hidden.rw t in
+ T.is_registered t node
+
+ let is_equal t node1 node2 =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ let node1,node2 = Shuffle.shuffle2 (node1,node2) in
+ Debug.dprintf4 debug "[Egraph] @[is_equal %a %a@]"
+ Node.pp node1 Node.pp node2;
+ draw_graph t;
+ T.is_equal t node1 node2
+
+ let find t node =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ T.find t node
+
+ let get_dom t dom node =
+ let t = Hidden.rw t in
+ T.get_dom t dom node
+
+ let get_value t value node =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ T.get_value t value node
+
+ let get_env t env =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ T.get_env t env
+
+ let set_env t env v =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ T.set_env t env v
+
+ let is_repr t node =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ T.is_repr t node
+
+ let find_def t node =
+ let t = Hidden.rw t in
+ assert (check_disabled_delayed t);
+ T.find_def t node
+
+ let get_trail t =
+ let t = Hidden.ro t in
+ (* assert (check_disabled_delayed t); *)
+ t.trail
+
+ let get_getter t =
+ (* assert (check_disabled_delayed t); *)
+ t
+
+ let new_dec t =
+ let t = Hidden.ro t in
+ assert (check_disabled_delayed t);
+ Trail.new_dec t.trail
+
+ let current_age (t:t) =
+ let t = Hidden.ro t in
+ Trail.current_age t.trail
+ let current_nbdec (t:t) =
+ let t = Hidden.ro t in
+ Trail.nbdec t.trail
+
+ let get_direct_dom t dom node =
+ assert (check_disabled_delayed t);
+ get_direct_dom t dom node
+
+ let draw_graph ?force t = let t = Hidden.ro t in draw_graph ?force t
+ let output_graph s t = let t = Hidden.ro t in output_graph s t
+end
+
+module type Getter = sig
+ type t
+
+ val is_equal : t -> Node.t -> Node.t -> bool
+ val find_def : t -> Node.t -> Node.t
+ val get_dom : t -> 'a DomKind.t -> Node.t -> 'a option
+ (** dom of the nodeass *)
+ val get_value : t -> 'a ValueKind.t -> Node.t -> 'a option
+ (** value of the nodeass *)
+
+ (** {4 The nodeasses must have been marked has registered} *)
+
+ val find : t -> Node.t -> Node.t
+ val is_repr : t -> Node.t -> bool
+
+ val is_registered : t -> Node.t -> bool
+
+ val get_env : t -> 'a Env.t -> 'a
+ val set_env : t -> 'a Env.t -> 'a -> unit
+
+ val context : t -> Context.creator
+
+end
+
+module Getter : Getter with type t = Backtrackable.t = Backtrackable
+
+module type Ro = sig
+ type t
+ include Getter with type t := t
+
+ (** {3 Immediate information} *)
+ val register : t -> Node.t -> unit
+
+ val is_current_env: t -> bool
+
+end
+
+module Ro : Ro with type t = Delayed.t = Delayed
+
+let check_initialization () =
+ VDom.is_well_initialized () && Wait.is_well_initialized ()
+
+let () = Exn_printer.register (fun fmt exn ->
+ match exn with
+ | UninitializedEnv env ->
+ Format.fprintf fmt "The environnement of %s is not initialized." env
+ | exn -> raise exn
+ )
diff --git a/src/core/egraph.mli b/src/core/egraph.mli
new file mode 100644
index 000000000..afadd49b6
--- /dev/null
+++ b/src/core/egraph.mli
@@ -0,0 +1,183 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Egraph is the main module of core *)
+
+(** The solver contains all the information. It keeps track of
+ equivalence classes, values. It take care to schedule event that
+ happened. *)
+
+open Trail
+open Nodes
+
+exception NotRegistered
+
+exception UninitializedEnv of string
+
+exception Contradiction of Trail.Pexp.t
+
+module type Getter = sig
+ type t
+
+ val is_equal : t -> Node.t -> Node.t -> bool
+ val find_def : t -> Node.t -> Node.t
+ val get_dom : t -> 'a DomKind.t -> Node.t -> 'a option
+ (** dom of the class *)
+ val get_value : t -> 'a ValueKind.t -> Node.t -> 'a option
+ (** value of the class *)
+
+ (** {4 The classes must have been registered} *)
+
+ val find : t -> Node.t -> Node.t
+ val is_repr : t -> Node.t -> bool
+
+ val is_registered : t -> Node.t -> bool
+
+ val get_env : t -> 'a Env.t -> 'a
+ val set_env : t -> 'a Env.t -> 'a -> unit
+
+ val context : t -> Context.creator
+
+end
+
+module type Ro = sig
+ type t
+ include Getter with type t := t
+
+ val register : t -> Node.t -> unit
+ (** Add a new node to register *)
+
+ val is_current_env: t -> bool
+
+end
+
+module Ro : Ro
+
+type t = private Ro.t
+include Ro with type t := t
+
+(** {3 Immediate modifications} *)
+val set_dom : t -> 'a DomKind.t -> Node.t -> 'a -> unit
+(** change the dom of the equivalence class *)
+
+val unset_dom : t -> 'a DomKind.t -> Node.t -> unit
+(** remove the dom of the equivalence class *)
+
+
+(** {3 Delayed modifications} *)
+val set_thterm : t -> Trail.Pexp.t -> Node.t -> ThTerm.t -> unit
+(** attach a theory term to an equivalence class *)
+
+val set_value: t -> Trail.Pexp.t -> Node.t -> Value.t -> unit
+(** attach value to an equivalence class *)
+
+val merge : t -> Trail.Pexp.t -> Node.t -> Node.t -> unit
+
+
+(** {3 Attach Event} *)
+val attach_dom: t -> Node.t -> 'a DomKind.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when the dom change *)
+val attach_value: t -> Node.t -> 'a ValueKind.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when a value is attached to this equivalence class *)
+val attach_any_value: t -> Node.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when any kind of value is attached to this equivalence class *)
+val attach_reg_node: t -> Node.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when this node is registered *)
+val attach_reg_sem: t -> 'a ThTermKind.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when a new semantical class is registered *)
+val attach_reg_value: t -> 'a ValueKind.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when a new value is registered *)
+val attach_node: t -> Node.t -> ('event,'r) Events.Dem.t -> 'event -> unit
+(** wakeup when it is not anymore the representative class *)
+
+val register_decision: t -> Trail.chogen -> unit
+(** register a decision that would be scheduled later. The
+ [choose_decision] of the [Cho] will be called at that time to know
+ if the decision is still needed. *)
+
+(** {3 Trails} *)
+val mk_pexp: t -> ?age:age -> 'a Exp.t -> 'a -> Trail.Pexp.t
+val current_age: t -> age
+val add_pexp: t -> Trail.Pexp.t -> unit
+val contradiction: t -> Trail.Pexp.t -> 'b
+
+(** {3 Low level} *)
+val flush_internal: t -> unit
+(** Apply all the modifications and direct consequences.
+ Should be used only during wakeup of not immediate daemon
+*)
+
+module Wait : Events.Wait.S with type delayed = t and type delayed_ro = Ro.t
+
+
+(** {2 Domains and Semantic Values key creation} *)
+
+module type Dom = DomKind.Dom_partial with type delayed := t and type pexp := Trail.Pexp.t
+
+val register_dom : (module Dom with type t = 'a) -> unit
+
+val check_initialization: unit -> bool
+(** Check if the initialization of all the dom, sem and dem have been done *)
+
+val print_dom: 'a DomKind.t -> 'a Format.printer
+val print_dom_opt: 'a DomKind.t -> 'a option Format.printer
+
+module Getter : Getter
+
+(** {2 External use of the solver} *)
+module Backtrackable: sig
+ type delayed = t
+ include Getter
+
+ val new_t : Context.creator -> t
+
+ val new_delayed :
+ sched_daemon:(Events.Wait.daemon_key -> unit) ->
+ sched_decision:(chogen -> unit) ->
+ t -> delayed
+ (** The solver shouldn't be used anymore before
+ calling flush. (flushd doesn't count)
+ *)
+
+ val run_daemon: delayed -> Events.Wait.daemon_key -> unit
+ (** schedule the run of a deamon *)
+
+ val delayed_stop: delayed -> unit
+ (** Apply all the modifications and direct consequences.
+ The argument shouldn't be used anymore *)
+
+ val flush: delayed -> unit
+ (** Apply all the modifications and direct consequences.
+ The argument can be used after that *)
+
+
+
+ (* val make_decisions : delayed -> attached_daemons -> unit *)
+
+ val get_trail : t -> Trail.t
+ val get_getter : t -> Getter.t
+ val new_dec : t -> Trail.dec
+ val current_age : t -> Trail.Age.t
+ val current_nbdec : t -> int
+
+ (** Debug *)
+ val draw_graph: ?force:bool -> t -> unit
+ val output_graph : string -> t -> unit
+end
diff --git a/src/inputlang/smtlib2/popop_of_smtlib2.mli b/src/core/env.ml
similarity index 52%
rename from src/inputlang/smtlib2/popop_of_smtlib2.mli
rename to src/core/env.ml
index e906b1e80..a93539cdc 100644
--- a/src/inputlang/smtlib2/popop_of_smtlib2.mli
+++ b/src/core/env.ml
@@ -1,34 +1,35 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
-exception Not_supported of Loc.position
+module Env = Keys.Make_key(struct end)
-val read_file: string -> Smtlib2_ast.commands
+include Env
-type status =
- | Sat
- | Unsat
- | Unknown
+type 'a data = {key: 'a Env.t; pp: 'a Format.printer}
-val check_file: Smtlib2_ast.commands -> status
+module VEnv = Env.Make_Registry(struct
+ type nonrec 'a data = 'a data
+ let pp d = d.pp
+ let key d = d.key
+ end)
-val print_status: status Pp.printer
+let register pp key = VEnv.register {key;pp}
+let print = VEnv.print
+let check_is_registered = VEnv.check_is_registered
diff --git a/src/core/env.mli b/src/core/env.mli
new file mode 100644
index 000000000..bf2e683bf
--- /dev/null
+++ b/src/core/env.mli
@@ -0,0 +1,35 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Theory specific environment *)
+
+(** Environment should currently be persistent data-structure in order
+ to be backtracked correctly *)
+
+include Keys.Key
+
+val register: 'a Format.printer -> 'a t -> unit
+(** Only a pretty printer is needed for registration *)
+
+val print: 'a t -> 'a Format.printer
+(** Get a pretty printer for a particular environment *)
+
+val check_is_registered: 'a t -> unit
+(** Check if all the keys created have been registered *)
diff --git a/src/core/events.ml b/src/core/events.ml
new file mode 100644
index 000000000..1018ab6ee
--- /dev/null
+++ b/src/core/events.ml
@@ -0,0 +1,280 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Nodes
+
+let debug = Debug.register_info_flag ~desc:"for the events" "Egraph.events"
+
+(** Dem *)
+
+module Dem = Keys.Make_key2(struct end)
+
+module Print = struct (** Cutting the knot for pp *)
+
+ type pdem_event = { mutable
+ pdem_event : 'k 'd. ('k,'d) Dem.t -> 'k Format.printer}
+
+ let pdem_event : pdem_event =
+ {pdem_event = fun _ _ _ -> assert false} (** called too early *)
+ let dem_event dem fmt s = pdem_event.pdem_event dem fmt s
+
+ type pdem_runable = { mutable
+ pdem_runable : 'k 'd. ('k,'d) Dem.t -> 'd Format.printer}
+
+ let pdem_runable : pdem_runable =
+ {pdem_runable = fun _ _ _ -> assert false} (** called too early *)
+ let dem_runable dem fmt s = pdem_runable.pdem_runable dem fmt s
+
+
+end
+
+
+module Fired = struct
+ type 'b event =
+ (** the domain dom of the class change *)
+ | EventDom : Node.t * 'a DomKind.t * 'b -> 'b event
+ (** the value of the class has been set *)
+ | EventValue : Node.t * 'a ValueKind.t * 'b -> 'b event
+ (** a new theory term 'a point to this class (not complete) *)
+ | EventSem : Node.t * 'a ThTermKind.t * 'a * 'b -> 'b event
+ (** we want to register a class *)
+ | EventReg : Node.t * 'b -> 'b event
+ (** we want to register this class *)
+ | EventRegNode : Node.t * 'b -> 'b event
+ (** This class is not the representant of its eq-class anymore *)
+ | EventChange : Node.t * 'b -> 'b event
+ (** a new semantical term 'a appear *)
+ | EventRegSem : ThTerm.t * 'b -> 'b event
+ (** a new value 'a appear *)
+ | EventRegValue : Value.t * 'b -> 'b event
+
+ let pp fmt = function
+ | EventDom (node, dom, _) ->
+ Format.fprintf fmt "dom:%a of %a" DomKind.pp dom Node.pp node
+ | EventValue (node, value, _) ->
+ Format.fprintf fmt "value:%a of %a" ValueKind.pp value Node.pp node
+ | EventSem (node, sem, v, _) ->
+ Format.fprintf fmt "sem:%a of %a with %a"
+ ThTermKind.pp sem Node.pp node (print_thterm sem) v
+ | EventReg (node, _) ->
+ Format.fprintf fmt "any registration of %a" Node.pp node
+ | EventRegNode (node, _) ->
+ Format.fprintf fmt "registration of %a" Node.pp node
+ | EventChange (node, _) ->
+ Format.fprintf fmt "change of %a" Node.pp node
+ | EventRegSem (thterm, _) ->
+ let node = Only_for_solver.node_of_thterm thterm in
+ begin match Only_for_solver.sem_of_node thterm with
+ | Only_for_solver.ThTerm(sem,v) ->
+ Format.fprintf fmt "registration of sem:%a of %a with %a"
+ ThTermKind.pp sem Node.pp node (print_thterm sem) v
+ end
+ | EventRegValue (nodevalue, _) ->
+ let node = Only_for_solver.node_of_nodevalue nodevalue in
+ begin match Only_for_solver.value_of_node nodevalue with
+ | Only_for_solver.Value(value,v) ->
+ Format.fprintf fmt "registration of value:%a of %a with %a"
+ ValueKind.pp value Node.pp node (print_value value) v
+ end
+
+ let get_data = function
+ | EventDom (_, _ , d) -> d
+ | EventValue (_, _ , d) -> d
+ | EventSem (_, _, _, d) -> d
+ | EventReg (_, d) -> d
+ | EventRegNode (_, d) -> d
+ | EventChange (_, d) -> d
+ | EventRegSem (_, d) -> d
+ | EventRegValue (_,d) -> d
+
+ type 'b t = 'b event list
+end
+
+module Wait = struct
+ type t =
+ | Event: ('k,'d) Dem.t * 'k -> t
+
+ let pp fmt = function
+ | Event (dem, event) ->
+ let f (type k) (type d) (dem:(k,d) Dem.t) (event : k) =
+ Format.fprintf fmt "Demon %a event %a"
+ Dem.pp dem (Print.dem_event dem) event
+ in
+ f dem event
+
+ type _ enqueue =
+ | EnqRun: 'r -> 'r enqueue
+ | EnqAlready: _ enqueue
+ | EnqRedirected: ('e,'r) Dem.t * 'e -> _ enqueue
+ | EnqStopped: _ enqueue
+
+ type daemon_key =
+ | DaemonKey: ('k,'runable) Dem.t * 'runable -> daemon_key
+
+
+ type 'a translate = { translate : 'd. 'a -> 'd -> 'd Fired.event}
+
+ let translate_dom =
+ {translate = fun (node,dom) data -> EventDom(node,dom,data)}
+ let translate_value =
+ {translate = fun (node,value) data -> EventValue(node,value,data)}
+ let translate_sem =
+ {translate = fun (node,sem,s) data -> EventSem(node,sem,s,data)}
+ let translate_reg =
+ {translate = fun node data -> EventReg(node,data)}
+ let translate_regnode =
+ {translate = fun node data -> EventRegNode(node,data)}
+ let translate_change =
+ {translate = fun node data -> EventChange(node,data)}
+ let translate_regsem =
+ {translate = fun thterm data -> EventRegSem(thterm,data)}
+ let translate_regvalue =
+ {translate = fun nodeval data -> EventRegValue(nodeval,data)}
+
+
+ module type S = sig
+ type delayed
+ type delayed_ro
+
+ module type Dem =
+ sig
+ type runable
+ val print_runable : runable Format.printer
+ val run : delayed -> runable -> runable option
+ type event
+ val print_event : event Format.printer
+ val enqueue : delayed_ro -> event Fired.event -> runable enqueue
+ val key : (event, runable) Dem.t
+ val immediate : bool
+ end
+
+ val register_dem : (module Dem with type event = 'k and type runable = 'd) -> unit
+
+ val get_dem : ('k, 'd) Dem.t -> (module Dem with type event = 'k and type runable = 'd)
+
+ val print_dem_event : ('a, 'b) Dem.t -> 'a Format.printer
+
+ val print_dem_runable : ('a, 'b) Dem.t -> 'b Format.printer
+
+ val new_pending_daemon : delayed -> ('a, 'b) Dem.t -> 'b -> unit
+
+ val wakeup_event : 'a translate -> delayed -> 'a -> t -> unit
+
+ val wakeup_events_list :
+ 'a translate -> delayed -> t list option -> 'a -> unit
+
+ val wakeup_events_bag :
+ 'a translate -> delayed -> t Bag.t option -> 'a -> unit
+
+ val is_well_initialized : unit -> bool
+ end
+
+ module Make(S:sig
+ type delayed
+ val schedule_immediate: delayed -> daemon_key -> unit
+ val schedule: delayed -> daemon_key -> unit
+
+ type delayed_ro
+ val readonly : delayed -> delayed_ro
+ end) : S with type delayed = S.delayed
+ and type delayed_ro = S.delayed_ro = struct
+
+ type delayed = S.delayed
+ type delayed_ro = S.delayed_ro
+
+ module type Dem = sig
+ type runable
+ val print_runable: runable Format.printer
+ val run: delayed -> runable -> runable option
+
+ type event
+ val print_event: event Format.printer
+ val enqueue: delayed_ro -> event Fired.event -> runable enqueue
+
+ val key: (event,runable) Dem.t
+ val immediate: bool
+
+ end
+
+ module Registry = Dem.Make_Registry(struct
+ type ('k,'d) data = (module Dem with type event = 'k and type runable = 'd)
+ let ppk (type k) (type d) (dem: (k,d) data) =
+ let module Dem = (val dem) in
+ Dem.print_event
+ let ppd (type k) (type d) (dem: (k,d) data) =
+ let module Dem = (val dem) in
+ Dem.print_runable
+ let key (type k) (type d) (dem: (k,d) data) =
+ let module Dem = (val dem) in
+ Dem.key
+ end
+ )
+
+ let register_dem = Registry.register
+ let get_dem = Registry.get
+
+ let print_dem_event = Registry.printk
+ let () = Print.pdem_event.Print.pdem_event <- print_dem_event
+
+ let print_dem_runable = Registry.printd
+ let () = Print.pdem_runable.Print.pdem_runable <- print_dem_runable
+
+ let is_well_initialized = Registry.is_well_initialized
+
+ let new_pending_daemon (type k) (type d) t (dem:(k,d) Dem.t) runable =
+ let module Dem = (val get_dem dem) in
+ let daemonkey = DaemonKey(dem, runable) in
+ if Dem.immediate
+ then S.schedule_immediate t daemonkey
+ else S.schedule t daemonkey
+
+ let wakeup_event translate t info wevent =
+ match wevent with
+ | Event (dem,event) ->
+ let rec f : type event r. S.delayed -> (event,r) Dem.t -> event -> unit =
+ fun t dem event ->
+ let module Dem = (val get_dem dem) in
+ let event = translate.translate info event in
+ match Dem.enqueue (S.readonly t) event with
+ | EnqStopped -> () (** todo remove from the list of event *)
+ | EnqAlready -> ()
+ | EnqRedirected(dem,event) -> f t dem event
+ | EnqRun runable -> new_pending_daemon t dem runable
+ in
+ f t dem event
+
+ let wakeup_events_list translate t events info =
+ match events with
+ | None | Some [] ->
+ Debug.dprintf0 debug "[Egraph] @[No scheduling@]"
+ | Some events ->
+ List.iter (wakeup_event translate t info) events
+
+ let wakeup_events_bag translate t events info =
+ let is_empty = match events with
+ | None -> true
+ | Some events -> Bag.is_empty events in
+ if is_empty then Debug.dprintf0 debug "[Egraph] @[No scheduling@]"
+ else Bag.iter (wakeup_event translate t info) (Opt.get events)
+
+
+ end
+end
diff --git a/src/core/events.mli b/src/core/events.mli
new file mode 100644
index 000000000..b0cc4b93c
--- /dev/null
+++ b/src/core/events.mli
@@ -0,0 +1,124 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Nodes
+
+module Fired : sig
+ type 'b event =
+ (** the domain dom of the class change *)
+ | EventDom : Node.t * 'a DomKind.t * 'b -> 'b event
+ (** the value of the node has been set *)
+ | EventValue : Node.t * 'a ValueKind.t * 'b -> 'b event
+ (** a new semantical term 'a point to this class (not complete) *)
+ | EventSem : Node.t * 'a ThTermKind.t * 'a * 'b -> 'b event
+ (** we want to register a class *)
+ | EventReg : Node.t * 'b -> 'b event
+ (** we want to register this class *)
+ | EventRegNode : Node.t * 'b -> 'b event
+ (** This class is not the representant of its eq-class anymore *)
+ | EventChange : Node.t * 'b -> 'b event
+ (** a new semantical term 'a appear *)
+ | EventRegSem : ThTerm.t * 'b -> 'b event
+ (** a new value 'a appear *)
+ | EventRegValue : Value.t * 'b -> 'b event
+
+ val pp: 'b event Format.printer
+ val get_data: 'b event -> 'b
+
+ type 'b t = 'b event list
+
+end
+
+module Dem: Keys.Key2
+
+module Wait : sig
+ type t =
+ | Event: ('k,'d) Dem.t * 'k -> t
+
+
+ type _ enqueue =
+ | EnqRun: 'r -> 'r enqueue
+ | EnqAlready: _ enqueue
+ | EnqRedirected: ('e,'r) Dem.t * 'e -> _ enqueue
+ | EnqStopped: _ enqueue
+
+ type daemon_key =
+ | DaemonKey: ('k,'runable) Dem.t * 'runable -> daemon_key
+
+ val pp: t Format.printer
+
+ type 'a translate = { translate : 'd. 'a -> 'd -> 'd Fired.event}
+
+ val translate_dom : (Node.t * 'a DomKind.t) translate
+ val translate_value : (Node.t * 'a ValueKind.t) translate
+ val translate_reg : Node.t translate
+ val translate_regnode : Node.t translate
+ val translate_change : Node.t translate
+ val translate_regsem : ThTerm.t translate
+ val translate_regvalue : Value.t translate
+
+ module type S = sig
+ type delayed
+ type delayed_ro
+
+ module type Dem =
+ sig
+ type runable
+ val print_runable : runable Format.printer
+ val run : delayed -> runable -> runable option
+ type event
+ val print_event : event Format.printer
+ val enqueue : delayed_ro -> event Fired.event -> runable enqueue
+ val key : (event, runable) Dem.t
+ val immediate : bool
+ end
+
+ val register_dem : (module Dem with type event = 'k and type runable = 'd) -> unit
+
+ val get_dem : ('k, 'd) Dem.t -> (module Dem with type event = 'k and type runable = 'd)
+
+ val print_dem_event : ('a, 'b) Dem.t -> 'a Format.printer
+
+ val print_dem_runable : ('a, 'b) Dem.t -> 'b Format.printer
+
+ val new_pending_daemon : delayed -> ('a, 'b) Dem.t -> 'b -> unit
+
+ val wakeup_event : 'a translate -> delayed -> 'a -> t -> unit
+
+ val wakeup_events_list :
+ 'a translate -> delayed -> t list option -> 'a -> unit
+
+ val wakeup_events_bag :
+ 'a translate -> delayed -> t Bag.t option -> 'a -> unit
+
+ val is_well_initialized : unit -> bool
+ end
+
+
+ module Make(S:sig
+ type delayed
+ val schedule_immediate: delayed -> daemon_key -> unit
+ val schedule: delayed -> daemon_key -> unit
+
+ type delayed_ro
+ val readonly : delayed -> delayed_ro
+ end) : S with type delayed = S.delayed and type delayed_ro = S.delayed_ro
+end
diff --git a/src/core/interp.ml b/src/core/interp.ml
new file mode 100644
index 000000000..ebc5b6da1
--- /dev/null
+++ b/src/core/interp.ml
@@ -0,0 +1,115 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Std
+
+module Register = struct
+
+ let ids : (Term.id -> Nodes.Value.t list -> Nodes.Value.t option) list ref = ref []
+ let id f = ids := f::!ids
+
+ module ThInterp = Nodes.ThTermKind.MkVector(struct
+ type ('a,_) t = (interp:(Nodes.Node.t -> Nodes.Value.t) -> 'a -> Nodes.Value.t)
+ end)
+
+ let thterms = ThInterp.create 10
+ let thterm sem f =
+ if not (ThInterp.is_uninitialized thterms sem)
+ then invalid_arg (Format.asprintf "Interpretation for semantic value %a already done" Nodes.ThTermKind.pp sem);
+ ThInterp.set thterms sem f
+
+ let models = Ty.H.create 16
+ let model ty (f:Egraph.t -> Nodes.Node.t -> Nodes.Value.t) =
+ Ty.H.add models ty f
+
+end
+
+exception NoInterpretation of Term.id
+exception CantInterpretTerm of Term.t
+exception CantInterpretThTerm of Nodes.ThTerm.t
+
+type leaf = Term.t -> Nodes.Value.t option
+
+(** No cache currently because there is no guaranty
+ that the variable in the let is unique *)
+let term ?(leaf=(fun _ -> None)) t =
+ let rec interp leaf t =
+ match leaf t with
+ | Some v -> v
+ | None ->
+ let rec aux leaf args = function
+ | { Term.term = App (f, arg); _ } ->
+ aux leaf ((interp leaf arg) :: args) f
+ | { Term.term = Let (v,e,t); _ } ->
+ let v' = interp leaf e in
+ let leaf t = match t.Term.term with
+ | Id id when Term.Id.equal v id -> Some v'
+ | _ -> leaf t in
+ aux leaf args t
+ | { Term.term = Id id; _ } ->
+ let rec find = function
+ | [] -> raise (NoInterpretation id)
+ | f::l ->
+ match f id args with
+ | None -> find l
+ | Some v -> v
+ in
+ find !Register.ids
+ | t -> raise (CantInterpretTerm t)
+ in
+ aux leaf [] t
+ in
+ interp leaf t
+
+let rec node ?(leaf=(fun _ -> None)) n =
+ match Nodes.Only_for_solver.open_node n with
+ | Nodes.Only_for_solver.ThTerm t -> thterm ~leaf t
+ | Nodes.Only_for_solver.Value v -> v
+
+and thterm ?(leaf=(fun _ -> None)) t =
+ match Nodes.Only_for_solver.sem_of_node t with
+ | Nodes.Only_for_solver.ThTerm (sem,v) ->
+ (** check if it is not a synterm *)
+ match Nodes.ThTermKind.Eq.eq_type sem SynTerm.key with
+ | Poly.Eq -> term ~leaf (v:Term.t)
+ | Poly.Neq ->
+ if Register.ThInterp.is_uninitialized Register.thterms sem
+ then raise (CantInterpretThTerm t);
+ (Register.ThInterp.get Register.thterms sem) ~interp:(node ~leaf) v
+
+let model d n =
+ match Ty.H.find_opt Register.models (Nodes.Node.ty n) with
+ | None -> invalid_arg "Uninterpreted type"
+ | Some f -> f d n
+
+let () = Exn_printer.register (fun fmt exn ->
+ match exn with
+ | NoInterpretation id ->
+ Format.fprintf fmt "Can't interpret the id %a."
+ Term.Id.pp id
+ | CantInterpretTerm t ->
+ Format.fprintf fmt "Can't interpret the term %a."
+ Term.pp t
+ | CantInterpretThTerm th ->
+ Format.fprintf fmt "Can't interpret the thterm %a."
+ Nodes.ThTerm.pp th
+ | exn -> raise exn
+ )
diff --git a/src/core/interp.mli b/src/core/interp.mli
new file mode 100644
index 000000000..a56c00757
--- /dev/null
+++ b/src/core/interp.mli
@@ -0,0 +1,37 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+
+module Register: sig
+ val id: (Term.id -> Nodes.Value.t list -> Nodes.Value.t option) -> unit
+
+ val thterm: 'a Nodes.ThTermKind.t -> (interp:(Nodes.Node.t -> Nodes.Value.t) -> 'a -> Nodes.Value.t) -> unit
+
+ val model: Ty.t -> (Egraph.t -> Nodes.Node.t -> Nodes.Value.t) -> unit
+
+end
+
+type leaf = Term.t -> Nodes.Value.t option
+
+val term : ?leaf:leaf -> Term.t -> Nodes.Value.t
+val thterm : ?leaf:leaf -> Nodes.ThTerm.t -> Nodes.Value.t
+val node : ?leaf:leaf -> Nodes.Node.t -> Nodes.Value.t
+
+val model : Egraph.t -> Nodes.Node.t -> Nodes.Value.t
diff --git a/src/core/structures/domKind.ml b/src/core/structures/domKind.ml
new file mode 100644
index 000000000..92625cce8
--- /dev/null
+++ b/src/core/structures/domKind.ml
@@ -0,0 +1,67 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Nodes
+
+let debug = Debug.register_info_flag
+ ~desc:"for the domains"
+ "Egraph.dom"
+
+module Dom = Keys.Make_key(struct end)
+include Dom
+type 'a dom = 'a t
+
+module type Dom_partial = sig
+ type delayed
+ type pexp
+ type t
+
+ val merged: t option -> t option -> bool
+ val merge: delayed ->
+ pexp -> t option * Node.t -> t option * Node.t ->
+ bool ->
+ unit
+ val pp: Format.formatter -> t -> unit
+ val key: t Dom.t
+end
+
+module Make(S:sig type delayed type pexp end) = struct
+
+ module type Dom = Dom_partial with type delayed := S.delayed and type pexp := S.pexp
+
+ include Dom.Make_Registry(struct
+ type 'a data = (module Dom with type t = 'a)
+ let pp (type a) (dom: a data) =
+ let module Dom = (val dom) in
+ Dom.pp
+ let key (type a) (dom: a data) =
+ let module Dom = (val dom) in
+ Dom.key
+ end)
+
+ let register_dom = register
+ let get_dom = get
+ let print_dom = print
+
+ let print_dom_opt k fmt = function
+ | None -> Format.pp_print_string fmt "N"
+ | Some s -> print_dom k fmt s
+end
diff --git a/src/core/structures/domKind.mli b/src/core/structures/domKind.mli
new file mode 100644
index 000000000..165c3f5e1
--- /dev/null
+++ b/src/core/structures/domKind.mli
@@ -0,0 +1,55 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Nodes
+
+(** Domains *)
+
+include Keys.Key
+
+type 'a dom = 'a t
+
+(** delayed and pexp are instanciated in Egraph *)
+module type Dom_partial = sig
+ type delayed
+ type pexp
+ type t
+
+ val merged: t option -> t option -> bool
+ val merge: delayed ->
+ pexp -> t option * Node.t -> t option * Node.t ->
+ bool ->
+ unit
+ val pp: Format.formatter -> t -> unit
+ val key: t dom
+end
+
+module Make (S:sig type delayed type pexp end) : sig
+
+ module type Dom = Dom_partial with type delayed := S.delayed and type pexp := S.pexp
+
+ val register_dom: (module Dom with type t = 'a) -> unit
+ val check_is_registered : 'a dom -> unit
+ val is_well_initialized : unit -> bool
+ val get_dom : 'a dom -> (module Dom with type t = 'a)
+ val print_dom : 'a dom -> Format.formatter -> 'a -> unit
+ val print_dom_opt : 'a dom -> Format.formatter -> 'a option -> unit
+
+end
diff --git a/src/core/structures/dune b/src/core/structures/dune
new file mode 100644
index 000000000..4325fb4ac
--- /dev/null
+++ b/src/core/structures/dune
@@ -0,0 +1,12 @@
+(library
+ (name witan_core_structures)
+ (public_name witan.core.structures)
+ (synopsis
+ "core structures for witan, e.g. terms, semantic terms, values, etc")
+ (libraries containers ocamlgraph witan.stdlib witan.popop_lib str dolmen.std)
+ (preprocess
+ (pps ppx_deriving.std))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always -open
+ Containers -open Witan_stdlib -open Std)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/core/structures/nodes.ml b/src/core/structures/nodes.ml
new file mode 100644
index 000000000..361481a42
--- /dev/null
+++ b/src/core/structures/nodes.ml
@@ -0,0 +1,455 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Popop_stdlib
+
+exception BrokenInvariant of string
+exception SolveSameRepr
+exception UnwaitedEvent
+exception AlreadyDead
+exception AlreadyRedirected
+
+
+let debug_create = Debug.register_info_flag
+ ~desc:"for the core solver class creation information"
+ "index"
+
+module ThTermKind = Keys.Make_key(struct end)
+module ValueKind = Keys.Make_key(struct end)
+
+module type ThTerm = sig
+ include Popop_stdlib.Datatype
+ val key: t ThTermKind.t
+end
+
+module ThTermRegistry = ThTermKind.Make_Registry(struct
+ type 'a data = (module ThTerm with type t = 'a)
+ let pp (type a) ((module ThTerm): a data) = ThTerm.pp
+ let key (type a) ((module ThTerm): a data) = ThTerm.key
+ end)
+
+let check_thterm_registered = ThTermRegistry.check_is_registered
+let print_thterm = ThTermRegistry.print
+let get_thterm = ThTermRegistry.get
+
+module type Value = sig
+ include Popop_stdlib.Datatype
+ val key: t ValueKind.t
+end
+
+module ValueRegistry = ValueKind.Make_Registry(struct
+ type 'a data = (module Value with type t = 'a)
+ let pp (type a) ((module V): a data) = V.pp
+ let key (type a) ((module V): a data) = V.key
+ end)
+
+let check_value_registered = ValueRegistry.check_is_registered
+let print_value = ValueRegistry.print
+let get_value = ValueRegistry.get
+
+module Node = struct
+ type 'a r =
+ | ThTerm : int * Ty.t * 'a ThTermKind.t * 'a -> [`ThTerm] r
+ | Value : int * Ty.t * 'a ValueKind.t * 'a -> [`Value] r
+
+ type t' = All : _ r -> t' [@@unboxed]
+ type thterm = [`ThTerm] r
+ type nodevalue = [`Value] r
+
+ let tag: t' -> int = function
+ | All(ThTerm(tag,_,_,_)) -> tag
+ | All(Value(tag,_,_,_)) -> tag
+
+ let names = Simple_vector.create 100
+ let used_names : (* next id to use *) int DStr.H.t = DStr.H.create 100
+
+ (** remove the empty string *)
+ let () = DStr.H.add used_names "" 0
+
+ let pp fmt x =
+ Format.pp_print_char fmt '@';
+ Format.pp_print_string fmt (Simple_vector.get names (tag x))
+
+ module T = Popop_stdlib.MakeMSH(struct
+ type t = t' let tag = tag
+ let pp = pp
+ end)
+
+ include T
+
+ let next_tag, incr_tag = Util.get_counter ()
+
+ let rename node s =
+ let s = Strings.find_new_name used_names s in
+ Simple_vector.set names (tag node) s
+
+ let ty = function
+ | All(ThTerm(_,ty,_,_)) -> ty
+ | All(Value(_,ty,_,_)) -> ty
+
+ module ThTermIndex = ThTermKind.MkVector
+ (struct type ('a,_) t = 'a -> Ty.t -> thterm end)
+
+ let semindex : unit ThTermIndex.t = ThTermIndex.create 8
+
+ let thterm sem v ty : thterm =
+ ThTermRegistry.check_is_registered sem;
+ ThTermIndex.get semindex sem v ty
+
+ module ValueIndex = ValueKind.MkVector
+ (struct type ('a,'unedeed) t = 'a -> Ty.t -> nodevalue end)
+
+ let valueindex : unit ValueIndex.t = ValueIndex.create 8
+
+ let nodevalue value v ty : nodevalue =
+ ValueRegistry.check_is_registered value;
+ ValueIndex.get valueindex value v ty
+
+ let of_thterm : thterm -> t = fun t -> All t
+ let of_nodevalue : nodevalue -> t = fun t -> All t
+
+ let index_sem sem v ty = of_thterm (thterm sem v ty)
+ let index_value sem v ty = of_nodevalue (nodevalue sem v ty)
+
+end
+
+module ThTerm = struct
+ include Popop_stdlib.MakeMSH(struct
+ type t = Node.thterm
+ let tag: t -> int = function
+ | Node.ThTerm(tag,_,_,_) -> tag
+ let pp fmt : t -> unit = function
+ | Node.ThTerm(_,_,sem,v) -> print_thterm sem fmt v
+ end)
+
+ let index = Node.thterm
+ let node = Node.of_thterm
+ let ty : t -> Ty.t = function
+ | Node.ThTerm(_,ty,_,_) -> ty
+
+
+end
+
+module type RegisteredThTerm = sig
+ type s
+ val key: s ThTermKind.t
+ (** thterm *)
+ include Datatype
+
+ val index: s -> Ty.t -> t
+ (** Return a thterm from a semantical value *)
+
+ val node: t -> Node.t
+ (** Return a node from a thterm *)
+
+ val ty: t -> Ty.t
+ (** Return the type from a thterm *)
+
+ val sem: t -> s
+ (** Return the sem from a thterm *)
+
+ val thterm: t -> ThTerm.t
+ val of_thterm: ThTerm.t -> t option
+
+ val coerce_thterm: ThTerm.t -> t
+
+end
+
+
+
+module RegisterThTerm (D:ThTerm) : RegisteredThTerm with type s = D.t = struct
+
+ module HC = Hashcons.MakeTag(struct
+ open Node
+ type t = thterm
+
+ let next_tag = Node.next_tag
+ let incr_tag = Node.incr_tag
+
+ let equal: t -> t -> bool = fun a b ->
+ match a, b with
+ | ThTerm(_,tya,sema,va), ThTerm(_,tyb,semb,vb) ->
+ match ThTermKind.Eq.coerce_type sema D.key,
+ ThTermKind.Eq.coerce_type semb D.key with
+ | Poly.Eq, Poly.Eq -> Ty.equal tya tyb && D.equal va vb
+
+ let hash: t -> int = fun a ->
+ match a with
+ | ThTerm(_,tya,sema,va) ->
+ let Poly.Eq = ThTermKind.Eq.coerce_type sema D.key in
+ Hashcons.combine (Ty.hash tya) (D.hash va)
+
+ let set_tag: int -> t -> t =
+ fun tag (ThTerm(_,ty,sem,v)) -> ThTerm(tag,ty,sem,v)
+
+ let tag: t -> int = fun (ThTerm(tag,_,_,_)) -> tag
+
+ let pp fmt x =
+ Format.pp_print_char fmt '@';
+ Format.pp_print_string fmt (Simple_vector.get names (tag x))
+ end)
+
+ include HC
+
+ type s = D.t
+ let key = D.key
+
+ let tag: t -> int = function
+ | Node.ThTerm(tag,_,_,_) -> tag
+
+ let index v ty =
+ let node =
+ HC.hashcons3
+ (fun tag sem v ty -> Node.ThTerm(tag,ty,sem,v))
+ D.key v ty in
+ let i = tag node in
+ Simple_vector.inc_size (i+1) Node.names;
+ begin
+ if Simple_vector.is_uninitialized Node.names i then
+ let s = Strings.find_new_name Node.used_names ""
+ (** TODO use ThTerm.pp or Sem.print_debug *) in
+ Debug.dprintf3 debug_create "[Egraph] @[@@%s is %a@]"
+ s D.pp v;
+ Simple_vector.set Node.names i s
+ end;
+ node
+
+ let node = Node.of_thterm
+
+ let sem : t -> D.t =
+ fun (Node.ThTerm(_,_,sem,v)) ->
+ let Poly.Eq = ThTermKind.Eq.coerce_type sem D.key in v
+
+ let ty = ThTerm.ty
+
+ let thterm: t -> ThTerm.t = fun x -> x
+
+ let of_thterm: ThTerm.t -> t option = function
+ | Node.ThTerm(_,_,sem',_) as v when ThTermKind.equal sem' D.key -> Some v
+ | _ -> None
+
+ let coerce_thterm: ThTerm.t -> t =
+ fun (Node.ThTerm(_,_,sem',_) as v) -> assert (ThTermKind.equal sem' D.key); v
+
+ let () =
+ ThTermRegistry.register (module D: ThTerm with type t = D.t);
+ Node.ThTermIndex.set Node.semindex D.key index
+
+end
+
+module Value = struct
+ include Popop_stdlib.MakeMSH(struct
+ type t = Node.nodevalue
+ let tag: t -> int = function
+ | Node.Value(tag,_,_,_) -> tag
+ let pp fmt : t -> unit = function
+ | Node.Value(_,_,value,v) -> print_value value fmt v
+ end)
+
+ let index = Node.nodevalue
+ let node = Node.of_nodevalue
+ let ty : t -> Ty.t = function
+ | Node.Value(_,ty,_,_) -> ty
+
+ let value : type a. a ValueKind.t -> t -> a option =
+ fun value (Node.Value(_,_,value',v)) ->
+ match ValueKind.Eq.eq_type value value' with
+ | Poly.Neq -> None
+ | Poly.Eq -> Some v
+
+ let semantic_equal (x:t) (y:t) : [ `Uncomparable | `Equal | `Disequal ] =
+ match x, y with
+ | Node.Value(_,_,xk,_), Node.Value(_,_,yk,_) when not (ValueKind.equal xk yk) ->
+ `Uncomparable
+ | _ -> if equal x y then `Equal else `Disequal
+
+end
+
+module type RegisteredValue = sig
+ type s
+ module V : Value with type t = s
+ val key: s ValueKind.t
+ (** nodevalue *)
+ include Datatype
+
+ val index: ?basename:string -> s -> Ty.t -> t
+ (** Return a nodevalue from a valueantical value *)
+
+ val node: t -> Node.t
+ (** Return a class from a nodevalue *)
+
+ val ty: t -> Ty.t
+ (** Return the type from a nodevalue *)
+
+ val value: t -> s
+ (** Return the value from a nodevalue *)
+
+ val nodevalue: t -> Value.t
+ val of_nodevalue: Value.t -> t option
+
+ val coerce_nodevalue: Value.t -> t
+
+end
+
+
+module RegisteredValueRegistry = ValueKind.Make_Registry(struct
+ type 'a data = (module RegisteredValue with type s = 'a)
+ let pp (type a) (value: a data) =
+ let module RegisteredValue = (val value) in
+ RegisteredValue.V.pp
+ let key (type a) (value: a data) =
+ let module RegisteredValue = (val value) in
+ RegisteredValue.key
+ end)
+
+let get_registered_value = RegisteredValueRegistry.get
+
+
+module RegisterValue (D:Value) : RegisteredValue with type s = D.t = struct
+
+ module All = struct
+
+ module V = D
+ module HC = Hashcons.MakeTag(struct
+ open Node
+ type t = nodevalue
+
+ let next_tag = Node.next_tag
+ let incr_tag = Node.incr_tag
+
+ let equal: t -> t -> bool = fun a b ->
+ match a, b with
+ | Value(_,tya,valuea,va), Value(_,tyb,valueb,vb) ->
+ match ValueKind.Eq.coerce_type valuea D.key,
+ ValueKind.Eq.coerce_type valueb D.key with
+ | Poly.Eq, Poly.Eq -> Ty.equal tya tyb && D.equal va vb
+
+ let hash: t -> int = fun a ->
+ match a with
+ | Value(_,tya,valuea,va) ->
+ let Poly.Eq = ValueKind.Eq.coerce_type valuea D.key in
+ Hashcons.combine (Ty.hash tya) (D.hash va)
+
+ let set_tag: int -> t -> t = fun tag x ->
+ match x with
+ | Value(_,ty,value,v) -> Value(tag,ty,value,v)
+
+ let tag: t -> int = function
+ | Value(tag,_,_,_) -> tag
+
+ let pp fmt x =
+ Format.pp_print_char fmt '@';
+ Format.pp_print_string fmt (Simple_vector.get names (tag x))
+ end)
+
+ include HC
+
+ type s = D.t
+ let key = D.key
+
+ let tag: t -> int = function
+ | Node.Value(tag,_,_,_) -> tag
+
+ let index ?(basename="") v ty =
+ let node =
+ HC.hashcons3
+ (fun tag value v ty -> Node.Value(tag,ty,value,v))
+ D.key v ty in
+ let i = tag node in
+ Simple_vector.inc_size (i+1) Node.names;
+ begin
+ if Simple_vector.is_uninitialized Node.names i then
+ let s = Strings.find_new_name Node.used_names basename in
+ Debug.dprintf3 debug_create "[Egraph] @[@@%s is %a@]"
+ s D.pp v;
+ Simple_vector.set Node.names i s
+ end;
+ node
+
+ let node = Node.of_nodevalue
+
+ let value : t -> D.t = function
+ | Node.Value(_,_,value,v) ->
+ let Poly.Eq = ValueKind.Eq.coerce_type value D.key in v
+
+ let ty = Value.ty
+
+ let nodevalue: t -> Value.t = fun x -> x
+
+ let of_nodevalue: Value.t -> t option = function
+ | Node.Value(_,_,value',_) as v when ValueKind.equal value' D.key -> Some v
+ | _ -> None
+
+ let coerce_nodevalue: Value.t -> t = function
+ | Node.Value(_,_,value',_) as v -> assert (ValueKind.equal value' D.key); v
+
+ end
+
+ include All
+ let () =
+ ValueRegistry.register (module D: Value with type t = D.t);
+ RegisteredValueRegistry.register (module All: RegisteredValue with type s = D.t);
+ Node.ValueIndex.set Node.valueindex D.key (fun v ty -> index v ty)
+
+end
+
+module Only_for_solver = struct
+ type sem_of_node =
+ | ThTerm: 'a ThTermKind.t * 'a -> sem_of_node
+
+ let thterm: Node.t -> ThTerm.t option = function
+ | Node.All Node.Value _ -> None
+ | Node.All (Node.ThTerm _ as x) -> Some x
+
+ let sem_of_node: ThTerm.t -> sem_of_node = function
+ | Node.ThTerm (_,_,sem,v) -> ThTerm(sem,v)
+
+ type value_of_node =
+ | Value: 'a ValueKind.t * 'a -> value_of_node
+
+ let nodevalue: Node.t -> Value.t option = function
+ | Node.All Node.ThTerm _ -> None
+ | Node.All (Node.Value _ as x) -> Some x
+
+ let value_of_node: Value.t -> value_of_node = function
+ | Node.Value (_,_,value,v) -> Value(value,v)
+
+ let node_of_thterm : ThTerm.t -> Node.t = ThTerm.node
+ let node_of_nodevalue : Value.t -> Node.t = Value.node
+
+ type opened_node =
+ | ThTerm : ThTerm.t -> opened_node
+ | Value : Value.t -> opened_node
+
+ let open_node : Node.t -> opened_node = function
+ | Node.All (Node.ThTerm _ as x) -> ThTerm x
+ | Node.All (Node.Value _ as x) -> Value x
+
+ let is_value : Node.t -> bool = function
+ | Node.All(Node.ThTerm _) -> false
+ | Node.All(Node.Value _) -> true
+
+end
+
+
+let check_initialization () =
+ ThTermRegistry.is_well_initialized () &&
+ ValueRegistry.is_well_initialized ()
diff --git a/src/core/structures/nodes.mli b/src/core/structures/nodes.mli
new file mode 100644
index 000000000..f906f88ce
--- /dev/null
+++ b/src/core/structures/nodes.mli
@@ -0,0 +1,234 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Define the Node, and the related types semantic terms and value *)
+
+open Witan_popop_lib
+open Popop_stdlib
+
+(** {2 General exceptions (to move away) } *)
+
+exception BrokenInvariant of string
+exception SolveSameRepr
+exception UnwaitedEvent
+exception AlreadyDead
+exception AlreadyRedirected
+
+
+module ThTermKind: Keys.Key
+module ValueKind: Keys.Key
+
+(** Node *)
+
+module Node : sig
+ include Datatype
+
+ val rename: t -> string -> unit
+ (** Change the pretty printed string for this node, to use with care
+ preferably at the start *)
+
+ val ty: t -> Ty.t
+ (** Return the type of a node *)
+
+ val index_sem: 'a ThTermKind.t -> 'a -> Ty.t -> t
+ (** Return the corresponding node from a theory term *)
+
+ val index_value: 'a ValueKind.t -> 'a -> Ty.t -> t
+ (** Return the corresponding node from a value *)
+end
+
+(** {2 Theory terms } *)
+
+(** Basically a theory term type is just something with an ordering.
+ For each theory terms a unique node is associated. *)
+module type ThTerm = sig
+ include Datatype
+
+ val key: t ThTermKind.t
+end
+
+(** {3 Generic Handling of theory terms} *)
+
+val get_thterm: 'a ThTermKind.t -> (module ThTerm with type t = 'a)
+val check_thterm_registered: 'a ThTermKind.t -> unit
+val print_thterm : 'a ThTermKind.t -> 'a Format.printer
+
+module ThTerm: sig
+ include Datatype
+
+ val index: 'a ThTermKind.t -> 'a -> Ty.t -> t
+ (** Return the corresponding node from a theory term *)
+
+ val node: t -> Node.t
+ (** Returns the node associated to this theory term *)
+
+ val ty: t -> Ty.t
+ (** Returns the type of the theory term *)
+
+end
+
+(** {3 Construction of a theory terms } *)
+
+(** Result of the registration of a theory term *)
+module type RegisteredThTerm = sig
+ type s
+ (** the user given type *)
+
+ val key: s ThTermKind.t
+
+ (** thterm *)
+ include Datatype
+
+ val index: s -> Ty.t -> t
+ (** Return a theory term from the user type *)
+
+ val node: t -> Node.t
+ (** Return a class from a thterm *)
+
+ val ty: t -> Ty.t
+ (** Return the type from a thterm *)
+
+ val sem: t -> s
+ (** Return the sem from a thterm *)
+
+ val thterm: t -> ThTerm.t
+ val of_thterm: ThTerm.t -> t option
+ (** Return the user type if the ThTerm belongs to this module *)
+
+ val coerce_thterm: ThTerm.t -> t
+ (** Return the user type. Raise if the ThTerm does not belong to this
+ module *)
+
+end
+
+module RegisterThTerm (D:ThTerm) : RegisteredThTerm with type s = D.t
+
+(** {2 Values } *)
+
+(** Basically a value is just something with an ordering. For each
+ value a unique node is associated. The difference with theory
+ terms is that only one value of a kind can be in an equivalence
+ class. The solver keep track of which value is associated to an
+ equivalence class (like it does for domains) *)
+module type Value = sig
+ include Datatype
+
+ val key: t ValueKind.t
+end
+
+val print_value : 'a ValueKind.t -> 'a Format.printer
+val get_value: 'a ValueKind.t -> (module Value with type t = 'a)
+val check_value_registered: 'a ValueKind.t -> unit
+
+(** {3 Module for handling generically values} *)
+
+module Value: sig
+ include Datatype
+
+ val index: 'a ValueKind.t -> 'a -> Ty.t -> t
+ (** Return the corresponding node from a value *)
+
+ val node: t -> Node.t
+
+ val ty: t -> Ty.t
+
+ val value: 'a ValueKind.t -> t -> 'a option
+
+ val semantic_equal: t -> t -> [ `Uncomparable | `Equal | `Disequal ]
+ (** Test semantic equality of comparable value (same value kind) *)
+end
+
+(** {3 For building a particular value} *)
+
+module type RegisteredValue = sig
+ type s
+ module V : Value with type t = s
+ val key: s ValueKind.t
+
+ (** nodevalue *)
+ include Datatype
+
+ val index: ?basename:string -> s -> Ty.t -> t
+ (** Return a nodevalue from a valueantical term.
+ Basename is used only for debug
+ *)
+
+ val node: t -> Node.t
+ (** Return a class from a nodevalue *)
+
+ val ty: t -> Ty.t
+ (** Return the type from a nodevalue *)
+
+ val value: t -> s
+ (** Return the value from a nodevalue *)
+
+ val nodevalue: t -> Value.t
+ val of_nodevalue: Value.t -> t option
+
+ val coerce_nodevalue: Value.t -> t
+
+end
+
+module RegisterValue (D:Value) : RegisteredValue with type s = D.t
+
+val get_registered_value: 'a ValueKind.t -> (module RegisteredValue with type s = 'a)
+
+val check_initialization: unit -> bool
+(** Check if the initialization of all the sem and value have been done *)
+
+(** {2 Only for the solver } *)
+module Only_for_solver: sig
+ type sem_of_node =
+ | ThTerm: 'a ThTermKind.t * 'a -> sem_of_node
+
+ val thterm:
+ Node.t -> ThTerm.t option
+ (** give the sem associated with a node, make sense only for not merged
+ class. So only the module solver can use it *)
+
+ val sem_of_node:
+ ThTerm.t -> sem_of_node
+ (** give the sem associated with a node, make sense only for not merged
+ class. So only the module solver can use it *)
+
+ type value_of_node =
+ | Value: 'a ValueKind.t * 'a -> value_of_node
+
+ val nodevalue:
+ Node.t -> Value.t option
+ (** give the value associated with a node, make sense only for not merged
+ class. So only the module solver can use it *)
+
+ val value_of_node:
+ Value.t -> value_of_node
+ (** give the value associated with a node, make sense only for not merged
+ class. So only the module solver can use it *)
+
+ val node_of_thterm: ThTerm.t -> Node.t
+ val node_of_nodevalue: Value.t -> Node.t
+
+ type opened_node =
+ | ThTerm : ThTerm.t -> opened_node
+ | Value : Value.t -> opened_node
+
+ val open_node: Node.t -> opened_node
+ val is_value: Node.t -> bool
+
+end
diff --git a/src/popop.ml b/src/core/structures/term.ml
similarity index 58%
rename from src/popop.ml
rename to src/core/structures/term.ml
index 44f790b3f..8755f3615 100644
--- a/src/popop.ml
+++ b/src/core/structures/term.ml
@@ -1,23 +1,21 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
-module Types = Popop_types
+type id = unit
diff --git a/src/core/structures/ty.ml b/src/core/structures/ty.ml
new file mode 100644
index 000000000..54a99f843
--- /dev/null
+++ b/src/core/structures/ty.ml
@@ -0,0 +1,33 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+type ty = Dolmen_std.Expr.ty
+
+include Dolmen_std.Expr.Ty
+
+let pp = Dolmen_std.Expr.Ty.print
+
+include Witan_popop_lib.Popop_stdlib.MkDatatype(struct
+ type nonrec t = t
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let pp = pp
+ end)
diff --git a/src/inputlang/dimacs_cnf/dimacs.mli b/src/core/structures/ty.mli
similarity index 57%
rename from src/inputlang/dimacs_cnf/dimacs.mli
rename to src/core/structures/ty.mli
index 01e191b38..87ff9fe6e 100644
--- a/src/inputlang/dimacs_cnf/dimacs.mli
+++ b/src/core/structures/ty.mli
@@ -1,27 +1,32 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
-type answer =
-| Sat
-| Unsat
+open Witan_popop_lib
+open Popop_stdlib
-val check_file : string -> answer
+(** {2 Types} *)
+
+type ty = Dolmen_std.Expr.ty
+
+include Datatype with type t = ty
+(** types *)
+
+(* val app: Constr.t -> ty IArray.t -> ty *)
+(* val ctr: Constr.t -> ty *)
diff --git a/src/core/theory.ml b/src/core/theory.ml
new file mode 100644
index 000000000..add74dd0a
--- /dev/null
+++ b/src/core/theory.ml
@@ -0,0 +1,24 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+module type S = sig
+
+
+end
diff --git a/src/core/trail.ml b/src/core/trail.ml
new file mode 100644
index 000000000..36fafe02f
--- /dev/null
+++ b/src/core/trail.ml
@@ -0,0 +1,32 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** explanation are removed from Colibrics *)
+module Pexp = Witan_popop_lib.Popop_stdlib.DUnit
+module Exp = struct
+ type 'a t = unit
+ include (Witan_popop_lib.Popop_stdlib.DUnit : Witan_popop_lib.Popop_stdlib.Datatype with type t := unit)
+end
+module Chogen = Witan_popop_lib.Popop_stdlib.DUnit
+type chogen = Chogen.t
+module Age = Witan_popop_lib.Popop_stdlib.DUnit
+type age = Age.t
+type t = unit
+type dec = unit
diff --git a/src/core/witan_core.ml b/src/core/witan_core.ml
new file mode 100644
index 000000000..77ead76da
--- /dev/null
+++ b/src/core/witan_core.ml
@@ -0,0 +1,95 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Witan core: define basic types and the solver *)
+
+module Id = Id
+module Term = Term
+module Ty = Ty
+
+module Keys = Keys
+
+module Node = struct
+ include Nodes.Node
+end
+
+module ThTermKind = struct
+ include Nodes.ThTermKind
+ let print = Nodes.print_thterm
+
+ module type ThTerm = Nodes.ThTerm
+ module type Registered = Nodes.RegisteredThTerm
+
+ module Register = Nodes.RegisterThTerm
+end
+
+module ThTerm = Nodes.ThTerm
+
+module SynTerm = SynTerm
+
+module ValueKind = struct
+ include Nodes.ValueKind
+ let print = Nodes.print_value
+
+ module type Value = Nodes.Value
+ module type Registered = Nodes.RegisteredValue
+
+ module Register = Nodes.RegisterValue
+
+ let get = Nodes.get_value
+ let get_registered = Nodes.get_registered_value
+end
+
+module Value = Nodes.Value
+
+module Interp = Interp
+
+module DomKind = struct
+ include DomKind
+ let print = Egraph.print_dom
+
+ module type Dom = Egraph.Dom
+
+ let register = Egraph.register_dom
+end
+
+module Dem = struct
+ include Events.Dem
+
+ module type Dem = Egraph.Wait.Dem
+
+ let register = Egraph.Wait.register_dem
+end
+
+module Env = Env
+
+module Exp = Trail.Exp
+
+module Egraph = Egraph
+module Trail = Trail
+
+module Events = Events
+module Demon = Demon
+
+module Conflict = Conflict
+
+exception UnwaitedEvent = Nodes.UnwaitedEvent
+(** Can be raised by daemon when receiving an event that they don't
+ waited for. It is the sign of a bug in the core solver *)
diff --git a/src/demon.ml b/src/demon.ml
deleted file mode 100644
index 94f0d7b86..000000000
--- a/src/demon.ml
+++ /dev/null
@@ -1,464 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
-
-let debug = Debug.register_info_flag
- ~desc:"for the specialized demons"
- "Demon.all"
-
-
-module Create = struct
- type 'b event =
- | EventDom : Cl.t * 'a dom * 'b -> 'b event
- | EventRegCl : Cl.t * 'b -> 'b event
- | EventChange : Cl.t * 'b -> 'b event
- | EventRegSem : 'a sem * 'b -> 'b event
-
-
- let print fmt = function
- | EventDom (cl, dom, _) ->
- Format.fprintf fmt "dom:%a of %a" Dom.print dom Cl.print cl
- | EventRegCl (cl, _) ->
- Format.fprintf fmt "registration of %a" Cl.print cl
- | EventChange (cl, _) ->
- Format.fprintf fmt "changecl of %a" Cl.print cl
- | EventRegSem (sem, _) ->
- Format.fprintf fmt "regsem for %a" Sem.print sem
-
-
- type 'b t = 'b event list
-end
-
-type 'k alive =
-| AliveReattached
-| AliveStopped
-| AliveRedirected of 'k
-
-module Key = struct
-
- type ('d,'k,'i) daemon_state =
- | Alive of 'd Solver.Events.Fired.t * 'i
- | Dead
- | Redirected of 'k
-
- let print_daemon_state fmt = function
- | Alive _ -> Format.fprintf fmt "alive"
- | Dead -> Format.fprintf fmt "dead"
- | Redirected _ -> Format.fprintf fmt "redirected"
-
- module type DemTable = sig
- module Key: Stdlib.Datatype
- type data
- type info val default: info
- val state : (data, Key.t, info) daemon_state Key.M.t
- end
-
- type ('k,'d,'i) demtable =
- (module DemTable with type Key.t = 'k and type data = 'd
- and type info = 'i)
-
- type ('k,'d,'i) t = {
- dk_id : ('k * 'd, 'k) Types.dem;
- dk_data : ('k,'d,'i) demtable Types.env;
- }
-
- let create name = {
- dk_id = Dem.create_key name;
- dk_data = Env.create_key name;
- }
-
- module type S = sig
- module Key: Stdlib.Datatype
-
- module Data: Stdlib.Printable
-
- type info
- val default: info
-
- val key: (Key.t, Data.t, info) t
-
- val immediate: bool
- val wakeup:
- Solver.Delayed.t -> Key.t -> Data.t Solver.Events.Fired.t ->
- info -> Key.t alive
- (** the Events.t in wakeup is a subset of the one given in watch *)
- end
-
- (** mark it attached if it is not already the case *)
- let mark_dem :
- type k d i. Solver.Delayed.t -> (k,d,i) t -> k -> unit =
- fun d dem k ->
- try
- let module DemTable = (val (Solver.Delayed.get_env d dem.dk_data)) in
- let module DemTable' = struct
- include DemTable
- let state = DemTable.Key.M.change (function
- | None -> Some (Alive([],DemTable.default))
- | Some Dead -> raise AlreadyDead
- | Some (Redirected _) -> raise AlreadyRedirected
- | Some (Alive _) -> raise Exit)
- k DemTable.state
- end in
- Solver.Delayed.set_env d dem.dk_data (module DemTable')
- with Exit -> ()
-
- module Register(D:S) = struct
-
- let rec run d k =
- let module DemTable = (val (Solver.Delayed.get_env d D.key.dk_data)) in
- match DemTable.Key.M.find k (DemTable.state) with
- | Dead ->
- Debug.dprintf4 debug "[Demon] @[Daemon %a for %a is dead@]@\n"
- Dem.print D.key.dk_id DemTable.Key.print k;
- None
- | Redirected k' ->
- Debug.dprintf6 debug
- "[Demon] @[Daemon %a for %a is redirected to %a@]@\n"
- Dem.print D.key.dk_id DemTable.Key.print
- k DemTable.Key.print k';
- run d k'
- | Alive (events,info) ->
- Debug.dprintf6 debug "[Demon] @[Run daemon %a for %a:@\n@[%a@]@]@\n"
- Dem.print D.key.dk_id DemTable.Key.print k
- (Pp.print_list Pp.newline Solver.Events.Fired.print) events;
- (** event can be added during wakeup *)
- let module DemTable' = struct
- include DemTable
- let state = DemTable.Key.M.add k (Alive([],info)) (DemTable.state)
- end
- in
- Solver.Delayed.set_env d D.key.dk_data (module DemTable');
- (** wakeup *)
- let alive = D.wakeup d k events info in
- (** delayed can be modified *)
- begin match alive with
- | AliveStopped | AliveRedirected _ ->
- let demstate = match alive with
- | AliveStopped -> Dead
- | AliveRedirected k' -> mark_dem d D.key k'; Redirected k'
- | AliveReattached -> assert false in
- Debug.dprintf4 debug "[Demon] @[Stop daemon %a %a@]@\n"
- Dem.print D.key.dk_id DemTable.Key.print k;
- begin
- let module DemTable =
- (val (Solver.Delayed.get_env d D.key.dk_data)) in
- (** Dead even if event have been added *)
- let state' = DemTable.Key.M.add k demstate (DemTable.state) in
- let module DemTable' = struct
- include DemTable
- let state = state'
- end
- in
- Solver.Delayed.set_env d D.key.dk_data (module DemTable')
- end
- | AliveReattached ->
- Debug.dprintf0 debug "[Demon] @[Reattach daemon@]@\n";
- end;
- None
-
- let enqueue d event =
- let module DemTable = (val (Solver.Ro.get_env d D.key.dk_data)) in
- let change_state k l =
- Debug.dprintf6 debug
- "[Demon] @[schedule %a for %a with %a@]@\n"
- Dem.print D.key.dk_id D.Key.print k
- Solver.Events.Fired.print event;
- let module DemTable' = struct
- include DemTable
- let state = DemTable.Key.M.add k l DemTable.state
- end in
- Solver.Ro.set_env d D.key.dk_data (module DemTable')
- in
- let rec update_state k data =
- match DemTable.Key.M.find_opt k DemTable.state with
- | None -> assert false (* should have been marked *)
- | Some Dead ->
- Debug.dprintf4 debug
- "[Demon] @[Dem %a is dead for %a@]@\n"
- Dem.print D.key.dk_id Solver.Events.Fired.print event;
- Solver.EnqStopped
- | Some (Redirected k') -> update_state k' data
- | (Some Alive([],info)) ->
- change_state k (Alive([data],info));
- Solver.EnqRun k
- | Some Alive(l,info) ->
- change_state k (Alive(data::l,info));
- Solver.EnqAlready
- in
- let k, event =
- let open Solver.Events.Fired in
- match event with
- | EventDom (a, b , (k,d)) -> k, EventDom(a, b, d)
- | EventSem (a, b, c, (k,d)) -> k, EventSem(a, b, c, d)
- | EventReg (a, (k,d)) -> k, EventReg(a, d)
- | EventRegCl (a, (k,d)) -> k, EventRegCl(a, d)
- | EventChange (a, (k,d)) -> k, EventChange(a, d)
- | EventRegSem (a, (k,d)) -> k, EventRegSem(a, d) in
- update_state k event
-
-
- let () =
- let print_demtable fmt (d: (D.Key.t,D.Data.t,D.info) demtable) =
- let module DT = (val d) in
- Pp.print_iter2 DT.Key.M.iter Pp.newline Pp.colon
- D.Key.print print_daemon_state fmt DT.state
- in
- Solver.register_env print_demtable D.key.dk_data;
- (** Interface for generic daemon *)
- let module Dem = struct
- type runable = D.Key.t
- let print_runable = D.Key.print
- let run = run
-
- type event = D.Key.t * D.Data.t
- let print_event fmt (k,d) =
- Format.fprintf fmt "(%a: %a)" D.Key.print k D.Data.print d
- let enqueue = enqueue
-
- let key = D.key.dk_id
- let immediate = D.immediate
- end in
- let module RDem = Solver.RegisterDem(Dem) in
- ()
-
- let init d =
- let module DemTable = struct
- module Key = D.Key
- type data = D.Data.t
- type info = D.info let default = D.default
- let state = Key.M.empty
- end in
- Solver.Delayed.set_env d D.key.dk_data (module DemTable);
-
- end
-
- let attach :
- type k d i. Solver.Delayed.t -> (k,d,i) t -> k -> d Create.t -> unit =
- fun t dem k events ->
- mark_dem t dem k;
- (** record waiters *)
- let iter ev =
- Debug.dprintf2 debug "[Demon] @[Attach event %a@]@\n"
- Create.print ev;
- match ev with
- | Create.EventDom (cl,dom,data) ->
- Solver.Delayed.attach_dom t cl dom dem.dk_id (k,data)
- | Create.EventChange (cl,data) ->
- Solver.Delayed.attach_cl t cl dem.dk_id (k,data)
- | Create.EventRegCl (cl,data) ->
- Solver.Delayed.attach_reg_cl t cl dem.dk_id (k,data)
- | Create.EventRegSem (sem,data) ->
- Solver.Delayed.attach_reg_sem t sem dem.dk_id (k,data)
- in
- List.iter iter events
-
-
- type ('k,'i) state =
- | SUnborn
- | SAlive of 'i
- | SDead
- | SRedirected of 'k
-
- let is_attached (type k) (type d) (type i) t (dem: (k,d,i) t) (k:k) =
- let module DemTable = (val (Solver.Delayed.get_env t dem.dk_data)) in
- match DemTable.Key.M.find_opt k DemTable.state with
- | None -> SUnborn
- | Some (Alive(_,i)) -> SAlive i
- | Some Dead -> SDead
- | Some (Redirected k') -> SRedirected k'
-
- exception NotAlive
-
- let set_info (type k) (type d) (type i) t (dem: (k,d,i) t) (k:k) (i:i) =
- let module DemTable = (val (Solver.Delayed.get_env t dem.dk_data)) in
- match DemTable.Key.M.find_exn NotAlive k DemTable.state with
- | Alive(w,_) ->
- let module DemTable' = struct
- include DemTable
- let state = DemTable.Key.M.add k (Alive(w,i)) DemTable.state
- end
- in
- Solver.Delayed.set_env t dem.dk_data (module DemTable')
- | _ -> raise NotAlive
-
-
- exception CantBeKilled
-
- let kill (type k) (type d) (type i) t (dem: (k,d,i) t) (k:k) =
- try
- let module DemTable = (val (Solver.Delayed.get_env t dem.dk_data)) in
- Debug.dprintf4 debug "[Demon] @[Kill dem %a %a@]@\n"
- Dem.print dem.dk_id DemTable.Key.print k;
- let module DemTable' = struct
- include DemTable
- let state = DemTable.Key.M.change (function
- | Some Dead -> raise Exit
- | _ -> Some Dead)
- k DemTable.state
- end in
- Solver.Delayed.set_env t dem.dk_data (module DemTable')
- with Exit -> ()
-
-end
-
-module Fast = struct
-
- type 'd t = {
- dk_id : ('d, unit) Types.dem;
- dk_data : 'd Solver.Events.Fired.event list Types.env;
- (** for throttling *)
- mutable dk_remaining: int; (** 0 if the demon is not the current one *)
- dk_current : 'd Solver.Events.Fired.event Queue.t; (** empty if idem *)
- }
-
- let create name = {
- dk_id = Dem.create_key name;
- dk_data = Env.create_key name;
- dk_remaining = 0;
- dk_current = Queue.create ();
- }
-
- module type S = sig
-
- module Data: sig
- type t
- val print: t Pp.printer
- end
-
- val key: Data.t t
-
- (** never killed *)
- val immediate: bool
- val throttle: int (** todo int ref? *)
- (** number of time run in a row *)
- val wakeup: Solver.Delayed.t -> Data.t Solver.Events.Fired.event -> unit
-
- end
-
-
- module Register(D:S) = struct
-
- let run d () =
- assert (D.key.dk_remaining == 0);
- assert (Queue.is_empty D.key.dk_current);
- let rec last_rev q n = function
- | [] -> [],n
- | a::l ->
- let rem,n = last_rev q n l in
- if n > 0 then begin
- assert (rem == []);
- Queue.add a q;
- rem,(n-1)
- end
- else a::rem, n in
- let events = Solver.Delayed.get_env d D.key.dk_data in
- let events,n = last_rev D.key.dk_current D.throttle events in
- D.key.dk_remaining <- n;
- Solver.Delayed.set_env d D.key.dk_data events;
- let new_runable = if events != [] then Some () else None in
- let rec run_one () =
- if not (Queue.is_empty D.key.dk_current) then
- let event = Queue.pop D.key.dk_current in
- Debug.dprintf6 debug
- "[Demon] @[Run daemon fast %a:@\n@[%a@ %a@]@]@\n"
- Dem.print D.key.dk_id Solver.Events.Fired.print event
- D.Data.print (Solver.Events.Fired.get_data event);
- D.wakeup d event;
- Debug.dprintf0 debug "[Demon] @[Done@]@\n";
- if not D.immediate then Solver.Delayed.flush d;
- run_one () in
- try
- run_one ();
- assert (D.key.dk_remaining >= 0);
- assert (Queue.is_empty D.key.dk_current);
- D.key.dk_remaining <- 0;
- new_runable
- with exn -> (** Normally Contradiction *)
- assert (D.key.dk_remaining >= 0);
- D.key.dk_remaining <- 0;
- Queue.clear D.key.dk_current;
- raise exn
-
- let enqueue d event =
- assert (D.key.dk_remaining >= 0);
- if D.key.dk_remaining = 0 then
- let events = Solver.Ro.get_env d D.key.dk_data in
- Debug.dprintf4 debug
- "[Demon] @[schedule %a for %a@]@\n"
- Dem.print D.key.dk_id Solver.Events.Fired.print event;
- Solver.Ro.set_env d D.key.dk_data (event::events);
- if events = [] then Solver.EnqRun () else Solver.EnqAlready
- else begin
- Debug.dprintf4 debug
- "[Demon] @[schedule %a for %a now@]@\n"
- Dem.print D.key.dk_id Solver.Events.Fired.print event;
- Queue.add event D.key.dk_current;
- D.key.dk_remaining <- D.key.dk_remaining - 1;
- assert (D.key.dk_remaining >= 0);
- Solver.EnqAlready
- end
-
-
- let () =
- let print_demtable fmt d =
- Pp.print_list Pp.comma Solver.Events.Fired.print fmt d
- in
- Solver.register_env print_demtable D.key.dk_data;
- (** Interface for generic daemon *)
- let module Dem = struct
- type runable = unit
- let print_runable = Stdlib.DUnit.print
- let run = run
-
- type event = D.Data.t
- let print_event = D.Data.print
- let enqueue = enqueue
-
- let key = D.key.dk_id
- let immediate = D.immediate
- end in
- let module RDem = Solver.RegisterDem(Dem) in
- ()
-
- let init d =
- Solver.Delayed.set_env d D.key.dk_data [];
-
- end
-
- let attach d dem events =
- let open Create in
- List.iter (function
- | EventDom (cl,dom,data) ->
- Solver.Delayed.attach_dom d cl dom dem.dk_id data
- | EventRegCl (cl,data) ->
- Solver.Delayed.attach_reg_cl d cl dem.dk_id data
- | EventChange (cl,data) ->
- Solver.Delayed.attach_cl d cl dem.dk_id data
- | EventRegSem (sem,data) ->
- Solver.Delayed.attach_reg_sem d sem dem.dk_id data) events
-
- let fresh_with_reg_cl dem s ty data =
- Cl.fresh ~to_reg:(dem.dk_id,data) s ty
-
-end
diff --git a/src/dune b/src/dune
new file mode 100644
index 000000000..e69de29bb
diff --git a/src/equality.ml b/src/equality.ml
deleted file mode 100644
index 9311af2df..000000000
--- a/src/equality.ml
+++ /dev/null
@@ -1,1132 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Stdlib
-open Types
-open Solver
-
-let debug = Debug.register_info_flag
- ~desc:"for the equality and disequality predicate"
- "disequality"
-
-module Dis = struct
- include DInt.S
- let print fmt s =
- Format.fprintf fmt "{%a}"
- (Pp.print_iter1 DInt.S.iter Pp.semi Stdlib.DInt.print) s
-end
-
-let dom : Dis.t dom = Dom.create_key "dis"
-
-module D = struct
- type t = Dis.t
-
- let merged (b1:t option) (b2 :t option) =
- match b1,b2 with
- | Some b1, Some b2 -> b1 == b2 (** not Dis.equality *)
- | None, None -> true
- | _ -> false
-
- type expmerge =
- | Merge of Explanation.pexp * Cl.t * Cl.t * int
-
- let expmerge : expmerge Explanation.exp =
- Explanation.Exp.create_key "Equality.merge"
-
- let merge d pexp (s1,cl1) (s2,cl2) _ =
- match s1, s2 with
- | None, None -> raise Impossible
- | Some s, None ->
- Delayed.set_dom_premerge d dom cl2 s
- | None, Some s ->
- Delayed.set_dom_premerge d dom cl1 s
- | Some s1, Some s2 ->
- let s = DInt.M.union (fun i () ->
- let pexp = Delayed.mk_pexp d expmerge (Merge(pexp,cl1,cl2,i)) in
- Delayed.contradiction d pexp) s1 s2 in
- Delayed.set_dom_premerge d dom cl1 s;
- Delayed.set_dom_premerge d dom cl2 s
-
-
- let print fmt s = Dis.print fmt s
- let key = dom
-end
-
-module DE = RegisterDom(D)
-
-let set_dom d pexp cl s =
- let s = match Delayed.get_dom d dom cl with
- | Some s' ->
- DInt.M.union (fun _i () -> assert false) s' s
- | None -> s in
- Delayed.set_dom d pexp dom cl s
-
-
-type t = Cl.S.t
-
-
-let sem : t sem = Sem.create_key "Eq"
-
-module Th = struct
-
- let get_ty v = Cl.ty (fst (Cl.M.choose v))
-
- let inv s = not (Cl.M.is_empty s || Cl.M.is_num_elt 1 s) &&
- let ty = get_ty s in
- (Cl.M.for_all (fun e _ -> Ty.equal ty (Cl.ty e)) s)
-
- let only_two s =
- assert (inv s);
- if Cl.M.is_num_elt 2 s then
- let enum = Cl.M.start_enum s in
- let (cl1,()), enum = Opt.get (Cl.M.val_enum enum), Cl.M.next_enum enum in
- let (cl2,()) = Opt.get (Cl.M.val_enum enum) in
- Some (cl1,cl2)
- else None
-
-
- module T = struct
- include Cl.S
-
- let hash s = Cl.S.fold (fun e acc -> Hashcons.combine acc (Cl.hash e)) s 29
-
- let print fmt s =
- assert (inv s);
- match only_two s with
- | Some (cl1,cl2) ->
- Format.fprintf fmt "%a=@,%a" Cl.print cl1 Cl.print cl2
- | None ->
- Format.fprintf fmt "or=(%a)"
- (Pp.print_iter1 Cl.S.iter Pp.comma Cl.print) s
- end
-
- include MkDatatype(T)
-
- let key = sem
-
-
-
- (* let propagate ~propagate s = Cl.S.iter propagate s *)
-
-end
-
-module ThE = RegisterSem(Th)
-
-let check_sem v cl =
- let own = ThE.cl (ThE.index v Bool.ty) in
- Cl.equal cl own
-
-(** API *)
-
-let equality cll =
- try
- let fold acc e = Cl.S.add_new Exit e acc in
- let s = List.fold_left fold Cl.S.empty cll in
- Cl.index sem s Bool.ty
- with Exit ->
- Bool._true
-
-let disequality cll = Bool._not (equality cll)
-
-let is_equal t cl1 cl2 = Delayed.is_equal t cl1 cl2
-let is_disequal t cl1 cl2 =
- not (Delayed.is_equal t cl1 cl2) &&
- let dom1 = Delayed.get_dom t dom cl1 in
- let dom2 = Delayed.get_dom t dom cl2 in
- match dom1, dom2 with
- | Some s1, Some s2 -> not (Dis.disjoint s1 s2)
- | _ -> false
-
-
-
-
-let new_tag =
- let c = ref (-1) in
- fun () -> incr c;
- let c = !c in
- c, fun () -> Dis.singleton c (** each instance of this tag must not be == *)
-
-exception Found of Cl.t * Cl.t
-
-let find_not_disequal d s =
- assert (Th.inv s);
- let rec inner_loop cl1 s1 enum2 =
- match enum2, s1 with
- | [],_ -> ()
- | (cl2,None)::_,_ | (cl2,_)::_, None ->
- raise (Found (cl1,cl2))
- | (cl2,Some s2)::_, Some s1 when Dis.disjoint s1 s2 ->
- raise (Found (cl1,cl2))
- | _::enum2, _ -> inner_loop cl1 s1 enum2 in
- let rec outer_loop enum1 =
- match enum1 with
- | [] -> ()
- | (cl1,s1)::enum1 ->
- inner_loop cl1 s1 enum1;
- outer_loop enum1 in
- try
- let s = Cl.M.fold_left (fun acc cl () ->
- (cl,Delayed.get_dom d dom cl)::acc) [] s in
- outer_loop s;
- None
- with Found (cl1,cl2) ->
- Some (cl1,cl2)
-
-type expsubst =
-| SubstUpTrue of t * Cl.t (* e1 *) * Cl.t (* e2 *) * Cl.t
-| SubstUpFalse of t * Cl.t
-| SubstDownTrue of t * Cl.t
-| SubstDownFalse of t * Cl.t * int
-| SubstDownDec of Explanation.pexp * int
-| Cst
-
-let expsubst : expsubst Explanation.exp =
- Explanation.Exp.create_key "Equality.subst"
-
-let cst_i, cst_tag =
- let i,stag = new_tag () in
- i, (fun env ->
- let pexp = Delayed.mk_pexp env expsubst Cst in
- pexp, stag)
-
-let norm_set d own v =
- try
- ignore (Cl.S.fold_left (fun acc e0 ->
- let e = Delayed.find_def d e0 in
- Cl.M.add_change (fun _ -> e0)
- (fun e0 e0' -> raise (Found(e0',e0)))
- e e0 acc)
- Cl.M.empty v);
- false
- with Found (e1,e2) ->
- (** TODO remove that and choose what to do. ex: int real *)
- let pexp = Delayed.mk_pexp d expsubst (SubstUpTrue (v,e1,e2,own)) in
- Bool.set_true d pexp own;
- true
-
-(** Conflict *)
-type eqconflict =
- | Eq : Cl.t * Cl.t * bool -> eqconflict
-
-module EqConflict = struct
-
-
- module K = Stdlib.MkDatatype(struct
-
- type t = eqconflict
-
- let print_equal fmt b =
- if b
- then Format.pp_print_string fmt "=="
- else Format.pp_print_string fmt "!="
-
- let print fmt = function
- | Eq(cl1,cl2,b) ->
- Format.fprintf fmt "%a%a%a" Cl.print cl1 print_equal b Cl.print cl2
-
- let equal e1 e2 =
- match e1, e2 with
- | Eq(cla1,clb1,b1), Eq(cla2,clb2,b2) ->
- Cl.equal cla1 cla2 && Cl.equal clb1 clb2 && DBool.equal b1 b2
-
- let compare e1 e2 =
- match e1, e2 with
- | Eq(cla1,clb1,b1), Eq(cla2,clb2,b2) ->
- let c = Cl.compare cla1 cla2 in
- if c != 0 then c else
- let c = Cl.compare clb1 clb2 in
- if c != 0 then c else
- DBool.compare b1 b2
-
- let hash e1 =
- match e1 with
- | Eq(cla1,clb1,b) ->
- Hashcons.combine2 (Cl.hash cla1) (Cl.hash clb1) (DBool.hash b)
- end)
-
- include K
-
- let mk_eq cl1 cl2 b =
- if Cl.compare cl1 cl2 <= 0
- then Eq(cl1,cl2,b)
- else Eq(cl2,cl1,b)
-
-end
-
-let choequal : (EqConflict.t,unit) Explanation.cho =
- Explanation.Cho.create_key "Equal.cho"
-
-(** Default equality/disequality conflict *)
-module ConDefaultEq = struct
- open Conflict
- open EqConflict
-
- type t = EqConflict.t Bag.t
-
- let print fmt b =
- Bag.print Pp.semi EqConflict.print fmt b
-
- let key = Explanation.Con.create_key "Equality.gen"
-
- let print_eqs fmt eqs =
- Pp.print_iter1 EqConflict.S.iter Pp.semi EqConflict.print fmt eqs
-
- class finalized eqs : Conflict.finalized = object
- method print fmt = print_eqs fmt eqs
- method test d =
- let fold acc v =
- let f cl1 cl2 b =
- let return b =
- if b then raise Exit (** true *) else acc (** false *) in
- (** the negation of the constraint is evaluated *)
- if Delayed.is_equal d cl1 cl2 then return (not b)
- else if is_disequal d cl1 cl2
- then return b
- else ToDecide
- in
- match v with
- | Eq(cl1,cl2,b) ->
- f cl1 cl2 b
- in
- try
- EqConflict.S.fold_left fold False eqs
- with Exit -> True
- method decide :
- 'a. 'a Conflict.fold_decisions -> Solver.Delayed.t -> 'a -> 'a =
- fun f d acc ->
- let fold acc v =
- let return cl1 cl2 c =
- if Delayed.is_equal d cl1 cl2 || is_disequal d cl1 cl2 then acc
- else f.fold_decisions acc choequal c () in
- match v with
- | Eq(cl1,cl2,b) ->
- return cl1 cl2 (Eq(cl1,cl2,not b))
- in
- EqConflict.S.fold_left fold acc eqs
- method conflict_add _ =
- let fold acc v =
- let f cl1 cl2 b =
- let eq = equality [cl1;cl2] in
- Cl.M.add eq b acc in
- (** no find because the explication would be different *)
- match v with
- | Eq(cl1,cl2,b) ->
- f cl1 cl2 b
- in
- EqConflict.S.fold_left fold Cl.M.empty eqs
- end
-
- let finalize _ l =
- let m =
- Bag.fold_left (fun acc b ->
- Bag.fold_left (fun acc e -> EqConflict.S.add e acc) acc b)
- EqConflict.S.empty l in
- Debug.dprintf2 Conflict.print_conflicts "[Equality] @[conflict: %a@]@\n"
- print_eqs m;
- if EqConflict.S.is_empty m then None
- else Some (new finalized m)
-
- let get_con = Conflict.fold_requested (fun b1 _ b2 -> Bag.concat b1 b2)
-
- let get_cons t _age s rlist = fold_rescon_list t get_con key s rlist
-
- let same_sem t age _sem _v pexp2 _cl1 _cl2 =
- let s = Bag.empty in
- let s = get_con s t (ComputeConflict.get_pexp t pexp2 key) in
- GRequested s
-
- let propacl t age cl rcl =
- if ComputeConflict.before_first_dec t age
- then GRequested Bag.empty
- else
- let v = mk_eq cl rcl true in
- ComputeConflict.set_dec_cho t choequal v;
- GRequested(Bag.elt v)
-
-end
-
-module EConDefaultEq = Conflict.RegisterCon(ConDefaultEq)
-
-let () =
- Bool.mk_conequal := (fun t cl1 cl2 ->
- let v = EqConflict.mk_eq cl1 cl2 true in
- Conflict.ComputeConflict.set_dec_cho t choequal v;
- Conflict.GOther(ConDefaultEq.key,Bag.elt v))
-
-module ChoEquals = struct
- open Conflict
-
- module Key = Th
- module Data = struct
- type t = Cl.t * Cl.t
- let print fmt (cl1,cl2) =
- Format.fprintf fmt "(%a = %a)"
- Cl.print cl1 Cl.print cl2
- end
-
- let key = Explanation.Cho.create_key "Equals.cho"
-
- let choose_decision d v =
- let own = Cl.index sem v Bool.ty in
- Debug.dprintf4 debug "[Equality] @[dec on %a for %a@]@\n"
- Cl.print own Th.print v;
- if norm_set d own v
- then DecNo
- else
- match find_not_disequal d v with
- | None ->
- let pexp = Delayed.mk_pexp d expsubst (SubstUpFalse(v,own)) in
- Bool.set_false d pexp own;
- DecNo
- | Some (cl1,cl2) ->
- DecTodo(cl1,cl2)
-
- let make_decision d dec v (cl1,cl2) =
- Debug.dprintf6 Conflict.print_decision
- "[Equality] @[decide on merge of %a and %a in %a@]@\n"
- Cl.print cl1 Cl.print cl2 Th.print v;
- let pexp = Explanation.mk_pcho dec key v (cl1,cl2) in
- Delayed.register d cl1;
- Delayed.register d cl2;
- Delayed.merge d pexp cl1 cl2
-
-
- let analyse (type a) t (con: a Explanation.con) v (cl1,cl2) =
- ComputeConflict.set_dec_cho t key v;
- return con ConDefaultEq.key (Bag.elt (EqConflict.mk_eq cl1 cl2 true))
-
-end
-
-module EChoEquals = Conflict.RegisterCho(ChoEquals)
-
-module ChoEqual = struct
- open Conflict
-
- module Key = EqConflict
- module Data = DUnit
-
- let key = choequal
-
- let choose_decision d v =
- let f cl1 cl2 =
- if Delayed.is_equal d cl1 cl2 || is_disequal d cl1 cl2 then DecNo
- else DecTodo ()
- in
- match v with
- | Eq(cl1,cl2,_) ->
- f cl1 cl2
-
- let make_decision d dec v () =
- Debug.dprintf2 Conflict.print_decision
- "[Equality] @[decide on %a@]@\n" EqConflict.print v;
- let pexp = Explanation.mk_pcho dec key v () in
- let cl1,cl2,b (* equality *) =
- match v with
- | Eq(cl1,cl2,b) ->
- cl1,cl2, b
- in
- if b then begin
- Delayed.register d cl1;
- Delayed.register d cl2;
- Delayed.merge d pexp cl1 cl2
- end else begin
- let dis, stag = new_tag () in
- let pexp = Delayed.mk_pexp d expsubst (SubstDownDec(pexp,dis)) in
- let set_dom cl =
- Delayed.register d cl;
- set_dom d pexp cl (stag ()) in
- assert (not (Delayed.is_equal d cl1 cl2));
- set_dom cl1; set_dom cl2
- end
-
- let analyse (type a) t (con: a Explanation.con) v () =
- ComputeConflict.set_dec_cho t choequal v;
- return con ConDefaultEq.key (Bag.elt v)
-
-end
-
-module EChoEqual = Conflict.RegisterCho(ChoEqual)
-
-let norm_dom d own v =
- if norm_set d own v
- then Demon.AliveStopped
- else begin
- Debug.dprintf4 debug "[Equality] @[norm_dom %a %a@]@\n"
- Cl.print own Th.print v;
- match Bool.is d own with
- | Some false ->
- let dis, stag = new_tag () in
- let pexp =
- Delayed.mk_pexp d expsubst (SubstDownFalse(v,own,dis)) in
- Cl.S.iter (fun cl -> set_dom d pexp cl (stag ())) v;
- Demon.AliveStopped
- | Some true ->
- begin match Th.only_two v with
- | Some (cl1,cl2) ->
- let pexp = Delayed.mk_pexp d expsubst (SubstDownTrue(v,own)) in
- Delayed.merge d pexp cl1 cl2; Demon.AliveStopped
- | None ->
- match find_not_disequal d v with
- | None ->
- let pexp = Delayed.mk_pexp d expsubst
- (SubstUpFalse(v,own)) in
- Bool.true_is_false d own pexp
- | Some _ ->
- Demon.AliveStopped
- end
- | None ->
- match find_not_disequal d v with
- | None ->
- let pexp = Delayed.mk_pexp d expsubst (SubstUpFalse(v,own)) in
- Bool.set_false d pexp own;
- Demon.AliveStopped
- | Some _ -> (** they are still not proved disequal *)
- Demon.AliveReattached
- end
-
-(** Register equality/disequality exp for types *)
-
-type special_equality = {
- equality:
- Conflict.ComputeConflict.t ->
- Explanation.Age.t -> Cl.t -> Cl.t -> unit;
- disequality:
- Conflict.ComputeConflict.t -> Explanation.Age.t ->
- hyp:bool -> Cl.t -> Cl.t -> Cl.t -> Cl.t -> unit;
- merged:
- Conflict.ComputeConflict.t ->
- Explanation.Deps.t -> Explanation.Age.t ->
- Cl.t -> Cl.t ->
- Explanation.pexp ->
- Cl.t -> Cl.t -> Explanation.Deps.t;
- repr:
- Conflict.ComputeConflict.t -> Explanation.Deps.t -> Explanation.Age.t ->
- Cl.t -> Conflict.rlist ->
- Explanation.Deps.t;
- dodec: bool;
-}
-
-let expspecial_of_sort = Ty.H.create 20
-
-let register_sort ty spe =
- Ty.H.add expspecial_of_sort ty spe
-
-module GenEquality = struct
- open Explanation
- open Conflict
-
- let equality t age cl1 cl2 =
- let rlist = ComputeConflict.get_equal t age cl1 cl2 in
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "[equality] @[%a at %a@]@\n" *)
- (* Conflict.print_rlist rlist Age.print age; *)
- let b = Bag.empty in
- let b = ConDefaultEq.get_cons t age b rlist in
- ComputeConflict.unknown_con t ConDefaultEq.key b
-
- let expspecial ~dodec f con =
- let get_con = Conflict.fold_requested_deps f in
- let get_con_deps acc t rescon =
- Conflict.fold_requested_deps f acc t rescon in
- let get_cons t s r = fold_rescon_list_deps t get_con_deps con s r in
- let get_sem t deps age _ _ pexp =
- let c,deps' = ComputeConflict.get_pexp_deps t pexp con in
- let deps = Deps.concat deps deps' in
- let b,deps = get_con_deps (Bag.empty,deps) t c in
- Explanation.Deps.add_unknown_con deps ConDefaultEq.key b
- in
- { equality;
- disequality = (fun t age ~hyp cl1d cl1e cl2e cl2d ->
- equality t age cl1d cl1e;
- equality t age cl2e cl2d);
- merged = (fun t deps age cl1d cl1 pexp cl2 cl2d ->
- let rs,deps' =
- ComputeConflict.get_pexp_deps t pexp con in
- let deps = Deps.concat deps deps' in
- let accdeps = Bag.empty,deps in
- let accdeps = get_con accdeps t rs in
- let r1 = ComputeConflict.get_equal t age cl1d cl1 in
- let accdeps = get_cons t accdeps r1 in
- let r2 = ComputeConflict.get_equal t age cl2d cl2 in
- let b,deps = get_cons t accdeps r2 in
- Explanation.Deps.add_unknown_con deps ConDefaultEq.key b);
- repr = (fun t deps age _ r1 ->
- let b,deps = get_cons t (Bag.empty,deps) r1 in
- Explanation.Deps.add_unknown_con deps ConDefaultEq.key b);
- dodec;
- }
-
- let def_expspecial =
- expspecial ~dodec:true
- (fun (b1,deps) _ b2 -> Bag.concat b1 b2, deps)
- ConDefaultEq.key
-
- let find_expspecial ty =
- Ty.H.find_def expspecial_of_sort def_expspecial ty
-
- let equality t age r1 r2 ty =
- (find_expspecial ty).equality t age r1 r2
-
- let disequality t age r1d r1e r2e r2d ty =
- (find_expspecial ty).disequality t age r1d r1e r2e r2d
-
- let merged t deps age pexp cl1 rl1 cl2 rl2 ty =
- let deps0 = ComputeConflict.get_current_deps t in
- let deps = (find_expspecial ty).merged t deps age pexp cl1 rl1 cl2 rl2 in
- (** No dependencies should have been added, all of them must be in deps *)
- assert (deps0 == ComputeConflict.get_current_deps t);
- deps
-(*
- let repr t deps age cl1 rl1 ty =
- let deps0 = ComputeConflict.get_current_deps t in
- let deps = (find_expspecial ty).repr t deps age cl1 rl1 in
- assert (deps0 == ComputeConflict.get_current_deps t);
- deps
-*)
-
- let dodec ty = (find_expspecial ty).dodec
-end
-
-let register_sort_con ty ~dodec con = register_sort ty
- (GenEquality.expspecial ~dodec
- (fun (b,deps) _ x -> b,Explanation.Deps.add_unknown_con deps con x)
- con)
-
-let () = register_sort_con Bool.ty ~dodec:false Conflict.conclause
-
-(** Propagation *)
-
-module DaemonPropa = struct
- type k = Th.t
- type d = unit
- let key = Demon.Key.create "Equality.DaemonPropa"
-
- module Key = Th
- module Data = DUnit
- type info = unit let default = ()
-
- let immediate = false
- let wakeup d v _ev () =
- norm_dom d (Cl.index sem v Bool.ty) v
-
-end
-
-module RDaemonPropa = Demon.Key.Register(DaemonPropa)
-
-module DaemonInit = struct
- type k = unit
- type d = unit
- let key = Demon.Key.create "Equality.DaemonInit"
-
- module Key = DUnit
- module Data = DUnit
- type info = unit let default = ()
-
- let immediate = true
- let wakeup d () ev () =
- List.iter
- (function Events.Fired.EventRegSem(clsem,()) ->
- begin
- let clsem = ThE.coerce_clsem clsem in
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- Cl.S.iter (Delayed.register d) v;
- let r = norm_dom d own v in
- begin match r with
- | Demon.AliveReattached ->
- let events = Cl.S.fold (fun cl acc ->
- (Demon.Create.EventChange(cl,()))::
- (Demon.Create.EventDom(cl,dom,()))::acc
- ) v [] in
- let events = Demon.Create.EventDom(own,Bool.dom,())::events in
- Demon.Key.attach d DaemonPropa.key v events;
- if GenEquality.dodec (Th.get_ty v) then begin
- Debug.dprintf4 debug "[Equality] @[ask_dec on %a for %a@]@\n"
- Cl.print own Th.print v;
- Delayed.register_decision d (Explanation.GCho(ChoEquals.key,v));
- end
- | _ -> ()
- end
- end
- | _ -> raise UnwaitedEvent
- ) ev;
- Demon.AliveReattached
-
-end
-
-module RDaemonInit = Demon.Key.Register(DaemonInit)
-
-
-(** conflict *)
-module ConDis = struct
- open Conflict
-
- type e =
- | Necessary of Cl.t
- | Hideable of Cl.t
- | Unknown
-
- type t = (e * Explanation.Deps.t) DInt.M.t
-
- let key : t Explanation.con = Explanation.Con.create_key "Diff"
-
- let print_e fmt (c,_) =
- match c with
- | Necessary cl -> Format.fprintf fmt "%a,nece" Cl.print cl
- | Hideable cl -> Format.fprintf fmt "%a,hide" Cl.print cl
- | Unknown -> Format.fprintf fmt "unk"
-
- let print fmt m =
- Format.fprintf fmt "{%a}"
- (Pp.print_iter2 DInt.M.iter Pp.semi Pp.colon DInt.print
- print_e) m
-
- (** Use only on dom domain *)
-
- let same_sem _ _ _ _ _ _ _ = raise Impossible (** never used on that *)
- let finalize _ _ = raise Impossible (** never used on that *)
-
- let propacl _ _ _ = raise Impossible
- let propasem _ _ _ _ = raise Impossible
-
- let propadom : type a. ComputeConflict.t ->
- Explanation.Age.t -> a dom -> Cl.t -> a option -> t rescon =
- fun t age dom' cl dis ->
- match Dom.Eq.coerce_type dom' dom with
- | Types.Eq ->
- if ComputeConflict.before_first_dec t age
- then
- let v = Hideable cl, Explanation.Deps.empty in
- Conflict.GRequested (DInt.M.map (fun () -> v) (Opt.get dis))
- else
- let v = Necessary cl, Explanation.Deps.empty in
- Conflict.GRequested (DInt.M.map (fun () -> v) (Opt.get dis))
-
-end
-
-module EConDis = Conflict.RegisterCon(ConDis)
-
-module ExpMerge = struct
- open Explanation
- open Conflict
- open D
- type t = expmerge
-
- let print fmt = function
- | Merge (pexp,cl1,cl2,i) ->
- Format.fprintf fmt "Merge!(%a,%a,%a,%i)"
- Conflict.print_pexp pexp Cl.print cl1 Cl.print cl2 i
-
-
-(*
- let iterexp t age = function
- | Merge ((pexp,cl1,cl2), repr_cl) ->
- IterExp.need_pexp t pexp;
- IterExp.need_dom t age cl1 dom;
- IterExp.need_cl_repr t age cl2;
- Opt.iter (fun cl -> IterExp.need_dom t age cl dom) repr_cl
- | DomMerge ((pexp,cl),repr_cl) ->
- IterExp.need_pexp t pexp;
- Opt.iter (fun cl -> IterExp.need_dom t age cl dom) repr_cl;
- IterExp.need_cl_repr t age cl
-*)
-
- module Deps = Explanation.Deps
-
- let get_dom_dis t deps pexp =
- let rc, deps' = ComputeConflict.get_pexp_deps t pexp ConDis.key in
- let deps = Deps.concat deps deps' in
- match rc with
- | GRequested s when Deps.is_empty deps -> s
- | GRequested s ->
- DInt.M.map (fun (cl,deps') -> cl,Deps.concat deps' deps) s
- (** equality is the only one to play with dom except fact *)
- | GOther (con,_) ->
- (* Format.fprintf (Debug.get_debug_formatter ()) *)
- (* "[Equality] @[Impossible %a@]@\n" Explanation.Con.print con; *)
- raise Impossible
-
-
- let mk_return_eq t cl1 cl2 =
- let open ConDis in
- match cl1,cl2 with
- (** The conflict comes from a propagation bool -> equality *)
- | Unknown, Unknown |
- (** The conflict comes from a explimit dom *)
- Hideable _, Hideable _ -> true
- | Necessary cl1, Necessary cl2 ->
- let v = EqConflict.mk_eq cl1 cl2 false in
- ComputeConflict.set_dec_cho t ChoEqual.key v;
- ComputeConflict.unknown_con t ConDefaultEq.key (Bag.elt v);
- false
- (** It should come from the same propagation *)
- | _,_ -> raise Impossible
-
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con exp ->
- let open ComputeConflict in
- (** this union unify if its discons but create a disequality
- in the other case *)
- match exp with
- | Merge (pexp,cl1,cl2,i) ->
- let ty = Cl.ty cl1 in
- let mod_dom1 = ComputeConflict.get_dom t age cl1 dom in
- let mod_dom2 = ComputeConflict.get_dom t age cl2 dom in
- let find_mod l =
- let search mod_dom =
- let m = get_dom_dis t Deps.empty mod_dom.Explanation.modpexp in
- match DInt.M.find_opt i m with
- | None -> None
- | Some (cl,deps) -> Some (mod_dom,cl,deps) in
- try Lists.first search l
- with Not_found -> raise Impossible
- in
- Debug.dprintf4 debug "mod_dom1:%a , mod_dom2:%a@\n"
- (Pp.print_list Pp.semi Explanation.print_mod_dom) mod_dom1
- (Pp.print_list Pp.semi Explanation.print_mod_dom) mod_dom2;
- let (mod_dom1,cld1,deps1) = find_mod mod_dom1 in
- let (mod_dom2,cld2,deps2) = find_mod mod_dom2 in
- let deps3 = GenEquality.merged t Deps.empty age
- mod_dom1.modcl cl1 pexp cl2 mod_dom2.modcl ty in
- ComputeConflict.add_deps t
- (Explanation.Deps.concatl [deps1;deps2;deps3]);
- (** It is a contradiction *)
- ignore (mk_return_eq t cld1 cld2);
- return con conclause Cl.M.empty
-
- let expdom _ _ _ _ _ _ = raise Impossible
- (** used only for unsat *)
-
- let key = expmerge
-
-end
-
-module EExpMerge = Conflict.RegisterExp(ExpMerge)
-
-module ExpSubst = struct
- open Explanation
- open Conflict
- open ComputeConflict
-
- type t = expsubst
-
- let print fmt = function
- | SubstUpTrue (v,e1,e2,cl) -> (** two are equals *)
- Format.fprintf fmt "SubstUpTrue(%a,%a,%a,%a)"
- Th.print v Cl.print e1 Cl.print e2 Cl.print cl
- | SubstUpFalse (v,cl) ->
- Format.fprintf fmt "SubstUpFalse(%a,%a)"
- Th.print v Cl.print cl
- | SubstDownTrue (v,own) ->
- Format.fprintf fmt "SubstDownTrue(%a,%a)"
- Th.print v Cl.print own
- | SubstDownFalse (v,own,i) ->
- Format.fprintf fmt "SubstDownFalse(%a,%a,%i)"
- Th.print v Cl.print own i
- | SubstDownDec (pexp,i) ->
- Format.fprintf fmt "SubstDownFalse(%a,%i)"
- Conflict.print_pexp pexp i
- | Cst ->
- Format.fprintf fmt "Cst"
-(*
- let iterexp t age = function
- | SubstUpTrue (v,e1,e2,_) -> (** two are equals *)
- need_sem t age sem v;
- need_cl_repr t age e1;
- need_cl_repr t age e2
- | SubstUpFalse (v,_) ->
- need_sem t age sem v;
- Cl.S.iter (fun cl -> need_dom t age cl dom) v
- | SubstDownTrue (v,l,own) ->
- need_sem t age sem v;
- List.iter (fun cl -> need_cl_repr t age cl) l;
- need_dom t age own Bool.dom
- | SubstDownFalse (v,l,own,_) ->
- need_sem t age sem v;
- List.iter (fun cl -> need_cl_repr t age cl) l;
- need_dom t age own Bool.dom
- | SubstDownDec (pexp,_) ->
- need_pexp t pexp
- | Cst -> ()
-*)
-
-
- let return_diseq t age con cl1 s1 cl2 s2 ty clauses =
- let open ConDis in
- let s =
- DInt.M.inter (fun _ (moddom1,cld1,deps1) (moddom2,cld2,deps2) ->
- Some (moddom1,moddom2,cld1,cld2,Deps.concat deps1 deps2)) s1 s2 in
- assert (not (DInt.M.is_empty s));
- let _,(moddom1,moddom2,cld1,cld2,deps) = DInt.M.choose s in
- ComputeConflict.add_deps t deps;
- let hyp = ExpMerge.mk_return_eq t cld1 cld2 in
- GenEquality.disequality t age ~hyp
- moddom1.modcl cl1
- cl2 moddom2.modcl ty;
- return con conclause clauses
-
-
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con exp ->
- let return_dis (con : a con) i : a Conflict.rescon =
- match Explanation.Con.Eq.coerce_type con ConDis.key with
- | Types.Eq ->
- GRequested (DInt.M.singleton i
- (ConDis.Unknown, Explanation.Deps.empty))
- in
- match exp with
- | SubstUpTrue (v,e1,e2,_) -> (** two are equals *)
- let ty = Th.get_ty v in
- let s = Cl.M.empty in
- GenEquality.equality t age e1 e2 ty;
- return con conclause s
- | SubstUpFalse (v,_) ->
- let ty = Th.get_ty v in
- let s = Cl.M.empty in
- let l = Cl.S.fold_left
- (fun acc cl -> (cl,ComputeConflict.get_dom t age cl dom)::acc) [] v in
- begin match l with
- | []| [_] -> assert false
- | [cl1,moddom1;cl2,moddom2] ->
- Debug.dprintf4 debug "moddom1:%a , moddom2:%a@\n"
- (Pp.print_list Pp.semi Explanation.print_mod_dom) moddom1
- (Pp.print_list Pp.semi Explanation.print_mod_dom) moddom2;
- let get_dom_disl l =
- List.fold_left (fun acc moddom ->
- let s = ExpMerge.get_dom_dis t Deps.empty moddom.modpexp in
- let s = DInt.M.map (fun (cl,deps) -> (moddom,cl,deps)) s in
- let s = DInt.M.union (fun _ _ -> raise Impossible) acc s in
- s
- ) DInt.M.empty l in
- let dis1 = get_dom_disl moddom1 in
- let dis2 = get_dom_disl moddom2 in
- return_diseq t age con cl1 dis1 cl2 dis2 ty s
- | _ -> assert false (* TODO *)
- end
- | SubstDownTrue (v,own) ->
- let ty = Th.get_ty v in
- assert (check_sem v own);
- let s = Bool.get_dom t age own Cl.M.empty in
- return con conclause s
- | SubstDownFalse (v,own,i) ->
- let ty = Th.get_ty v in
- assert (check_sem v own);
- let s = Bool.get_dom t age own Cl.M.empty in
- unknown_con t conclause s;
- return_dis con i
- | SubstDownDec (pexp,i) ->
- begin match get_pexp t pexp ConDefaultEq.key with
- | GRequested v -> unknown_con t ConDefaultEq.key v
- | GOther _ -> raise Impossible
- end;
- return_dis con i
- | Cst ->
- return_dis con cst_i
-
- let expdom :
- type a b. Conflict.ComputeConflict.t ->
- Explanation.age -> b dom -> Cl.t ->
- a Explanation.con -> t -> a Conflict.rescon =
- fun t age dom' cl con exp ->
- let return_dis (con : a con) i : a Conflict.rescon =
- match Explanation.Con.Eq.coerce_type con ConDis.key with
- | Types.Eq ->
- GRequested (DInt.M.singleton i
- ((if ComputeConflict.before_first_dec t age
- then ConDis.Hideable cl
- else ConDis.Necessary cl), Explanation.Deps.empty))
- in
- match exp with
- | SubstUpTrue (v,e1,e2,_) -> (** two are equals *)
- assert (Dom.equal dom' Bool.dom);
- let s = Cl.M.singleton cl true in
- return con conclause s
- | SubstUpFalse (v,_) ->
- assert (Dom.equal dom' Bool.dom);
- let s = Cl.M.singleton cl true in
- return con conclause s
- | SubstDownTrue (v,own) ->
- raise Impossible (** propagate a merge *)
- | SubstDownFalse (_,_,i) ->
- assert (Dom.equal dom' dom);
- return_dis con i
- | SubstDownDec (pexp,i) ->
- return_dis con i
- | Cst ->
- return_dis con cst_i
-
- let key = expsubst
-
-end
-
-module EExpSubst = Conflict.RegisterExp(ExpSubst)
-
-
-(** ITE *)
-type ite = {cond: Cl.t; then_: Cl.t; else_: Cl.t}
-
-module ITE = struct
-
- module TITE = struct
- type t = ite
- let equal x y = Cl.equal x.cond y.cond &&
- Cl.equal x.then_ y.then_ &&
- Cl.equal x.else_ y.else_
- let compare x y =
- let c = Cl.compare x.cond y.cond in
- if c != 0 then c
- else let c = Cl.compare x.then_ y.then_ in
- if c != 0 then c
- else Cl.compare x.else_ y.else_
- let hash x =
- Hashcons.combine2 (Cl.hash x.cond) (Cl.hash x.then_) (Cl.hash x.else_)
-
- let print fmt x =
- Format.fprintf fmt "ite(%a,%a,%a)"
- Cl.print x.cond Cl.print x.then_ Cl.print x.else_
- end
-
- include MkDatatype(TITE)
-
- let key = Sem.create_key "ite"
-
-end
-open ITE
-
-module EITE = Types.RegisterSem(ITE)
-
-let ite cond then_ else_ =
- let ty1 = Cl.ty then_ in
- let ty2 = Cl.ty else_ in
- assert (Ty.equal ty1 ty2);
- Cl.index ITE.key { cond; then_; else_} ty1
-
-let expite : (ITE.t * bool) Explanation.exp =
- Explanation.Exp.create_key "Ite.exp"
-
-module DaemonPropaITE = struct
- type d = EITE.t
- let key = Demon.Fast.create "ITE.propa"
-
- module Data = EITE
-
- let simplify d own b v =
- let branch = if b then v.then_ else v.else_ in
- let pexp = Delayed.mk_pexp d expite (v,b) in
- Delayed.register d branch;
- Delayed.merge d pexp own branch
-
- let immediate = false
- let throttle = 100
- let wakeup d = function
- | Events.Fired.EventDom(cond,dom,clsem) ->
- assert (Dom.equal dom Bool.dom);
- let v = EITE.sem clsem in
- assert (Delayed.is_equal d cond v.cond);
- let own = EITE.cl clsem in
- begin match Bool.is d v.cond with
- | None -> assert false
- | Some b -> simplify d own b v
- end
- | _ -> raise UnwaitedEvent
-
-end
-
-module RDaemonPropaITE = Demon.Fast.Register(DaemonPropaITE)
-
-module DaemonInitITE = struct
- type d = unit
- let key = Demon.Fast.create "ITE.init"
-
- module Key = DUnit
- module Data = DUnit
-
- let immediate = false
- let throttle = 100
- let wakeup d = function
- | Events.Fired.EventRegSem(clsem,()) ->
- begin
- let clsem = EITE.coerce_clsem clsem in
- let v = EITE.sem clsem in
- let own = EITE.cl clsem in
- match Bool.is d v.cond with
- | Some b ->
- DaemonPropaITE.simplify d own b v
- | None ->
- let clsem = EITE.index v (Cl.ty own) in
- assert (Cl.equal (EITE.cl clsem) own);
- Delayed.register d v.cond;
- Delayed.register d v.then_;
- Delayed.register d v.else_;
- Delayed.register_decision d (Explanation.GCho(Bool.chobool,v.cond));
- let events = [Demon.Create.EventDom(v.cond,Bool.dom,clsem)] in
- Demon.Fast.attach d DaemonPropaITE.key events
- end
- | _ -> raise UnwaitedEvent
-
-end
-
-module RDaemonInitITE = Demon.Fast.Register(DaemonInitITE)
-
-module ExpITE = struct
- open Conflict
-
- type t = ITE.t * bool
- let key = expite
-
- let print fmt (ite,b) =
- Format.fprintf fmt "(%a,%b)" ITE.print ite b
-(*
- let iterexp t age (ite,_) =
- IterExp.need_sem t age ITE.key ite;
- IterExp.need_dom t age ite.cond Bool.dom
-*)
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con (ite,_) ->
- let s = Cl.M.empty in
- let s = Bool.get_dom t age ite.cond s in
- return con conclause s
-
- let expdom _ _ _ _ _ _ = raise Impossible (** merge *)
-
-end
-
-module EExpITE = Conflict.RegisterExp(ExpITE)
-
-let th_register env =
- RDaemonPropa.init env;
- RDaemonInit.init env;
- RDaemonPropaITE.init env;
- RDaemonInitITE.init env;
- Demon.Key.attach env
- DaemonInit.key () [Demon.Create.EventRegSem(sem,())];
- Demon.Fast.attach env
- DaemonInitITE.key [Demon.Create.EventRegSem(ITE.key,())];
- let pexp,stag = cst_tag env in
- Delayed.set_dom env pexp dom Bool._true (stag ());
- Delayed.set_dom env pexp dom Bool._false (stag ())
diff --git a/src/equality.mli b/src/equality.mli
deleted file mode 100644
index 8b5fe1133..000000000
--- a/src/equality.mli
+++ /dev/null
@@ -1,69 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Types
-
-val equality : Cl.t list -> Cl.t
-val disequality : Cl.t list -> Cl.t
-
-val is_equal : Solver.d -> Cl.t -> Cl.t -> bool
-val is_disequal : Solver.d -> Cl.t -> Cl.t -> bool
-
-val ite : Cl.t -> Cl.t -> Cl.t -> Cl.t
-
-val th_register : Solver.d -> unit
-
-open Explanation
-
-type special_equality = {
- equality:
- Conflict.ComputeConflict.t ->
- Explanation.Age.t -> Cl.t -> Cl.t -> unit;
- disequality:
- Conflict.ComputeConflict.t -> Explanation.Age.t ->
- hyp:bool -> Cl.t -> Cl.t -> Cl.t -> Cl.t -> unit;
- merged:
- Conflict.ComputeConflict.t ->
- Explanation.Deps.t -> Explanation.Age.t ->
- Cl.t -> Cl.t ->
- Explanation.pexp ->
- Cl.t -> Cl.t -> Explanation.Deps.t;
- repr:
- Conflict.ComputeConflict.t -> Explanation.Deps.t -> Explanation.Age.t ->
- Cl.t -> Conflict.rlist ->
- Explanation.Deps.t;
- dodec: bool;
-}
-
-val register_sort: Ty.t -> special_equality -> unit
-val register_sort_con: Ty.t -> dodec:bool -> 'a con -> unit
-
-module GenEquality: sig
- val equality: Conflict.ComputeConflict.t ->
- Explanation.Age.t -> Types.Cl.t -> Types.Cl.t -> Ty.t -> unit
-
-end
-
-type eqconflict =
- | Eq : Cl.t * Cl.t * bool -> eqconflict
-
-val choequal : (eqconflict, unit) Explanation.cho
diff --git a/src/explanation.ml b/src/explanation.ml
deleted file mode 100644
index e51c2e8ec..000000000
--- a/src/explanation.ml
+++ /dev/null
@@ -1,473 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Stdlib
-open Types
-
-(** The age is a position in the trail. So it is also a way to
- indicate the state. The state corresponding to an age is the state
- of the solver when the current age integer have been incremented
- into this age *)
-let debugage = Debug.register_info_flag
- ~desc:"for@ the@ age in the trail."
- "Explanation.age"
-
-let debug = Debug.register_flag (** not info just because duplicate of solver *)
- ~desc:"for@ the@ trail."
- "Explanation.core"
-
-module Exp = Popop_types.Make_key(struct end)
-module Con = Popop_types.Make_key(struct end)
-module Cho = Popop_types.Make_key2(struct end)
-
-type 'a exp = 'a Exp.k
-type 'a con = 'a Con.k
-type ('a,'b) cho = ('a,'b) Cho.k
-
-module Age = struct
- include DIntOrd
- let bef = -1
- let min = 0
- let max (x : int) y = if x < y then y else x
- let pred = Pervasives.pred
- let succ = Pervasives.succ
- let to_int x = x
-end
-type age = Age.t (* position in the trail *)
-
-module Tag = Popop_types.Make_key(struct end)
-type 'a tag = 'a Tag.k
-
-module Tags : sig
- type t
- val empty: t
- val add: t -> 'a tag -> 'a Bag.t -> t
- val find: t -> 'a tag -> 'a Bag.t
- val union: t -> t -> t
- val print: t Pp.printer
-end = struct
- type exi
- type t = exi Bag.t Tag.K.M.t
- let empty = Tag.K.M.empty
- let add : type a. t -> a tag -> a Bag.t -> t =
- fun tags tag l ->
- Tag.K.M.add ((tag : a tag) :> Tag.K.t)
- (Obj.magic (l : a Bag.t) :> exi Bag.t) tags
- let find : type a. t -> a tag -> a Bag.t =
- fun tags tag ->
- (Obj.magic (Tag.K.M.find_def Bag.empty ((tag : a tag) :> Tag.K.t)
- tags : exi Bag.t) : a Bag.t)
- let union : t -> t -> t = fun t1 t2 ->
- Tag.K.M.union (fun _ a b -> Some (Bag.concat a b)) t1 t2
- let print fmt _ = Format.pp_print_string fmt "!Tags!"
-end
-type tags = Tags.t
-
-type dec = age
-let age_of_dec x = x
-let print_dec = Age.print
-
-type 'a rescon =
-| GRequested: 'a -> 'a rescon
-| GOther: 'b con * 'b -> 'a rescon
-
-module Conunknown = Con.MkMap(struct type ('a,'b) t = 'a Bag.t end)
-type conunknown = unit Conunknown.t
-type chogen =
- | GCho: ('k,'d) cho * 'k -> chogen
-type decs = chogen list Cl.M.t Dom.M.t
-
-(** Module for manipulating explicit dependencies *)
-module Deps = struct
-
- type t =
- | Empty
- | Tags: tags * t -> t
- | Decs: chogen * t -> t
- | Cunk: 'a con * 'a * t -> t
- | Concat: t * t -> t
-
- let empty = Empty
- let is_empty = function Empty -> true | _ -> false
- let concat t1 t2 =
- (* Format.fprintf (Debug.get_debug_formatter ()) "."; *)
- match t1,t2 with
- | Empty, Empty -> Empty
- | Empty, t | t, Empty -> t
- | _ -> Concat(t2,t1)
- let concatl l = List.fold_left concat Empty l
- let add_tags t tags =
- (* Format.fprintf (Debug.get_debug_formatter ()) "$"; *)
- Tags(tags,t)
- let add_unknown_con t con a =
- (* Format.fprintf (Debug.get_debug_formatter ()) "!%a" Con.print con; *)
- Cunk(con,a,t)
- let add_chogen t chogen =
- (* Format.fprintf (Debug.get_debug_formatter ()) "*"; *)
- Decs(chogen,t)
-
- type result = {
- unknown : conunknown;
- tags : tags;
- decs : chogen Bag.t;
- }
-
- module Compute = struct
-
- let empty = {
- unknown = Conunknown.empty;
- tags = Tags.empty;
- decs = Bag.empty;
- }
-
- let _concat t1 t2 =
- let conunion _ l1 l2 =
- Some (Bag.concat l1 l2) in
- {
- tags = Tags.union t1.tags t2.tags;
- unknown = Conunknown.union {Conunknown.union = conunion}
- t1.unknown t2.unknown;
- decs = Bag.concat t1.decs t2.decs;
- }
-
- let add_tags t tags =
- {t with tags = Tags.union t.tags tags}
-
- let add_unknown_con t con a =
- { t with unknown =
- Conunknown.add_change
- Bag.elt Bag.add
- con a t.unknown
- }
-
- let add_chogen t chogen =
- { t with decs = Bag.add chogen t.decs }
-
- let empty_repr = Obj.repr Empty
-
- let rec fold acc t =
- match t with
- | Empty -> acc
- | Tags(tags,t') ->
- let acc = fold acc t' in
- Obj.set_field (Obj.repr t) 1 empty_repr;
- add_tags acc tags
- | Decs(chogen,t') ->
- let acc = fold acc t' in
- Obj.set_field (Obj.repr t) 1 empty_repr;
- add_chogen acc chogen
- | Cunk(con,a,t') ->
- let acc = fold acc t' in
- Obj.set_field (Obj.repr t) 2 empty_repr;
- add_unknown_con acc con a
- | Concat(t1,t2) ->
- let acc = fold acc t1 in
- Obj.set_field (Obj.repr t) 0 empty_repr;
- let acc = fold acc t2 in
- Obj.set_field (Obj.repr t) 1 empty_repr;
- acc
- end
-
- let compute_deps t = Compute.fold Compute.empty t
-end
-
-module Concache = struct
-
- type 'a value = 'a rescon * Deps.t
- module Cache = Con.MkVector(struct
- type ('a,'b) t = 'a value end)
-
- type t = unit Cache.t
-
- let mk () = Cache.create (Con.hint_size ())
- let set (type a) (concache:t) (con:a con) (c:a value) =
- Cache.inc_size con concache;
- Cache.set concache con c
- let get concache con = Cache.get concache con
- let is_set concache con = not (Cache.is_uninitialized concache con)
- let clear = Cache.clear
-end
-
-type concache = Concache.t
-
-type pexp =
-| Pexp: age * 'a exp * 'a * tags * concache -> pexp
-
-let print_pexp : (pexp Pp.printer) ref =
- ref (fun _ _ -> assert false)
-
-type modif =
-| Cl : Cl.t * Cl.t -> modif (** Just for taking an age *)
-| Dom: Cl.t * 'a dom * pexp * Cl.t -> modif
-| DomL: Cl.t * 'a dom * 'a option * Age.t * pexp * Cl.t -> modif
-| Dec: dec -> modif
-
-let print_modif_ref = ref (fun _ _ -> assert false)
-
-type node_clhist = {
- nage : age;
- ncl : Cl.t;
- npexp: pexp;
- ninv : bool;
-}
-
-let print_node fmt e =
- Format.fprintf fmt "M(%a,@,%a,@,%a,@,%b)"
- Age.print e.nage Cl.print e.ncl !print_pexp e.npexp e.ninv
-
-
-type clgraph = (node_clhist list) Cl.M.t (** graph *)
-type clhist = (age * Cl.t) Cl.M.t (** graph *)
-
-type mod_dom = {
- modcl : Cl.t;
- modage : Age.t;
- modpexp : pexp
-}
-
-let print_mod_dom fmt m =
- Format.fprintf fmt "{cl=%a;@,age=%a;@,pexp=%a}"
- Cl.print m.modcl Age.print m.modage !print_pexp m.modpexp
-
-type domhist_node =
- | DomNeverSet
- | DomMerge of Age.t (** agedommerge *) *
- domhist_node (** other_cl *) * domhist_node (** repr_cl **)
- | DomPreMerge of Age.t *
- Cl.t * (** cl that will be equal to it
- and from which we take the dom *)
- domhist_node * (** domhist of this cl *)
- domhist_node (** previous domhist *)
- | DomSet of mod_dom * domhist_node
-
-let rec print_domhist_node fmt = function
- | DomNeverSet -> Format.pp_print_string fmt "[]"
- | DomMerge(age,l1,l2) ->
- Format.fprintf fmt "DM(%a,%a,%a)"
- Age.print age print_domhist_node l1 print_domhist_node l2
- | DomPreMerge(age,from_cl,_,l) ->
- Format.fprintf fmt "(%a,%a,_)::%a"
- Age.print age
- Cl.print from_cl
- print_domhist_node l
- | DomSet(moddom,l) ->
- Format.fprintf fmt "%a::%a"
- print_mod_dom moddom
- print_domhist_node l
-
-type domhist = domhist_node Cl.M.t Dom.Vector.t
-
-let print_domhist fmt x =
- (Dom.Vector.print Pp.newline Pp.colon {Dom.Vector.printk = Dom.print}
- (Pp.print_iter2 Cl.M.iter Pp.semi Pp.comma Cl.print print_domhist_node))
- fmt x
-
-
-type t = {
- mutable last_dec : Age.t;
- mutable first_dec : Age.t;
- mutable nbdec : int;
- mutable age : Age.t;
- mutable trail : modif list;
- mutable clgraph : clgraph;
- mutable clhist : clhist;
- domhist : domhist;
-}
-
-
-let create () = {
- age = Age.bef;
- trail = [];
- clhist = Cl.M.empty;
- clgraph = Cl.M.empty;
- domhist = Dom.Vector.create (Dom.hint_size ());
- last_dec = Age.bef;
- first_dec = max_int;
- nbdec = 0;
-}
-
-let new_handler t = {
- age = t.age;
- trail = t.trail;
- clhist = t.clhist;
- clgraph = t.clgraph;
- domhist = Dom.Vector.copy t.domhist;
- last_dec = t.last_dec;
- first_dec = t.first_dec;
- nbdec = t.nbdec;
-}
-
-let current_age t = t.age
-let last_dec t = t.last_dec
-let nbdec t = t.nbdec
-let at_current_level t age = Age.compare t.last_dec age <= 0
-let before_first_dec t age = Age.compare t.first_dec age > 0
-let trail t = t.trail
-
-let push (* modif *) t =
- (* t.trail <- modif::t.trail; *)
- t.age <- t.age + 1; (** t.age correspong now to the state after this
- modification *)
- (* Format.fprintf (Debug.get_debug_formatter ()) "domhist:@[%a@]@\n" *)
- (* print_domhist t.domhist; *)
- Debug.dprintf2 debugage "[Trail] @[new age %a@]@\n" Age.print t.age
-
-
-let new_dec t =
- t.nbdec <- t.nbdec + 1;
- let dec = t.age + 1 in
- t.last_dec <- dec;
- if t.first_dec == max_int then t.first_dec <- dec;
- push (*Dec dec*) t;
- Debug.dprintf2 debug "[Trail] @[new dec %a@]@\n" Age.print dec;
- dec
-
-let mk_pexp t ?age ?(tags=Tags.empty) kexp exp =
- (** This modification is evaluated by default in the state of the
- last regstered modification *)
- let age = match age with
- | None -> t.age
- | Some age -> assert (Age.compare age t.age <= 0); age in
- Pexp(age,kexp,exp,tags,Concache.mk ())
-
-let mk_pexp_direct ~age ?(tags=Tags.empty) kexp exp =
- Pexp(age,kexp,exp,tags,Concache.mk ())
-
-
-let add_pexp_cl t pexp ~inv ~other_cl ~other_cl0 ~repr_cl ~repr_cl0 =
- (* let modif = Cl(other_cl0,repr_cl0) in *)
- push (* modif *) t;
- Debug.dprintf10 debug
- "[Trail] @[merge %a(%a) -> %a(%a) at %a@]@\n"
- Cl.print other_cl0 Cl.print other_cl
- Cl.print repr_cl0 Cl.print repr_cl
- Age.print t.age (* print_modif modif *);
- (** update clgraph *)
- let add_edge cl1_0 cl2_0 inv =
- t.clgraph <- Cl.M.add_change Lists.singleton Lists.add
- cl1_0 {nage = t.age; ncl = cl2_0; npexp = pexp; ninv = inv} t.clgraph in
- add_edge other_cl0 repr_cl0 inv;
- add_edge repr_cl0 other_cl0 (not inv)
-
-let add_merge_dom_no
- t ~inv:_ ~other_cl ~other_cl0 ~repr_cl ~repr_cl0 =
- push (* modif *) t;
- Debug.dprintf10 debug
- "[Trail] @[finalmerge without dom %a(%a) -> %a(%a) at %a@]@\n"
- Cl.print other_cl0 Cl.print other_cl
- Cl.print repr_cl0 Cl.print repr_cl
- Age.print t.age (* print_modif modif *);
- (** update clhist *)
- t.clhist <- Cl.M.add other_cl (t.age,repr_cl) t.clhist
-
-
-let add_merge_dom_all
- t ~inv:_ ~other_cl ~other_cl0 ~repr_cl ~repr_cl0 =
- push (* modif *) t;
- Debug.dprintf10 debug
- "[Trail] @[finalmerge with dom %a(%a) -> %a(%a) at %a@]@\n"
- Cl.print other_cl0 Cl.print other_cl
- Cl.print repr_cl0 Cl.print repr_cl
- Age.print t.age (* print_modif modif *);
- (** update clhist *)
- t.clhist <- Cl.M.add other_cl (t.age,repr_cl) t.clhist;
- (**update domhist *)
- let apply m =
- try Cl.M.add_change
- (fun (age,o) -> DomMerge(age,o,DomNeverSet))
- (fun (age,o) r -> DomMerge(age,o,r))
- repr_cl (t.age,Cl.M.find other_cl m) m
- with Not_found -> m
- in
- Dom.Vector.apply_initialized apply t.domhist
-
-let add_pexp_dom t pexp dom ~cl ~cl0 =
- if Dom.Vector.is_uninitialized t.domhist dom then
- Dom.Vector.set t.domhist dom Cl.M.empty;
- push t;
- Debug.dprintf6 debug "[Trail] @[add dom cl:%a cl0:%a %a@]@\n"
- Cl.print cl Cl.print cl0 Age.print t.age;
- let cm = Dom.Vector.get t.domhist dom in
- let append md m = DomSet(md,m) in
- let singleton md = append md DomNeverSet in
- let cm = Cl.M.add_change singleton append cl
- {modage=t.age;modpexp=pexp;modcl=cl0} cm in
- Dom.Vector.set t.domhist dom cm
-
-let add_pexp_dom_premerge t dom ~clto ~clfrom ~clfrom0 =
- if Dom.Vector.is_uninitialized t.domhist dom then
- Dom.Vector.set t.domhist dom Cl.M.empty;
- push t;
- Debug.dprintf8 debug
- "[Trail] @[add premerge to_cl:%a from_cl:%a(%a) dom %a@]@\n"
- Cl.print clto Cl.print clfrom0 Cl.print clfrom Age.print t.age;
- let cm = Dom.Vector.get t.domhist dom in
- let append (age,cl,m') m = DomPreMerge(age,cl,m',m) in
- let singleton x = append x DomNeverSet in
- let cm = Cl.M.add_change singleton append clto
- (t.age,clfrom0,Cl.M.find clfrom cm) cm in
- Dom.Vector.set t.domhist dom cm
-
-(*
- let age = Cl.M.find_def Age.bef cl (Dom.Vector.get t.dom dom) in
- if age <= t.last_dec
- then (** last modified before current level *)
- begin
- push (DomL (cl,dom,v,age,pexp,cl0)) t;
- Dom.Vector.set t.dom dom (Cl.M.add cl t.age (Dom.Vector.get t.dom dom));
- end
- else (** already modified after current level *)
- push (Dom (cl,dom,pexp,cl0)) t;
- Debug.dprintf10 debug
- "[Trail] @[change dom %a of (%a)%a at %a evaluated at %a@]@\n"
- Dom.print dom Cl.print cl0 Cl.print cl Age.print t.age !print_pexp pexp
-*)
-
-let expfact : unit exp = Exp.create_key "Explanation.fact"
-let pexpfact = Pexp(Age.bef,expfact,(),Tags.empty,Concache.mk ())
-
-type invclhist = Cl.t Age.M.t Cl.H.t
-
-let print_invclhist fmt h =
- Pp.print_iter2 Cl.H.iter Pp.newline Pp.colon Cl.print
- (Pp.print_iter2 Age.M.iter Pp.semi Pp.comma Age.print Cl.print)
- fmt h
-
-let invclhist t =
- let invclhist = Cl.H.create 100 in
- let iter cl (age,cl') =
- (* if Age.compare t.last_dec age <= 0 then *)
- let m = Cl.H.find_def invclhist Age.M.empty cl' in
- let m = Age.M.add_new Impossible age cl m in
- Cl.H.replace invclhist cl' m
- in
- Cl.M.iter iter t.clhist;
- invclhist
-
-type pcho =
- | Pcho: dec * ('k,'d) cho * 'k * 'd -> pcho
-
-let expcho = Exp.create_key "Core.expcho"
-
-let mk_pcho dec cho k d =
- mk_pexp_direct ~age:dec expcho (Pcho(dec,cho,k,d))
diff --git a/src/explanation.mli b/src/explanation.mli
deleted file mode 100644
index fac28abc3..000000000
--- a/src/explanation.mli
+++ /dev/null
@@ -1,252 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
-
-
-module Tag: Key
-type 'a tag = 'a Tag.k
-
-module Tags : sig
- type t
- val empty: t
- val add: t -> 'a tag -> 'a Bag.t -> t
- val find: t -> 'a tag -> 'a Bag.t
- val union: t -> t -> t
- val print: t Pp.printer
-end
-type tags = Tags.t
-
-
-
-module Age: sig
- include Stdlib.Datatype
- val min: t
- val max: t -> t -> t
- val pred: t -> t
- val succ: t -> t
- val to_int: t -> int
-end
-type age = Age.t
-
-
-
-module Exp: Key
-module Con: Key
-module Cho: Key2
-
-type 'a exp = 'a Exp.k
-type 'a con = 'a Con.k
-type ('k,'d) cho = ('k,'d) Cho.k
-
-type 'a rescon =
-| GRequested: 'a -> 'a rescon
-| GOther: 'b con * 'b -> 'a rescon
-
-type concache
-type pexp = private
-| Pexp: age * 'a exp * 'a * tags * concache -> pexp
-
-type dec
-
-type modif =
-| Cl : Cl.t * Cl.t -> modif
- (** Cl(cl1,cl2,pexp) explication why cl1 and cl2 are merged
- but cl1 and cl2 are perhaps not the representative of there class
- *)
-
-| Dom: Cl.t * 'a dom * pexp * Cl.t -> modif
-(** Cl(clr,dom,pexp,cl) explication why cl1 and cl2 are merged
- but clr is the representative of the equivalence class,
- cl2 can be not the representative.
-*)
-
-| DomL: Cl.t * 'a dom * 'a option * Age.t * pexp * Cl.t -> modif
-(** same as before but the first time in this level *)
-
-| Dec: dec -> modif
-(** new level decision *)
-
-type node_clhist = {
- nage : age;
- ncl : Cl.t;
- npexp: pexp;
- ninv : bool;
-}
-
-val print_node: node_clhist Pp.printer
-
-type clgraph = (node_clhist list) Cl.M.t (** graph *)
-type clhist = (age * Cl.t) Cl.M.t (** graph *)
-
-type mod_dom = {
- modcl : Cl.t;
- modage : Age.t;
- modpexp : pexp
-}
-
-val print_mod_dom: mod_dom Pp.printer
-
-type domhist_node =
- | DomNeverSet
- | DomMerge of Age.t (** agedommerge *) *
- domhist_node (** other_cl *) *
- domhist_node (** repr_cl *)
- | DomPreMerge of Age.t *
- Cl.t * (** cl that will be equal to it
- and from which we take the cl *)
- domhist_node * (** domhist of this cl *)
- domhist_node (** previous domhist *)
- | DomSet of mod_dom * domhist_node
-
-val print_domhist_node: domhist_node Pp.printer
-
-type domhist = domhist_node Cl.M.t Dom.Vector.t
-
-val print_domhist: domhist Pp.printer
-
-type t = private {
- mutable last_dec : Age.t;
- mutable first_dec : Age.t;
- mutable nbdec : int;
- mutable age : Age.t;
- mutable trail : modif list;
- mutable clgraph : clgraph;
- mutable clhist : clhist;
- domhist : domhist;
-}
-
-val create: unit -> t
-val new_handler: t -> t
-
-val current_age: t -> age
-
-val mk_pcho: dec -> ('k,'d) cho -> 'k -> 'd -> pexp
-
-val print_dec: dec Pp.printer
-val age_of_dec: dec -> age
-val new_dec: t -> dec
-
-
-val mk_pexp:
- t ->
- ?age:age (* in which age it should be evaluated *) ->
- ?tags:tags ->
- 'a exp -> 'a -> pexp
-
-
-(** TODO make the add_pexp_cl sooner
- and so cut in two it.
- *)
-val add_pexp_cl:
- t -> pexp -> inv:bool -> other_cl:Cl.t -> other_cl0:Cl.t
- -> repr_cl:Cl.t -> repr_cl0:Cl.t -> unit
-(** cl* representative, cl*_0 the one merged initially on which the
- pexp apply *)
-val add_merge_dom_no:
- t -> inv:bool -> other_cl:Cl.t -> other_cl0:Cl.t
- -> repr_cl:Cl.t -> repr_cl0:Cl.t -> unit
-
-val add_merge_dom_all:
- t -> inv:bool -> other_cl:Cl.t -> other_cl0:Cl.t
- -> repr_cl:Cl.t -> repr_cl0:Cl.t -> unit
-(** cl* representative, cl*_0 the one merged initially on which the
- pexp apply *)
-val add_pexp_dom:
- t -> pexp -> 'b dom -> cl:Cl.t -> cl0:Cl.t -> unit
-(** The value must be the old value *)
-
-
-val add_pexp_dom_premerge:
- t -> 'b dom ->
- clto:Cl.t ->
- clfrom:Cl.t ->
- clfrom0:Cl.t ->
- unit
-
-val trail: t -> modif list
-val last_dec: t -> Age.t
-val nbdec: t -> int
-val at_current_level: t -> Age.t -> bool
-val before_first_dec : t -> Age.t -> bool
-val pexpfact: pexp
-
-(** Just for Conflict *)
-module Conunknown : Intmap_hetero.S1 with
- type 'a key = 'a con and type ('a,'b) data = 'a Bag.t
-type conunknown = unit Conunknown.t
-type chogen =
- | GCho: ('k,'d) cho * 'k -> chogen
-type decs = chogen list Cl.M.t Dom.M.t
-
-val print_modif_ref : modif Pp.printer ref
-
-type invclhist = Cl.t Age.M.t Cl.H.t
-val print_invclhist: invclhist Pp.printer
-val invclhist: t -> invclhist
-
-(** Module for manipulating explicit dependencies *)
-module Deps : sig
- type t
-
- val empty: t
- val is_empty: t -> bool
- val concat: t -> t -> t
- val concatl: t list -> t
-
- val add_tags: t -> tags -> t
- val add_unknown_con: t -> 'a con -> 'a -> t
- val add_chogen: t -> chogen -> t
-
- type result = {
- unknown : conunknown;
- tags : tags;
- decs : chogen Bag.t;
- }
-
- val compute_deps: t -> result
- (** Can be done only by Conflict and only once!!! *)
-
-end
-
-module Concache : sig
- type 'a value = 'a rescon * Deps.t
- val set : concache -> 'a con -> 'a value -> unit
- val get : concache -> 'a con -> 'a value
- val is_set : concache -> 'a con -> bool
- val clear : concache -> unit
-end
-
-
-val mk_pexp_direct:
- age:age (* in which age it should be evaluated *) ->
- ?tags:tags ->
- 'a exp -> 'a -> pexp
-
-type pcho =
- | Pcho: dec * ('k,'d) cho * 'k * 'd -> pcho
-
-val expcho: pcho exp
-val expfact: unit exp
-
-val print_pexp : (pexp Pp.printer) ref
diff --git a/src/inputlang/altergo/popop_of_altergo.ml b/src/inputlang/altergo/popop_of_altergo.ml
deleted file mode 100644
index 7bddf34be..000000000
--- a/src/inputlang/altergo/popop_of_altergo.ml
+++ /dev/null
@@ -1,196 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Types
-open Stdlib
-open Why_ptree
-exception Not_supported of Loc.position
-
-exception Unbound of (Loc.position * string)
-
-
-type benv = {
- ctr : Ty.Constr.t DStr.H.t;
- term: Types.Cl.t DStr.H.t;
-}
-
-let rec sort benv = function
- | PPTreal -> Arith.real
- | PPTint -> Arith.real
- | PPTbool -> Bool.ty
- | PPTvarid (ctr,loc) ->
- let ctr = DStr.H.find_exn benv.ctr (Unbound(Loc.extract loc,ctr)) ctr in
- Ty.ctr ctr
- | PPTexternal (args,ctr,loc) ->
- let l = List.map (sort benv) args in
- let ctr = DStr.H.find_exn benv.ctr (Unbound(Loc.extract loc,ctr)) ctr in
- Ty.app ctr (IArray.of_list l)
- | _ -> raise (Not_supported Loc.dummy_position)
-
-let result_sort benv = function
- | PPredicate l -> (List.length l), Bool.ty
- | PFunction (l,result) -> (List.length l), sort benv result
-
-let bind benv s cl =
- DStr.H.add benv.term s cl
-
-let unbind benv s =
- DStr.H.remove benv.term s
-
-let rec append_op env benv opc t acc =
- match t.pp_desc with
- | PPinfix (t1,op,t2) when op = opc ->
- let l = append_op env benv opc t1 acc in
- let l = append_op env benv opc t2 l in
- l
- | _ -> (of_lexpr env benv t)::acc
-
-and of_lexpr env benv t =
- match t.pp_desc with
- | PPvar s -> DStr.H.find_exn benv.term (Unbound(Loc.extract t.pp_loc,s)) s
- | PPapp (s,l) ->
- let f = DStr.H.find_exn benv.term (Unbound(Loc.extract t.pp_loc,s)) s in
- let l = List.map (fun e -> of_lexpr env benv e) l in
- Uninterp.app_fun f l
- | PPconst (ConstInt s) ->
- Arith.cst (Q.of_string s)
- | PPconst (ConstReal q) ->
- Arith.cst q
- | PPinfix (t1,PPand,t2) ->
- let l = append_op env benv PPand t1 [] in
- let l = append_op env benv PPand t2 l in
- Bool._and l
- | PPinfix (t1,PPor,t2) ->
- let l = append_op env benv PPor t1 [] in
- let l = append_op env benv PPor t2 l in
- Bool._or l
- | PPinfix (t1,op,t2) ->
- let cl1,cl2 = Shuffle.seq2 (of_lexpr env benv) (t1,t2) in
- begin match op with
- | PPimplies -> Bool._or [Bool._not cl1;cl2]
- | PPeq
- | PPiff -> Equality.equality [cl1;cl2]
- | PPneq -> Equality.disequality [cl1;cl2]
- | PPadd -> Arith.add cl1 cl2
- | PPsub -> Arith.sub cl1 cl2
- | PPmul -> Arith.mult cl1 cl2
- | _ -> raise (Not_supported (Loc.extract t.pp_loc))
- end
- | PPprefix (op,e) ->
- let cl = of_lexpr env benv e in
- begin match op with
- | PPneg -> Arith.mult_cst (Q.of_int (-1)) cl
- | PPnot -> Bool._not cl
- end
- | PPforall (bl,ty,_,e) ->
- let result = sort benv ty in
- List.iter (fun name ->
- let cl = Variable.fresh result name in
- bind benv name cl) bl;
- let cl = of_lexpr env benv e in
- List.iter (fun name -> unbind benv name) bl;
- cl
- | PPforall_named (bl,ty,trs,e) ->
- let bl = List.map fst bl in
- of_lexpr env benv {t with pp_desc = PPforall (bl, ty, trs, e)}
- | PPconst (ConstTrue) -> Bool._true
- | PPconst (ConstFalse) -> Bool._false
- | _ -> raise (Not_supported (Loc.extract t.pp_loc))
-
-let rec of_decl sched benv = function
- | [] -> raise (Not_supported Loc.dummy_position)
- | TypeDecl (_,_,name,Abstract)::l ->
- let ctr = Ty.Constr.create name in
- DStr.H.add benv.ctr name ctr;
- of_decl sched benv l
- | TypeDecl (loc,_,_,_)::_ ->
- raise (Not_supported (Loc.extract loc))
- | Logic (_,Symbols.Other,names,result)::l ->
- let arity, result = result_sort benv result in
- List.iter (fun (name,_) ->
- let cl = if arity > 0 then
- Uninterp.fresh_fun ~result
- ~arity name
- else
- Variable.fresh result name
- in
- DStr.H.add benv.term name cl) names;
- Scheduler.Scheduler.flush_delayed sched;
- of_decl sched benv l
- | Logic _::_ -> raise (Not_supported Loc.dummy_position)
- | Axiom(_,_,_,e)::l ->
- let envd = Scheduler.Scheduler.get_delayed sched in
- let cl = of_lexpr envd benv e in
- Solver.Delayed.register envd cl;
- Bool.set_true envd Explanation.pexpfact cl;
- Scheduler.Scheduler.flush_delayed sched;
- of_decl sched benv l
- | Goal(_,_,e)::_ ->
- let envd = Scheduler.Scheduler.get_delayed sched in
- let cl = of_lexpr envd benv e in
- Solver.Delayed.register envd cl;
- Bool.set_false envd Explanation.pexpfact cl;
- Scheduler.Scheduler.flush_delayed sched
- | _::l -> of_decl sched benv l
-
-
-type result =
-| Valid
-| Idontknow
-| Sat
-
-let check_goal l =
- let sched = Scheduler.new_env [Variable.th_register;
- Uninterp.th_register; Arith.th_register;
- Bool.th_register;
- Equality.th_register] () in
- try
- let benv = {term = DStr.H.create 100; ctr = DStr.H.create 10} in
- of_decl sched benv l;
- Scheduler.Scheduler.stop_delayed sched;
- Scheduler.Scheduler.run_inf_step sched;
- Idontknow
- with Scheduler.Scheduler.Contradiction ->
- Valid
-
-let read_file s =
- let cin = open_in s in
- let lb = Lexing.from_channel cin in
- Loc.set_file s lb;
- let _, decls = Loc.with_location (Why_parser.file Why_lexer.token) lb in
- decls
-
-let read_split s =
- let cin = open_in s in
- let lb = Lexing.from_channel cin in
- Loc.set_file s lb;
- Loc.with_location (Why_parser.split_file Why_lexer.token) lb
-
-
-
-let () = Exn_printer.register (fun fmt exn ->
- match exn with
- | Not_supported pos ->
- Format.fprintf fmt
- "%a@ popop can't convert alt-ergo construct"
- Loc.report_position pos
- | _ -> raise exn)
diff --git a/src/inputlang/altergo/symbols.ml b/src/inputlang/altergo/symbols.ml
deleted file mode 100644
index b7d126c3f..000000000
--- a/src/inputlang/altergo/symbols.ml
+++ /dev/null
@@ -1,139 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-type operator =
- | Plus | Minus | Mult | Div | Modulo | Concat | Extract
- | Get | Set | Access of Strings.Hashcons.t | Record
-
-type name_kind = Ac | Constructor | Other
-
-type t =
- | True
- | False
- | Void
- | Name of Strings.Hashcons.t * name_kind
- | Int of Strings.Hashcons.t
- | Real of Strings.Hashcons.t
- | Bitv of string
- | Op of operator
- | Var of Strings.Hashcons.t
-type s = t
-
-let name ?(kind=Other) s = Name (Strings.Hashcons.make s, kind)
-let var s = Var (Strings.Hashcons.make s)
-let int i = Int (Strings.Hashcons.make i)
-let real r = Real (Strings.Hashcons.make r)
-
-let is_ac = function
- | Name(_, Ac) -> true
- | _ -> false
-
-let underscoring = function
- Var s -> Var (Strings.Hashcons.make ("$"^Strings.Hashcons.view s))
- | _ -> assert false
-
-let compare_kind k1 k2 = match k1, k2 with
- | Ac , Ac -> 0
- | Ac , _ -> 1
- | _ , Ac -> -1
- | Other, Other -> 0
- | Other, _ -> 1
- | _ , Other -> -1
- | Constructor, Constructor -> 0
-
-let compare s1 s2 = match s1, s2 with
- | Name (n1,k1), Name (n2,k2) ->
- let c = compare_kind k1 k2 in
- if c = 0 then Strings.Hashcons.compare n1 n2 else c
- | Name _, _ -> -1
- | _, Name _ -> 1
- | Var n1, Var n2 -> Strings.Hashcons.compare n1 n2
- | Var _, _ -> -1
- | _ ,Var _ -> 1
- | Int i1, Int i2 -> Strings.Hashcons.compare i1 i2
- | Int _, _ -> -1
- | _ ,Int _ -> 1
- | Op(Access s1), Op(Access s2) -> Strings.Hashcons.compare s1 s2
- | Op(Access _), _ -> -1
- | _, Op(Access _) -> 1
- | _ -> Pervasives.compare s1 s2
-
-let equal s1 s2 = compare s1 s2 = 0
-
-let hash = function
- | Name (n,Ac) -> Strings.Hashcons.hash n * 19 + 1
- | Name (n,_) -> Strings.Hashcons.hash n * 19
- | Var n (*| Int n*) -> Strings.Hashcons.hash n * 19 + 1
- | Op (Access s) -> Strings.Hashcons.hash s + 19
- | s -> Hashtbl.hash s
-
-let to_string = function
- | Name (n,_) -> Strings.Hashcons.view n
- | Var x -> (Strings.Hashcons.view x)
- | Int n -> Strings.Hashcons.view n
- | Real n -> Strings.Hashcons.view n
- | Bitv s -> "[|"^s^"|]"
- | Op Plus -> "+"
- | Op Minus -> "-"
- | Op Mult -> "*"
- | Op Div -> "/"
- | Op Modulo -> "%"
- | Op (Access s) -> "@Access_"^(Strings.Hashcons.view s)
- | Op Record -> "@Record"
- | Op Get -> "get"
- | Op Set -> "set"
- | True -> "true"
- | False -> "false"
- | Void -> "void"
- | _ -> "" (*assert false*)
-
-let print fmt s = Format.fprintf fmt "%s" (to_string s)
-
-let dummy = Name (Strings.Hashcons.make "_one", Other)
-
-let fresh =
- let cpt = ref 0 in
- fun s ->
- incr cpt;
- (* garder le suffixe "__" car cela influence l'ordre *)
- name (Format.sprintf "!?__%s%i" s (!cpt))
-
-let is_get f = equal f (Op Get)
-let is_set f = equal f (Op Set)
-
-module Map =
- Map.Make(struct type t' = t type t=t' let compare=compare end)
-
-module Set =
- Set.Make(struct type t' = t type t=t' let compare=compare end)
-
-
-
-module Labels = Hashtbl.Make(struct
- type t = s
- let equal = equal
- let hash = hash
-end)
-
-let labels = Labels.create 100007
-
-let add_label lbl t = Labels.replace labels t lbl
-
-let label t = try Labels.find labels t with Not_found ->
- Strings.Hashcons.make ""
diff --git a/src/inputlang/altergo/symbols.mli b/src/inputlang/altergo/symbols.mli
deleted file mode 100644
index 916c31027..000000000
--- a/src/inputlang/altergo/symbols.mli
+++ /dev/null
@@ -1,64 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-type operator =
- | Plus | Minus | Mult | Div | Modulo | Concat | Extract
- | Get | Set | Access of Strings.Hashcons.t | Record
-
-type name_kind = Ac | Constructor | Other
-
-type t =
- | True
- | False
- | Void
- | Name of Strings.Hashcons.t * name_kind
- | Int of Strings.Hashcons.t
- | Real of Strings.Hashcons.t
- | Bitv of string
- | Op of operator
- | Var of Strings.Hashcons.t
-
-val name : ?kind:name_kind -> string -> t
-val var : string -> t
-val underscoring : t -> t
-val int : string -> t
-val real : string -> t
-
-val is_ac : t -> bool
-
-val equal : t -> t -> bool
-val compare : t -> t -> int
-val hash : t -> int
-
-val to_string : t -> string
-val print : t Pp.printer
-
-val dummy : t
-
-val fresh : string -> t
-
-val is_get : t -> bool
-val is_set : t -> bool
-
-
-module Map : Map.S with type key = t
-module Set : Set.S with type elt = t
-
-val add_label : Strings.Hashcons.t -> t -> unit
-val label : t -> Strings.Hashcons.t
diff --git a/src/inputlang/altergo/why_lexer.mll b/src/inputlang/altergo/why_lexer.mll
deleted file mode 100644
index 7a08a2e55..000000000
--- a/src/inputlang/altergo/why_lexer.mll
+++ /dev/null
@@ -1,308 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-(*
- * The Why certification tool
- * Copyright (C) 2002 Jean-Christophe FILLIATRE
- *
- * This software is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public
- * License version 2, as published by the Free Software Foundation.
- *
- * This software 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 version 2 for more details
- * (enclosed in the file GPL).
- *)
-
-(* $Id: why_lexer.mll,v 1.26 2011-02-24 15:35:48 mebsout Exp $ *)
-
-{
- open Lexing
- open Why_parser
- open Format
-
- let rules () = 1 (** replace open Option *)
- let fmt = Debug.get_debug_formatter ()
-
- let keywords = Hashtbl.create 97
- let () =
- List.iter
- (fun (x,y) -> Hashtbl.add keywords x y)
- [ "ac", AC;
- "and", AND;
- "axiom", AXIOM;
- "inversion", INVERSION;
- "bitv", BITV;
- "bool", BOOL;
- "check", CHECK;
- "cut", CUT;
- "distinct", DISTINCT;
- "else", ELSE;
- "exists", EXISTS;
- "false", FALSE;
- "forall", FORALL;
- "function", FUNCTION;
- "goal", GOAL;
- "if", IF;
- "in", IN;
- "include", INCLUDE;
- "int", INT;
- "let", LET;
- "logic", LOGIC;
- "not", NOT;
- "or", OR;
- "predicate", PREDICATE;
- "prop", PROP;
- "real", REAL;
- "rewriting", REWRITING;
- "then", THEN;
- "true", TRUE;
- "type", TYPE;
- "unit", UNIT;
- "void", VOID;
- "with", WITH;
- ]
-
- let newline lexbuf =
- let pos = lexbuf.lex_curr_p in
- lexbuf.lex_curr_p <-
- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum }
-
- let string_buf = Buffer.create 1024
-
- exception Lexical_error of string
-
- let char_for_backslash = function
- | 'n' -> '\n'
- | 't' -> '\t'
- | c -> c
-
- let num0 = Z.of_int 0
- let num10 = Z.of_int 10
- let num16 = Z.of_int 16
-
- let decnumber s =
- let r = ref num0 in
- for i=0 to String.length s - 1 do
- r := Z.add (Z.mul num10 !r)
- (Z.of_int (Char.code s.[i] - Char.code '0'))
- done;
- !r
-
- let hexnumber s =
- let r = ref num0 in
- for i=0 to String.length s - 1 do
- let c = s.[i] in
- let v =
- match c with
- | '0'..'9' -> Char.code c - Char.code '0'
- | 'a'..'f' -> Char.code c - Char.code 'a' + 10
- | 'A'..'F' -> Char.code c - Char.code 'A' + 10
- | _ -> assert false
- in
- r := Z.add (Z.mul num16 !r) (Z.of_int v)
- done;
- !r
-
-}
-
-let newline = '\n'
-let space = [' ' '\t' '\r']
-let alpha = ['a'-'z' 'A'-'Z']
-let letter = alpha | '_'
-let digit = ['0'-'9']
-let hexdigit = ['0'-'9''a'-'f''A'-'F']
-let ident = (letter | '?') (letter | digit | '?' | '\'')*
-
-rule token = parse
- | newline
- { newline lexbuf; token lexbuf }
- | space+
- { token lexbuf }
- | ident as id (* identifiers *)
- { try
- let k = Hashtbl.find keywords id in
- if rules () = 0 then fprintf fmt "[rule] TR-Lexical-keyword@.";
- k
- with Not_found ->
- if rules () = 0 then fprintf fmt "[rule] TR-Lexical-identifier@.";
- IDENT id }
- | digit+ as s (* integers *)
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-integer@.";
- INTEGER s }
- | (digit+ as i) ("" as f) ['e' 'E'] (['-' '+']? as sign (digit+ as exp))
- | (digit+ as i) '.' (digit* as f)
- (['e' 'E'] (['-' '+']? as sign (digit+ as exp)))?
- | (digit* as i) '.' (digit+ as f)
- (['e' 'E'] (['-' '+']? as sign (digit+ as exp)))?
- (* decimal real literals *)
- { (*
- Format.eprintf "decimal real literal found: i=%s f=%s sign=%a exp=%a"
- i f so sign so exp;
- *)
- if rules () = 0 then fprintf fmt "[rule] TR-Lexical-real@.";
- let v =
- match exp,sign with
- | Some exp,Some "-" ->
- Q.div (Q.of_bigint (decnumber (i^f)))
- (Q.of_bigint (Z.pow (Z.of_int 10) (Z.to_int (decnumber exp))))
- | Some exp,_ ->
- Q.mul (Q.of_bigint (decnumber (i^f)))
- (Q.of_bigint (Z.pow (Z.of_int 10) (Z.to_int (decnumber exp))))
- | None,_ -> Q.of_bigint (decnumber (i^f))
- in
- let v =
- Q.div v
- (Q.of_bigint (Z.pow (Z.of_int 10) (String.length f)))
- in
- (* Format.eprintf " -> value = %s@." (Num.string_of_num v); *)
- NUM v
- }
-
- (* hexadecimal real literals a la C99 (0x..p..) *)
- | "0x" (hexdigit+ as e) ('.' (hexdigit* as f))?
- ['p''P'] (['+''-']? as sign) (digit+ as exp)
- { (* Format.eprintf "hex num found: %s" (lexeme lexbuf); *)
- if rules () = 0 then fprintf fmt "[rule] TR-Lexical-hexponent@.";
- if rules () = 0 then fprintf fmt "[rule] TR-Lexical-hexa@.";
- let f = match f with None -> "" | Some f -> f in
- let v =
- match sign with
- | "-" ->
- Q.div (Q.of_bigint (hexnumber (e^f)))
- (Q.of_bigint (Z.pow (Z.of_int 2) (Z.to_int (decnumber exp))))
- | _ ->
- Q.mul (Q.of_bigint (hexnumber (e^f)))
- (Q.of_bigint (Z.pow (Z.of_int 2) (Z.to_int (decnumber exp))))
- in
- let v =
- Q.div v
- (Q.of_bigint (Z.pow (Z.of_int 16) (String.length f)))
- in
- (* Format.eprintf " -> value = %s@." (Num.string_of_num v); *)
- NUM v
- }
- | "(*"
- { comment lexbuf; token lexbuf }
- | "(* status:" space* (ident as id) space* "*)" { STATUS id }
- | "'"
- { QUOTE }
- | ","
- { COMMA }
- | ";"
- { PV }
- | "("
- { LEFTPAR }
- | ")"
- { RIGHTPAR }
- | ":"
- { COLON }
- | "->"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- ARROW }
- | "<-"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- LEFTARROW }
- | "<->"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- LRARROW }
- | "="
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- EQUAL }
- | "<"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- LT }
- | "<="
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- LE }
- | ">"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- GT }
- | ">="
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- GE }
- | "<>"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- NOTEQ }
- | "+"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- PLUS }
- | "-"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- MINUS }
- | "*"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- TIMES }
- | "/"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- SLASH }
- | "%"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- PERCENT }
- | "@"
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-operator@.";
- AT }
- | "."
- { DOT }
- | "["
- { LEFTSQ }
- | "]"
- { RIGHTSQ }
- | "{"
- { LEFTBR }
- | "}"
- { RIGHTBR }
- | "|"
- { BAR }
- | "^"
- { HAT }
- | "\""
- { Buffer.clear string_buf; string lexbuf }
- | eof
- { EOF }
- | _ as c
- { raise (Lexical_error ("illegal character: " ^ String.make 1 c)) }
-
-and comment = parse
- | "*)"
- { () }
- | "(*"
- { comment lexbuf; comment lexbuf }
- | newline
- { newline lexbuf; comment lexbuf }
- | eof
- { raise (Lexical_error "unterminated comment") }
- | _
- { comment lexbuf }
-
-and string = parse
- | "\""
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-string@.";
- STRING (Buffer.contents string_buf) }
- | "\\" (_ as c)
- { Buffer.add_char string_buf (char_for_backslash c); string lexbuf }
- | newline
- { newline lexbuf; Buffer.add_char string_buf '\n'; string lexbuf }
- | eof
- { raise (Lexical_error "unterminated string") }
- | _ as c
- { Buffer.add_char string_buf c; string lexbuf }
diff --git a/src/inputlang/altergo/why_parser.mly b/src/inputlang/altergo/why_parser.mly
deleted file mode 100644
index c61885132..000000000
--- a/src/inputlang/altergo/why_parser.mly
+++ /dev/null
@@ -1,554 +0,0 @@
-/**************************************************************************/
-/* */
-/* The Alt-Ergo theorem prover */
-/* Copyright (C) 2006-2011 */
-/* */
-/* Sylvain Conchon */
-/* Evelyne Contejean */
-/* */
-/* Francois Bobot */
-/* Mohamed Iguernelala */
-/* Stephane Lescuyer */
-/* Alain Mebsout */
-/* Claire Dross */
-/* */
-/* CNRS - INRIA - Universite Paris Sud */
-/* */
-/* This file is distributed under the terms of the CeCILL-C licence */
-/* */
-/**************************************************************************/
-
-/*
- * The Why certification tool
- * Copyright (C) 2002 Jean-Christophe FILLIATRE
- *
- * This software is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public
- * License version 2, as published by the Free Software Foundation.
- *
- * This software 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 version 2 for more details
- * (enclosed in the file GPL).
- */
-
-/* from http://www.lysator.liu.se/c/ANSI-C-grammar-y.html */
-
-%{
-
- open Why_ptree
- open Parsing
- open Format
-
- let rules () = 1 (** replace open Option *)
- let fmt = Debug.get_debug_formatter ()
-
- let loc () = (symbol_start_pos (), symbol_end_pos ())
- let loc_i i = (rhs_start_pos i, rhs_end_pos i)
- let loc_ij i j = (rhs_start_pos i, rhs_end_pos j)
-
- let mk_ppl loc d = { pp_loc = loc; pp_desc = d }
- let mk_pp d = mk_ppl (loc ()) d
-
- let infix_ppl loc a i b = mk_ppl loc (PPinfix (a, i, b))
- let infix_pp a i b = infix_ppl (loc ()) a i b
-
- let prefix_ppl loc p a = mk_ppl loc (PPprefix (p, a))
- let prefix_pp p a = prefix_ppl (loc ()) p a
-
- let check_binary_mode s =
- String.iter (fun x-> if x<>'0' && x<>'1' then raise Parsing.Parse_error) s;
- s
-
-%}
-
-/* Tokens */
-
-%token <string> IDENT
-%token <string> INTEGER
-%token <string> FLOAT
-%token <Q.t> NUM
-%token <string> STRING
-%token INCLUDE
-%token WITH
-%token AND LEFTARROW ARROW AC AT AXIOM INVERSION REWRITING
-%token BAR HAT
-%token BOOL COLON COMMA PV DISTINCT DOT ELSE EOF EQUAL
-%token EXISTS FALSE VOID FORALL FUNCTION GE GOAL GT CHECK CUT ADDTERM
-%token IF IN INT BITV
-%token LE LET LEFTPAR LEFTSQ LEFTBR LOGIC LRARROW LT MINUS
-%token NOT NOTEQ OR PERCENT PLUS PREDICATE PROP
-%token QUOTE REAL UNIT
-%token RIGHTPAR RIGHTSQ RIGHTBR
-%token SLASH
-%token THEN TIMES TRUE TYPE
-%token REACH
-
-%token <string> STATUS
-
-/* Precedences */
-
-%nonassoc INCLUDE
-%nonassoc WITH
-%nonassoc IN
-%nonassoc prec_forall prec_exists
-%right ARROW LRARROW
-%right OR
-%right AND
-%nonassoc prec_ite
-%left prec_relation EQUAL NOTEQ LT LE GT GE
-%left PLUS MINUS
-%left TIMES SLASH PERCENT AT
-%nonassoc HAT
-%nonassoc uminus
-%nonassoc NOT DOT
-%right prec_named
-%nonassoc CHECK CUT ADDTERM
-%left LEFTSQ
-%nonassoc LIDENT
-
-/* Entry points */
-
-%type <Why_ptree.lexpr list> trigger
-%start trigger
-%type <Why_ptree.lexpr> lexpr
-%start lexpr
-%type <string list * Why_ptree.file> file
-%start file
-%type <(string (* resultat *) * Loc.position * Why_ptree.file) list> split_file
-%start split_file
-%%
-
-split_file:
- | EOF { [] }
- | STATUS list1_decl split_file { ($1,Loc.extract (loc_i 2), $2)::$3 }
-
-file:
-| includes list1_decl EOF
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-file@.";
- $1, $2 }
-| list1_decl EOF
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-file@.";
- [], $1 }
-| EOF
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-file@.";
- [], [] }
-;
-
-includes:
-| INCLUDE STRING { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-file@.";
- [$2]}
-| INCLUDE STRING includes{ if rules () = 0 then fprintf fmt "[rule] TR-Lexical-file@.";
- $2::$3}
-
-list1_decl:
-| decl
- { [$1] }
-| decl list1_decl
- { $1 :: $2 }
-;
-
-decl:
-| TYPE type_vars ident
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- TypeDecl (loc_ij 1 2, $2, $3, Abstract) }
-| TYPE type_vars ident EQUAL list1_constructors_sep_bar
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- TypeDecl (loc_i 2, $2, $3, Enum $5 ) }
-| TYPE type_vars ident EQUAL record_type
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- TypeDecl (loc_i 2, $2, $3, Record $5 ) }
-| LOGIC ac_modifier list1_named_ident_sep_comma COLON logic_type
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Logic (loc (), $2, $3, $5) }
-| FUNCTION named_ident LEFTPAR list0_logic_binder_sep_comma RIGHTPAR COLON
- primitive_type EQUAL lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Function_def (loc (), $2, $4, $7, $9) }
-| PREDICATE named_ident EQUAL lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Predicate_def (loc (), $2, [], $4) }
-| PREDICATE named_ident LEFTPAR list0_logic_binder_sep_comma RIGHTPAR EQUAL lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Predicate_def (loc (), $2, $4, $7) }
-| AXIOM ident COLON lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- if false (* !Preoptions.inversion_axioms*) then
- let b =
- try String.sub $2 (String.length $2 - 9) 9 = "inversion"
- with Invalid_argument _ -> false
- in
- Axiom (loc (), $2, b, $4)
- else Axiom (loc (), $2, false, $4) }
-| INVERSION ident COLON lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Axiom (loc (), $2, true, $4) }
-| REWRITING ident COLON list1_lexpr_sep_pv
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Rewriting(loc (), $2, $4) }
-| GOAL ident COLON lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-decl@.";
- Goal (loc (), $2, $4) }
-;
-
-ac_modifier:
- /* */ { Symbols.Other }
-| AC { Symbols.Ac }
-
-primitive_type:
-| INT
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTint }
-| BOOL
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTbool }
-| REAL
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTreal }
-| UNIT
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTunit }
-| BITV LEFTSQ INTEGER RIGHTSQ
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTbitv(int_of_string $3) }
-| ident
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTexternal ([], $1, loc ()) }
-| type_var
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTvarid ($1, loc ()) }
-| primitive_type ident
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTexternal ([$1], $2, loc_i 2) }
-| LEFTPAR list1_primitive_type_sep_comma RIGHTPAR ident
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-primitive-type@.";
- PPTexternal ($2, $4, loc_i 4) }
-;
-
-logic_type:
-| list0_primitive_type_sep_comma ARROW PROP
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-logic-type@.";
- PPredicate $1 }
-| PROP
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-logic-type@.";
- PPredicate [] }
-| list0_primitive_type_sep_comma ARROW primitive_type
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-logic-type@.";
- PFunction ($1, $3) }
-| primitive_type
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-logic-type@.";
- PFunction ([], $1) }
-;
-
-list1_primitive_type_sep_comma:
-| primitive_type { [$1] }
-| primitive_type COMMA list1_primitive_type_sep_comma { $1 :: $3 }
-;
-
-list0_primitive_type_sep_comma:
-| /* epsilon */ { [] }
-| list1_primitive_type_sep_comma { $1 }
-;
-
-list0_logic_binder_sep_comma:
-| /* epsilon */ { [] }
-| list1_logic_binder_sep_comma { $1 }
-;
-
-list1_logic_binder_sep_comma:
-| logic_binder { [$1] }
-| logic_binder COMMA list1_logic_binder_sep_comma { $1 :: $3 }
-;
-
-logic_binder:
-| ident COLON primitive_type
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-logic-binder@.";
- (loc_i 1, $1, $3) }
-;
-
-list1_constructors_sep_bar:
-| ident { [$1] }
-| ident BAR list1_constructors_sep_bar { $1 :: $3}
-;
-
-
-lexpr:
-
-| simple_expr { $1 }
-
-/* binary operators */
-
-| lexpr PLUS lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPadd $3 }
-| lexpr MINUS lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPsub $3 }
-| lexpr TIMES lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPmul $3 }
-| lexpr SLASH lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPdiv $3 }
-| lexpr PERCENT lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPmod $3 }
-| lexpr AND lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPand $3 }
-| lexpr OR lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPor $3 }
-| lexpr LRARROW lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPiff $3 }
-| lexpr ARROW lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 PPimplies $3 }
-| lexpr relation lexpr %prec prec_relation
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- infix_pp $1 $2 $3 }
-
-/* unary operators */
-
-| NOT lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- prefix_pp PPnot $2 }
-| MINUS lexpr %prec uminus
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- prefix_pp PPneg $2 }
-
-/* bit vectors */
-
-| LEFTSQ BAR INTEGER BAR RIGHTSQ
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-bitv@.";
- if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconst (ConstBitv (check_binary_mode $3))) }
-| lexpr HAT LEFTBR INTEGER COMMA INTEGER RIGHTBR
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- let i = mk_pp (PPconst (ConstInt $4)) in
- let j = mk_pp (PPconst (ConstInt $6)) in
- mk_pp (PPextract ($1, i, j)) }
-| lexpr AT lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconcat($1, $3)) }
-
-/* predicate or function calls */
-
-| DISTINCT LEFTPAR list2_lexpr_sep_comma RIGHTPAR
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPdistinct $3) }
-
-
-| IF lexpr THEN lexpr ELSE lexpr %prec prec_ite
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPif ($2, $4, $6)) }
-
-| FORALL list1_named_ident_sep_comma COLON primitive_type triggers
- DOT lexpr %prec prec_forall
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPforall_named ($2, $4, $5, $7)) }
-
-| EXISTS list1_named_ident_sep_comma COLON primitive_type triggers
- DOT lexpr %prec prec_exists
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPexists_named ($2, $4, $5, $7)) }
-
-| STRING COLON lexpr %prec prec_named
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPnamed ($1, $3)) }
-
-| LET ident EQUAL lexpr IN lexpr
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPlet ($2, $4, $6)) }
-
-| CHECK lexpr
- { mk_pp (PPcheck $2) }
-
-| CUT lexpr
- { mk_pp (PPcut $2) }
-;
-
-simple_expr :
-
-/* constants */
-| INTEGER
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconst (ConstInt $1)) }
-| NUM
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconst (ConstReal $1)) }
-| TRUE
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconst ConstTrue) }
-| FALSE
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconst ConstFalse) }
-| VOID
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPconst ConstVoid) }
-| ident
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPvar $1) }
-
-/* records */
-
-| LEFTBR list1_label_expr_sep_PV RIGHTBR
- { mk_pp (PPrecord $2) }
-
-| LEFTBR simple_expr WITH list1_label_expr_sep_PV RIGHTBR
- { mk_pp (PPwith($2, $4)) }
-
-| simple_expr DOT ident
- { mk_pp (PPdot($1, $3)) }
-
-/* function or predicat calls */
-
-| ident LEFTPAR list0_lexpr_sep_comma RIGHTPAR
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPapp ($1, $3)) }
-
-
-/* arrays */
-
-| simple_expr LEFTSQ lexpr RIGHTSQ
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp(PPget($1, $3)) }
-| simple_expr LEFTSQ array_assignements RIGHTSQ
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- let acc, l = match $3 with
- | [] -> assert false
- | (i, v)::l -> mk_pp (PPset($1, i, v)), l
- in
- List.fold_left (fun acc (i,v) -> mk_pp (PPset(acc, i, v))) acc l
- }
-
-| LEFTPAR lexpr RIGHTPAR
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- $2 }
-
-| simple_expr COLON primitive_type
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-expr@.";
- mk_pp (PPcast($1,$3))
- }
-;
-
-array_assignements:
-| array_assignement { [$1] }
-| array_assignement COMMA array_assignements { $1 :: $3 }
-;
-
-array_assignement:
-| lexpr LEFTARROW lexpr { $1, $3 }
-;
-
-triggers:
-| /* epsilon */
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-triggers@.";
- [] }
-| LEFTSQ list1_trigger_sep_bar RIGHTSQ
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-triggers@.";
- $2 }
-;
-
-list1_trigger_sep_bar:
-| trigger { [$1] }
-| trigger BAR list1_trigger_sep_bar { $1 :: $3 }
-;
-
-trigger:
- list1_lexpr_sep_comma
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-trigger@.";
- $1 }
-;
-
-
-list1_lexpr_sep_pv:
-| lexpr { [$1] }
-| lexpr PV { [$1] }
-| lexpr PV list1_lexpr_sep_pv { $1 :: $3 }
-;
-
-list0_lexpr_sep_comma:
-| /*empty */ { [] }
-| lexpr { [$1] }
-| lexpr COMMA list1_lexpr_sep_comma { $1 :: $3 }
-;
-
-list1_lexpr_sep_comma:
-| lexpr { [$1] }
-| lexpr COMMA list1_lexpr_sep_comma { $1 :: $3 }
-;
-
-list2_lexpr_sep_comma:
-| lexpr COMMA lexpr { [$1; $3] }
-| lexpr COMMA list2_lexpr_sep_comma { $1 :: $3 }
-;
-
-relation:
-| LT { PPlt }
-| LE { PPle }
-| GT { PPgt }
-| GE { PPge }
-| EQUAL { PPeq }
-| NOTEQ { PPneq }
-;
-
-record_type:
-| LEFTBR list1_label_sep_PV RIGHTBR
- { $2 }
-;
-
-list1_label_sep_PV:
-| label_with_type { [$1] }
-| label_with_type PV list1_label_sep_PV { $1::$3 }
-;
-
-label_with_type:
-| ident COLON primitive_type
- { $1,$3 }
-;
-
-
-list1_label_expr_sep_PV:
-| ident EQUAL lexpr
- { [$1, $3] }
-| ident EQUAL lexpr PV list1_label_expr_sep_PV
- { ($1, $3) :: $5 }
-;
-
-type_var:
-| QUOTE ident
- { if rules () = 0 then fprintf fmt "[rule] TR-Lexical-car-type@.";
- $2 }
-;
-
-type_vars:
-| /* empty */
- { [] }
-| type_var
- { [$1] }
-| LEFTPAR list1_type_var_sep_comma RIGHTPAR
- { $2 }
-
-list1_type_var_sep_comma:
-| type_var { [$1] }
-| type_var COMMA list1_type_var_sep_comma { $1 :: $3 }
-;
-
-ident:
-| IDENT { $1 }
-;
-
-list1_named_ident_sep_comma:
-| named_ident { [$1] }
-| named_ident COMMA list1_named_ident_sep_comma { $1 :: $3 }
-;
-
-named_ident:
-| IDENT { $1, "" }
-| IDENT STRING { $1, $2 }
-;
-
diff --git a/src/inputlang/altergo/why_ptree.mli b/src/inputlang/altergo/why_ptree.mli
deleted file mode 100644
index 4dd5624e8..000000000
--- a/src/inputlang/altergo/why_ptree.mli
+++ /dev/null
@@ -1,193 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-type loc = Lexing.position * Lexing.position
-
-type constant =
- | ConstBitv of string
- | ConstInt of string
- | ConstReal of Q.t
- | ConstTrue
- | ConstFalse
- | ConstVoid
-
-type pp_infix =
- | PPand | PPor | PPimplies | PPiff
- | PPlt | PPle | PPgt | PPge | PPeq | PPneq
- | PPadd | PPsub | PPmul | PPdiv | PPmod
-
-type pp_prefix =
- | PPneg | PPnot
-
-type ppure_type =
- | PPTint
- | PPTbool
- | PPTreal
- | PPTunit
- | PPTbitv of int
- | PPTvarid of string * loc
- | PPTexternal of ppure_type list * string * loc
-
-type lexpr =
- { pp_loc : loc; pp_desc : pp_desc }
-
-and pp_desc =
- | PPvar of string
- | PPapp of string * lexpr list
- | PPdistinct of lexpr list
- | PPconst of constant
- | PPinfix of lexpr * pp_infix * lexpr
- | PPprefix of pp_prefix * lexpr
- | PPget of lexpr * lexpr
- | PPset of lexpr * lexpr * lexpr
- | PPdot of lexpr * string
- | PPrecord of (string * lexpr) list
- | PPwith of lexpr * (string * lexpr) list
- | PPextract of lexpr * lexpr * lexpr
- | PPconcat of lexpr * lexpr
- | PPif of lexpr * lexpr * lexpr
- | PPforall of string list * ppure_type * lexpr list list * lexpr
- | PPexists of string list * ppure_type * lexpr list list * lexpr
- | PPforall_named of
- (string * string) list * ppure_type * lexpr list list * lexpr
- | PPexists_named of
- (string * string) list * ppure_type * lexpr list list * lexpr
- | PPnamed of string * lexpr
- | PPlet of string * lexpr * lexpr
- | PPcheck of lexpr
- | PPcut of lexpr
- | PPcast of lexpr * ppure_type
-
-(* Declarations. *)
-
-type plogic_type =
- | PPredicate of ppure_type list
- | PFunction of ppure_type list * ppure_type
-
-type name_kind = Symbols.name_kind
-
-type body_type_decl =
- | Record of (string * ppure_type) list (* lbl : t *)
- | Enum of string list
- | Abstract
-
-type inversion = bool
-
-type decl =
- | Axiom of loc * string * inversion * lexpr
- | Rewriting of loc * string * lexpr list
- | Goal of loc * string * lexpr
- | Logic of loc * name_kind * (string * string) list * plogic_type
- | Predicate_def of
- loc * (string * string) *
- (loc * string * ppure_type) list * lexpr
- | Function_def of
- loc * (string * string) *
- (loc * string * ppure_type) list * ppure_type * lexpr
- | TypeDecl of loc * string list * string * body_type_decl
-
-type file = decl list
-
-(*** typed ast *)
-
-type ('a, 'b) annoted =
- { c : 'a;
- annot : 'b }
-
-type tconstant =
- | Tint of string
- | Treal of Num.num
- | Tbitv of string
- | Ttrue
- | Tfalse
- | Tvoid
-
-type 'a tterm =
- { tt_ty : Why_ty.t; tt_desc : 'a tt_desc }
-and 'a tt_desc =
- | TTconst of tconstant
- | TTvar of Symbols.t
- | TTinfix of ('a tterm, 'a) annoted * Symbols.t * ('a tterm, 'a) annoted
- | TTprefix of Symbols.t * ('a tterm, 'a) annoted
- | TTapp of Symbols.t * ('a tterm, 'a) annoted list
- | TTget of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted
- | TTset of
- ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted
- | TTextract of
- ('a tterm, 'a) annoted * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted
- | TTconcat of ('a tterm, 'a) annoted * ('a tterm, 'a) annoted
- | TTdot of ('a tterm, 'a) annoted * Strings.Hashcons.t
- | TTrecord of (Strings.Hashcons.t * ('a tterm, 'a) annoted) list
- | TTlet of Symbols.t * ('a tterm, 'a) annoted * ('a tterm, 'a) annoted
- | TTnamed of Strings.Hashcons.t * ('a tterm, 'a) annoted
-
-type 'a tatom =
- | TAtrue
- | TAfalse
- | TAeq of ('a tterm, 'a) annoted list
- | TAdistinct of ('a tterm, 'a) annoted list
- | TAneq of ('a tterm, 'a) annoted list
- | TAle of ('a tterm, 'a) annoted list
- | TAlt of ('a tterm, 'a) annoted list
- | TApred of ('a tterm, 'a) annoted
- | TAbuilt of Strings.Hashcons.t * ('a tterm, 'a) annoted list
-
-type 'a oplogic =
- OPand |OPor | OPimp | OPnot | OPiff
- | OPif of ('a tterm, 'a) annoted
-
-type 'a quant_form = {
- (* quantified variables that appear in the formula *)
- qf_bvars : (Symbols.t * Why_ty.t) list ;
- qf_upvars : (Symbols.t * Why_ty.t) list ;
- qf_triggers : ('a tterm, 'a) annoted list list ;
- qf_form : ('a tform, 'a) annoted
-}
-
-and 'a tform =
- | TFatom of ('a tatom, 'a) annoted
- | TFop of 'a oplogic * (('a tform, 'a) annoted) list
- | TFforall of 'a quant_form
- | TFexists of 'a quant_form
- | TFlet of (Symbols.t * Why_ty.t) list * Symbols.t *
- ('a tterm, 'a) annoted * ('a tform, 'a) annoted
- | TFnamed of Strings.Hashcons.t * ('a tform, 'a) annoted
-
-
-type 'a rwt_rule = {
- rwt_vars : (Symbols.t * Why_ty.t) list;
- rwt_left : 'a;
- rwt_right : 'a
-}
-
-type goal_sort = Cut | Check | Thm
-
-type 'a tdecl =
- | TAxiom of loc * string * inversion * ('a tform, 'a) annoted
- | TRewriting of loc * string * (('a tterm, 'a) annoted rwt_rule) list
- | TGoal of loc * goal_sort * string * ('a tform, 'a) annoted
- | TLogic of loc * string list * plogic_type
- | TPredicate_def of
- loc * string *
- (string * ppure_type) list * ('a tform, 'a) annoted
- | TFunction_def of
- loc * string *
- (string * ppure_type) list * ppure_type * ('a tform, 'a) annoted
- | TTypeDecl of loc * string list * string * body_type_decl
-
diff --git a/src/inputlang/altergo/why_ty.ml b/src/inputlang/altergo/why_ty.ml
deleted file mode 100644
index 15b5bb380..000000000
--- a/src/inputlang/altergo/why_ty.ml
+++ /dev/null
@@ -1,369 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-open Format
-
-type t =
- | Tint
- | Treal
- | Tbool
- | Tunit
- | Tvar of tvar
- | Tbitv of int
- | Text of t list * Strings.Hashcons.t
- | Tfarray of t * t
- | Tnext of t
- | Tsum of Strings.Hashcons.t * Strings.Hashcons.t list
- | Trecord of trecord
-
-and tvar = { v : int ; mutable value : t option }
-and trecord = {
- mutable args : t list;
- name : Strings.Hashcons.t;
- mutable lbs : (Strings.Hashcons.t * t) list
-}
-
-exception TypeClash of t*t
-exception Shorten of t
-
-
-
-(*** pretty print ***)
-let print full fmt ty =
- let h = Hashtbl.create 17 in
- let rec print fmt = function
- | Tint -> fprintf fmt "int"
- | Treal -> fprintf fmt "real"
- | Tbool -> fprintf fmt "bool"
- | Tunit -> fprintf fmt "unit"
- | Tbitv n -> fprintf fmt "bitv[%d]" n
- | Tvar{v=v ; value = None} -> fprintf fmt "'a_%d" v
- | Tvar{v=v ; value = Some (Trecord {args=l; name=n} as t) } ->
- if Hashtbl.mem h v then
- fprintf fmt "%a%s" printl l (Strings.Hashcons.view n)
- else
- (Hashtbl.add h v ();
- (*fprintf fmt "('a_%d->%a)" v print t *)
- print fmt t)
- | Tvar{value = Some t} ->
- (*fprintf fmt "('a_%d->%a)" v print t *)
- print fmt t
- | Text(l, s) -> fprintf fmt "%a%s" printl l (Strings.Hashcons.view s)
- | Tfarray (t1, t2) -> fprintf fmt "(%a,%a) farray" print t1 print t2
- | Tnext t -> fprintf fmt "%a next" print t
- | Tsum(s, _) -> fprintf fmt "%s" (Strings.Hashcons.view s)
- | Trecord {args=lv; name=n; lbs=lbls} ->
- fprintf fmt "%a%s" printl lv (Strings.Hashcons.view n);
- if full then begin
- fprintf fmt " = {";
- let first = ref true in
- List.iter
- (fun (s, t) ->
- fprintf fmt "%s%s : %a" (if !first then "" else "; ")
- (Strings.Hashcons.view s) print t;
- first := false
- ) lbls;
- fprintf fmt "}"
- end
-
- and printl fmt = function
- [] -> ()
- | [t] -> fprintf fmt "%a " print t
- | t::l -> fprintf fmt "%a,%a" print t printl l
- in
- print fmt ty
-
-let print_full = print true
-let print = print false
-
-
-(* smart constructors *)
-
-let tunit = Text ([],Strings.Hashcons.make "unit")
-
-let text l s = Text (l,Strings.Hashcons.make s)
-
-let tsum s lc = Tsum (Strings.Hashcons.make s, List.map Strings.Hashcons.make lc)
-
-let trecord lv n lbs =
- let lbs = List.map (fun (l,ty) -> Strings.Hashcons.make l, ty) lbs in
- let lbs = List.sort (fun (l1, _) (l2, _) -> Strings.Hashcons.compare l1 l2) lbs in
- Trecord { args = lv; name = Strings.Hashcons.make n; lbs = lbs}
-
-let rec shorten t =
- match t with
- | Tvar {value=None} -> t
- | Tvar {value=Some(Tvar{value=None} as t')} -> t'
- | Tvar ({value=Some(Tvar t2)} as t1) -> t1.value <- t2.value; shorten t
- | Tvar {value = Some t'} -> shorten t'
- | Text (l,s) -> Text(List.map shorten l,s)
- | Tfarray (t1,t2) -> Tfarray(shorten t1,shorten t2)
- | Trecord r ->
- r.args <- List.map shorten r.args;
- r.lbs <- List.map (fun (lb, ty) -> lb, shorten ty) r.lbs;
- t
- | _ -> t
-
-let fresh_var =
- let cpt = ref (-1) in
- fun () -> incr cpt; {v= !cpt ; value = None }
-
-let fresh_empty_text =
- let cpt = ref (-1) in
- fun () -> incr cpt; text [] ("'_c"^(string_of_int !cpt))
-
-let rec hash t =
- match t with
- | Tvar{v=v} -> v
- | Text(l,s) ->
- abs (List.fold_left (fun acc x-> acc*19 + hash x) (Strings.Hashcons.hash s) l)
- | Tfarray (t1,t2) -> 19 * (hash t1) + 23 * (hash t2)
- | Trecord { args = args; name = s; lbs = lbs} ->
- let h =
- List.fold_left (fun h ty -> 27 * h + hash ty) (Strings.Hashcons.hash s) args
- in
- let h =
- List.fold_left
- (fun h (lb, ty) -> 23 * h + 19 * (Strings.Hashcons.hash lb) + hash ty)
- (abs h) lbs
- in
- abs h
- | Tsum (s, l) ->
- let h =
- List.fold_left
- (fun h x -> 13 * h + Strings.Hashcons.hash x) (Strings.Hashcons.hash s) l
- in
- abs h
- | _ -> Hashtbl.hash t
-
-let rec equal t1 t2 =
- match shorten t1 , shorten t2 with
- | Tvar{v=v1}, Tvar{v=v2} -> v1 = v2
- | Text(l1, s1), Text(l2, s2) ->
- (try Strings.Hashcons.equal s1 s2 && List.for_all2 equal l1 l2
- with Invalid_argument _ -> false)
- | Tfarray (ta1, ta2), Tfarray (tb1, tb2) ->
- equal ta1 tb1 && equal ta2 tb2
- | Tsum (s1, _), Tsum (s2, _) -> Strings.Hashcons.equal s1 s2
- | Trecord {args=a1;name=s1;lbs=l1}, Trecord {args=a2;name=s2;lbs=l2} ->
- begin
- try
- Strings.Hashcons.equal s1 s2 && List.for_all2 equal a1 a2 &&
- List.for_all2
- (fun (l1, ty1) (l2, ty2) ->
- Strings.Hashcons.equal l1 l2 && equal ty1 ty2) l1 l2
- with Invalid_argument _ -> false
- end
- | Tint, Tint | Treal, Treal | Tbool, Tbool | Tunit, Tunit -> true
- | Tbitv n1, Tbitv n2 -> n1 =n2
- | Tnext t1, Tnext t2 -> equal t1 t2
- | _ -> false
-
-let rec compare t1 t2 =
- match shorten t1 , shorten t2 with
- | Tvar{v=v1} , Tvar{v=v2} -> Pervasives.compare v1 v2
- | Tvar _, _ -> -1 | _ , Tvar _ -> 1
- | Text(l1, s1) , Text(l2, s2) ->
- let c = Strings.Hashcons.compare s1 s2 in
- if c<>0 then c
- else compare_list l1 l2
- | Text _, _ -> -1 | _ , Text _ -> 1
- | Tfarray (ta1,ta2), Tfarray (tb1,tb2) ->
- let c = compare ta1 tb1 in
- if c<>0 then c
- else compare ta2 tb2
- | Tfarray _, _ -> -1 | _ , Tfarray _ -> 1
- | Tsum(s1, _), Tsum(s2, _) ->
- Strings.Hashcons.compare s1 s2
- | Tsum _, _ -> -1 | _ , Tsum _ -> 1
- | Trecord {args=a1;name=s1;lbs=l1},Trecord {args=a2;name=s2;lbs=l2} ->
- let c = Strings.Hashcons.compare s1 s2 in
- if c <> 0 then c else
- let c = compare_list a1 a2 in
- if c <> 0 then c else
- let l1, l2 = List.map snd l1, List.map snd l2 in
- compare_list l1 l2
- | Trecord _, _ -> -1 | _ , Trecord _ -> 1
- | t1 , t2 -> Pervasives.compare t1 t2
-and compare_list l1 l2 = match l1, l2 with
- | [] , [] -> 0
- | [] , _ -> -1
- | _ , [] -> 1
- | x::ll1 , y::ll2 ->
- let c = compare x y in
- if c<>0 then c else compare_list ll1 ll2
-
-let occurs {v=n} t =
- let rec occursrec = function
- Tvar {v=m} -> n=m
- | Text(l,_) -> List.exists occursrec l
- | Tfarray (t1,t2) -> occursrec t1 || occursrec t2
- | _ -> false
- in occursrec t
-
-(*** destructive unification ***)
-let rec unify t1 t2 =
- let t1 = shorten t1 in
- let t2 = shorten t2 in
- match t1 , t2 with
- Tvar ({v=n;value=None} as tv1), Tvar {v=m;value=None} ->
- if n<>m then tv1.value <- Some t2
- | _ , Tvar ({value=None} as tv) ->
- if (occurs tv t1) then raise (TypeClash(t1,t2));
- tv.value <- Some t1
- | Tvar ({value=None} as tv) , _ ->
- if (occurs tv t2) then raise (TypeClash(t1,t2));
- tv.value <- Some t2
- | Text(l1,s1) , Text(l2,s2) when Strings.Hashcons.equal s1 s2 ->
- List.iter2 unify l1 l2
- | Tfarray (ta1,ta2), Tfarray (tb1,tb2) -> unify ta1 tb1;unify ta2 tb2
- | Trecord r1, Trecord r2 when Strings.Hashcons.equal r1.name r2.name ->
- List.iter2 unify r1.args r2.args
- | Tsum(s1, _) , Tsum(s2, _) when Strings.Hashcons.equal s1 s2 -> ()
- | Tint, Tint | Tbool, Tbool | Treal, Treal | Tunit, Tunit -> ()
- | Tbitv n , Tbitv m when m=n -> ()
- | _ , _ ->
- raise (TypeClash(t1,t2))
-
-
-(*** matching with a substitution mechanism ***)
-module M = Map.Make(struct type t=int let compare = Pervasives.compare end)
-type subst = t M.t
-
-let esubst = M.empty
-
-let rec matching s pat t =
- match pat , t with
- | Tvar {v=n;value=None} , _ ->
- (try if not (equal (M.find n s) t) then raise (TypeClash(pat,t)); s
- with Not_found -> M.add n t s)
- | Tvar {value=_}, _ -> raise (Shorten pat)
- | Text (l1,s1) , Text (l2,s2) when Strings.Hashcons.equal s1 s2 ->
- List.fold_left2 matching s l1 l2
- | Tfarray (ta1,ta2), Tfarray (tb1,tb2) ->
- matching (matching s ta1 tb1) ta2 tb2
- | Trecord r1, Trecord r2 when Strings.Hashcons.equal r1.name r2.name ->
- let s = List.fold_left2 matching s r1.args r2.args in
- List.fold_left2
- (fun s (_, p) (_, ty) -> matching s p ty) s r1.lbs r2.lbs
- | Tsum (s1, _), Tsum (s2, _) when Strings.Hashcons.equal s1 s2 -> s
- | Tint , Tint | Tbool , Tbool | Treal , Treal | Tunit, Tunit -> s
- | Tbitv n , Tbitv m when n=m -> s
- | _ , _ ->
- raise (TypeClash(pat,t))
-
-let rec apply_subst s ty =
- match ty with
- | Tvar {v=n} ->
- (try M.find n s with Not_found -> ty)
- | Text (l,e) -> Text(List.map (apply_subst s) l,e)
- | Tfarray (t1,t2) -> Tfarray (apply_subst s t1,apply_subst s t2)
- | Trecord r ->
- let lbs = List.map (fun (x,t) -> x, apply_subst s t) r.lbs in
- Trecord
- {args = List.map (apply_subst s) r.args;
- name = r.name;
- lbs = lbs}
- | t -> t
-
-let instantiate lvar lty ty =
- let s =
- List.fold_left2
- (fun s x t ->
- match x with
- | Tvar {v=n} ->
- M.add n t s
- | _ -> assert false) M.empty lvar lty
- in
- apply_subst s ty
-
-let union_subst s1 s2 =
- M.fold (fun k x s2 -> M.add k x s2) (M.map (apply_subst s2) s1) s2
-
-let compare_subst = M.compare Pervasives.compare
-
-let rec fresh ty subst =
- match ty with
- | Tvar {v=x} ->
- begin
- try M.find x subst, subst
- with Not_found ->
- let nv = Tvar (fresh_var()) in
- nv, M.add x nv subst
- end
- | Text (args, n) ->
- let args, subst = fresh_list args subst in
- Text (args, n), subst
- | Tfarray (ty1, ty2) ->
- let ty1, subst = fresh ty1 subst in
- let ty2, subst = fresh ty2 subst in
- Tfarray (ty1, ty2), subst
- | Trecord {args = args; name = n; lbs = lbs} ->
- let args, subst = fresh_list args subst in
- let lbs, subst =
- List.fold_right
- (fun (x,ty) (lbs, subst) ->
- let ty, subst = fresh ty subst in
- (x, ty)::lbs, subst) lbs ([], subst)
- in
- Trecord { args = args; name = n; lbs = lbs}, subst
- | t -> t, subst
-and fresh_list lty subst =
- List.fold_right
- (fun ty (lty, subst) ->
- let ty, subst = fresh ty subst in
- ty::lty, subst) lty ([], subst)
-
-module Svty =
- Set.Make(struct type t = int let compare = Pervasives.compare end)
-
-let vty_of t =
- let rec vty_of_rec acc t =
- let t = shorten t in
- match t with
- | Tvar { v = i ; value = None } -> Svty.add i acc
- | Text(l,_) -> List.fold_left vty_of_rec acc l
- | Tfarray (t1,t2) -> vty_of_rec (vty_of_rec acc t1) t2
- | Trecord {args = args; lbs = lbs} ->
- let acc = List.fold_left vty_of_rec acc args in
- List.fold_left (fun acc (_, ty) -> vty_of_rec acc ty) acc lbs
- | _ -> acc
- in
- vty_of_rec Svty.empty t
-
-let rec monomorphize ty =
- match ty with
- | Tint | Treal | Tbool | Tunit | Tbitv _ | Tsum _ -> ty
- | Text (tyl,hs) -> Text (List.map monomorphize tyl, hs)
- | Trecord {args = tylv; name = n; lbs = tylb} ->
- let m_tylv = List.map monomorphize tylv in
- let m_tylb =
- List.map (fun (lb, ty_lb) -> lb, monomorphize ty_lb) tylb
- in
- Trecord {args = m_tylv; name = n; lbs = m_tylb}
- | Tfarray (ty1,ty2) -> Tfarray (monomorphize ty1,monomorphize ty2)
- | Tnext ty -> Tnext (monomorphize ty)
- | Tvar {v=v; value=None} -> text [] ("'_c"^(string_of_int v))
- | Tvar ({value=Some ty1} as r) ->
- Tvar { r with value = Some (monomorphize ty1)}
-
-
-let print_subst fmt sbt =
- M.iter (fun n ty -> fprintf fmt "%d -> %a" n print ty) sbt;
- fprintf fmt "@?"
diff --git a/src/inputlang/altergo/why_ty.mli b/src/inputlang/altergo/why_ty.mli
deleted file mode 100644
index 7ab10ad27..000000000
--- a/src/inputlang/altergo/why_ty.mli
+++ /dev/null
@@ -1,87 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-type t =
- | Tint
- | Treal
- | Tbool
- | Tunit
- | Tvar of tvar
- | Tbitv of int
- | Text of t list * Strings.Hashcons.t
- | Tfarray of t * t
- | Tnext of t
- | Tsum of Strings.Hashcons.t * Strings.Hashcons.t list
- | Trecord of trecord
-
-and tvar = { v : int ; mutable value : t option }
-and trecord = {
- mutable args : t list;
- name : Strings.Hashcons.t;
- mutable lbs : (Strings.Hashcons.t * t) list
-}
-
-
-type subst
-
-val esubst : subst
-
-exception TypeClash of t*t
-
-val tunit : t
-
-val text : t list -> string -> t
-val tsum : string -> string list -> t
-val trecord : t list -> string -> (string * t) list -> t
-
-val shorten : t -> t
-
-val fresh_var : unit -> tvar
-val fresh_empty_text : unit -> t
-
-val fresh : t -> subst -> t * subst
-val fresh_list : t list -> subst -> t list * subst
-
-val equal : t -> t -> bool
-val hash : t -> int
-val compare : t -> t -> int
-
-val unify : t -> t -> unit
-val matching : subst -> t -> t -> subst
-
-val apply_subst : subst -> t -> t
-val instantiate : t list -> t list -> t -> t
-
-(* Applique la seconde substitution sur la premiere
- puis fais l'union des map avec prioritée à la première *)
-val union_subst : subst -> subst -> subst
-
-val compare_subst : subst -> subst -> int
-
-val print : t Pp.printer
-val print_full : t Pp.printer
-(*val printl : t list Pp.printer*)
-
-module Svty : Set.S
-
-val vty_of : t -> Svty.t
-
-val monomorphize: t -> t
-
-val print_subst: subst Pp.printer
diff --git a/src/inputlang/altergo/why_typing.ml b/src/inputlang/altergo/why_typing.ml
deleted file mode 100644
index 1568bebfb..000000000
--- a/src/inputlang/altergo/why_typing.ml
+++ /dev/null
@@ -1,1390 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-open Options
-open Format
-open Why_ptree
-open Common
-
-module S = Set.Make(String)
-module Sy = Symbols.Set
-
-module MString =
- Map.Make(struct type t = string let compare = Pervasives.compare end)
-
-module Types = struct
-
- (* environment for user-defined types *)
- type t = {
- to_ty : Why_ty.t MString.t;
- from_labels : string MString.t; }
-
- let to_tyvars = ref MString.empty
-
- let empty =
- { to_ty = MString.empty;
- from_labels = MString.empty }
-
- let fresh_vars env vars loc =
- List.map
- (fun x ->
- if MString.mem x !to_tyvars then
- error (TypeDuplicateVar x) loc;
- let nv = Why_ty.Tvar (Why_ty.fresh_var ()) in
- to_tyvars := MString.add x nv !to_tyvars;
- nv
- ) vars
-
- let check_number_args loc lty ty =
- match ty with
- | Why_ty.Text (lty', s) | Why_ty.Trecord {Why_ty.args=lty'; name=s} ->
- if List.length lty <> List.length lty' then
- error (WrongNumberofArgs (Hstring.view s)) loc;
- lty'
- | Why_ty.Tsum (s, _) ->
- if List.length lty <> 0 then
- error (WrongNumberofArgs (Hstring.view s)) loc;
- []
- | _ -> assert false
-
- let equal_pp_vars lpp lvars =
- try
- List.for_all2
- (fun pp x ->
- match pp with PPTvarid (y, _) -> x = y | _ -> false) lpp lvars
- with Invalid_argument _ -> false
-
- let rec ty_of_pp loc env rectype = function
- | PPTint -> Why_ty.Tint
- | PPTbool -> Why_ty.Tbool
- | PPTunit -> Why_ty.Tunit
- | PPTreal -> Why_ty.Treal
- | PPTbitv n -> Why_ty.Tbitv n
- | PPTvarid (s, _) ->
- begin
- try MString.find s !to_tyvars
- with Not_found ->
- let nty = Why_ty.Tvar (Why_ty.fresh_var ()) in
- to_tyvars := MString.add s nty !to_tyvars;
- nty
- end
- | PPTexternal (l, s, loc) when s = "farray" ->
- let t1,t2 = match l with
- | [t2] -> PPTint,t2
- | [t1;t2] -> t1,t2
- | _ -> error (WrongArity(s,2)) loc in
- let ty1 = ty_of_pp loc env rectype t1 in
- let ty2 = ty_of_pp loc env rectype t2 in
- Why_ty.Tfarray (ty1, ty2)
- | PPTexternal (l, s, loc) ->
- begin
- match rectype with
- | Some (id, vars, ty) when s = id && equal_pp_vars l vars -> ty
- | _ ->
- try
- let lty = List.map (ty_of_pp loc env rectype) l in
- let ty = MString.find s env.to_ty in
- let vars = check_number_args loc lty ty in
- Why_ty.instantiate vars lty ty
- with Not_found ->
- error (UnknownType s) loc
- end
-
- let add env vars id body loc =
- if MString.mem id env.to_ty then error (ClashType id) loc;
- let ty_vars = fresh_vars env vars loc in
- match body with
- | Abstract ->
- { env with to_ty = MString.add id (Why_ty.text ty_vars id) env.to_ty }
- | Enum lc ->
- { env with to_ty = MString.add id (Why_ty.tsum id lc) env.to_ty }
- | Record lbs ->
- let lbs =
- List.map (fun (x, pp) -> x, ty_of_pp loc env None pp) lbs in
- { to_ty = MString.add id (Why_ty.trecord ty_vars id lbs) env.to_ty;
- from_labels =
- List.fold_left
- (fun fl (l,_) -> MString.add l id fl) env.from_labels lbs }
-
- module SH = Set.Make(Hstring)
-
- let check_labels lbs ty loc =
- let rec check_duplicates s = function
- | [] -> ()
- | (lb, _) :: l ->
- if SH.mem lb s then error (DuplicateLabel lb) loc;
- check_duplicates (SH.add lb s) l
- in
- check_duplicates SH.empty lbs;
- match ty with
- | Why_ty.Trecord {Why_ty.lbs=l} ->
- if List.length lbs <> List.length l then
- error WrongNumberOfLabels loc;
- List.iter
- (fun (lb, _) ->
- try ignore (Hstring.list_assoc lb l)
- with Not_found -> error (WrongLabel(lb, ty)) loc) lbs;
- ty
- | _ -> assert false
-
-
- let from_labels env lbs loc =
- match lbs with
- | [] -> assert false
- | (l, _) :: _ ->
- try
- let l = Hstring.view l in
- let ty = MString.find (MString.find l env.from_labels) env.to_ty in
- check_labels lbs ty loc
- with Not_found -> error (NoRecordType l) loc
-
- let rec monomorphized = function
- | PPTvarid (x, _) when not (MString.mem x !to_tyvars) ->
- to_tyvars := MString.add x (Why_ty.fresh_empty_text ()) !to_tyvars;
-
- | PPTexternal (args, _, _) ->
- List.iter monomorphized args
-
- | pp_ty -> ()
-
- let init_labels fl id loc = function
- | Record lbs ->
- List.fold_left
- (fun fl (s, _) ->
- if MString.mem s fl then
- error (ClashLabel (s, (MString.find s fl))) loc;
- MString.add s id fl) fl lbs
- | _ -> fl
-
-end
-
-module Env = struct
-
- type profile = { args : Why_ty.t list; result : Why_ty.t }
-
- type t = {
- var_map : (Symbols.t * Why_ty.t) MString.t ; (* variables' map*)
- types : Types.t ;
- logics : (Symbols.t * profile) MString.t (* logic symbols' map *)
- }
-
- let empty = {
- var_map = MString.empty;
- types = Types.empty;
- logics = MString.empty
- }
-
- let add env lv fvar ty =
- let vmap =
- List.fold_left
- (fun vmap x -> MString.add x (fvar x, ty) vmap) env.var_map lv in
- { env with var_map = vmap }
-
- let add_var env lv pp_ty loc =
- let ty = Types.ty_of_pp loc env.types None pp_ty in
- add env lv Symbols.var ty
-
- let add_names env lv pp_ty loc =
- Types.monomorphized pp_ty;
- let ty = Types.ty_of_pp loc env.types None pp_ty in
- add env lv Symbols.name ty
-
- let add_names_lbl env lv pp_ty loc =
- Types.monomorphized pp_ty;
- let ty = Types.ty_of_pp loc env.types None pp_ty in
- let rlv =
- List.fold_left (fun acc (x, lbl) ->
- let lbl = Hstring.make lbl in
- if not (Hstring.equal lbl Hstring.empty) then
- Symbols.add_label lbl (Symbols.name x);
- x::acc
- ) [] lv in
- let lv = List.rev rlv in
- add env lv Symbols.name ty
-
- let add_logics env ac names pp_profile loc =
- let profile =
- match pp_profile with
- | PPredicate args ->
- { args = List.map (Types.ty_of_pp loc env.types None) args;
- result = Why_ty.Tbool }
- (*| PFunction ([], PPTvarid (_, loc)) ->
- error CannotGeneralize loc*)
- | PFunction(args, res) ->
- let args = List.map (Types.ty_of_pp loc env.types None) args in
- let res = Types.ty_of_pp loc env.types None res in
- { args = args; result = res }
- in
- let logics =
- List.fold_left
- (fun logics (n, lbl) ->
- let sy = Symbols.name n ~kind:ac in
- if MString.mem n logics then error (SymbAlreadyDefined n) loc;
-
- let lbl = Hstring.make lbl in
- if not (Hstring.equal lbl Hstring.empty) then
- Symbols.add_label lbl sy;
-
- MString.add n (sy, profile) logics)
- env.logics names
- in
- { env with logics = logics }
-
- let find {var_map=m} n = MString.find n m
-
- let mem n {var_map=m} = MString.mem n m
-
- let list_of {var_map=m} = MString.fold (fun _ c acc -> c::acc) m []
-
- let add_type_decl env vars id body loc =
- { env with types = Types.add env.types vars id body loc }
-
- (* returns a type with fresh variables *)
- let fresh_type env n loc =
- try
- let s, { args = args; result = r} = MString.find n env.logics in
- let args, subst = Why_ty.fresh_list args Why_ty.esubst in
- let res, _ = Why_ty.fresh r subst in
- s, { args = args; result = res }
- with Not_found -> error (SymbUndefined n) loc
-
-end
-
-let new_id = let r = ref 0 in fun () -> r := !r+1; !r
-
-let rec freevars_term acc t = match t.c.tt_desc with
- | TTvar x -> Sy.add x acc
- | TTapp (_,lt) -> List.fold_left freevars_term acc lt
- | TTinfix (t1,_,t2) | TTget(t1, t2) ->
- List.fold_left freevars_term acc [t1; t2]
- | TTset (t1, t2, t3) ->
- List.fold_left freevars_term acc [t1; t2; t3]
- | TTdot (t1, _) -> freevars_term acc t1
- | TTrecord lbs ->
- List.fold_left (fun acc (_, t) -> freevars_term acc t) acc lbs
- | _ -> acc
-
-let freevars_atom a = match a.c with
- | TAeq lt | TAneq lt | TAle lt
- | TAlt lt | TAbuilt(_,lt) | TAdistinct lt ->
- List.fold_left freevars_term Sy.empty lt
- | TApred t -> freevars_term Sy.empty t
- | _ -> Sy.empty
-
-let rec freevars_form f = match f with
- | TFatom a -> freevars_atom a
- | TFop (_,lf) ->
- List.fold_left Sy.union Sy.empty
- (List.map (fun f -> freevars_form f.c) lf)
- | TFforall qf | TFexists qf ->
- let s = freevars_form qf.qf_form.c in
- List.fold_left (fun acc (s,_) -> Sy.remove s acc) s qf.qf_bvars
- | TFlet(up,v,t,f) -> freevars_term (Sy.remove v (freevars_form f.c)) t
- | TFnamed(_, f) -> freevars_form f.c
-
-let symbol_of = function
- PPadd -> Symbols.Op Symbols.Plus
- | PPsub -> Symbols.Op Symbols.Minus
- | PPmul -> Symbols.Op Symbols.Mult
- | PPdiv -> Symbols.Op Symbols.Div
- | PPmod -> Symbols.Op Symbols.Modulo
- | _ -> assert false
-
-let rec type_term env f =
- let e,t = type_term_desc env f.pp_loc f.pp_desc in
- {c = { tt_desc = e ; tt_ty = t }; annot = new_id ()}
-
-and type_term_desc env loc = function
- | PPconst ConstTrue ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Const type %a@\n" Why_ty.print Why_ty.Tbool;
- TTconst Ttrue, Why_ty.Tbool
- | PPconst ConstFalse ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Const type %a@\n" Why_ty.print Why_ty.Tbool;
- TTconst Tfalse, Why_ty.Tbool
- | PPconst ConstVoid ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Const type %a@\n" Why_ty.print Why_ty.Tunit;
- TTconst Tvoid, Why_ty.Tunit
- | PPconst (ConstInt n) ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Const type %a@\n" Why_ty.print Why_ty.Tint;
- TTconst(Tint n), Why_ty.Tint
- | PPconst (ConstReal n) ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Const type %a@\n" Why_ty.print Why_ty.Treal;
- TTconst(Treal n), Why_ty.Treal
- | PPconst (ConstBitv n) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Const type %a@\n" Why_ty.print
- (Why_ty.Tbitv (String.length n));
- TTconst(Tbitv n), Why_ty.Tbitv (String.length n)
- | PPvar p ->
- begin
- try let s,t = Env.find env p in
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Var$_\\Gamma$ type %a@\n"
- Why_ty.print t;
- TTvar s , t
- with Not_found ->
- match Env.fresh_type env p loc with
- | s, { Env.args = []; result = ty} ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Var$_\\Delta$ type %a@\n"
- Why_ty.print ty;
- TTvar s , ty
- | _ -> error (ShouldBeApply p) loc
- end
- | PPapp(p,args) ->
- begin
- let te_args = List.map (type_term env) args in
- let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in
- let s, {Env.args = lt; result = t} = Env.fresh_type env p loc in
- try
- List.iter2 Why_ty.unify lt lt_args;
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-App type %a@\n" Why_ty.print t;
- TTapp(s,te_args), t
- with
- | Why_ty.TypeClash(t1,t2) ->
- error (Unification(t1,t2)) loc
- | Invalid_argument _ ->
- error (WrongNumberofArgs p) loc
- end
- | PPinfix(t1,(PPadd | PPsub | PPmul | PPdiv as op),t2) ->
- begin
- let s = symbol_of op in
- let te1 = type_term env t1 in
- let te2 = type_term env t2 in
- let ty1 = Why_ty.shorten te1.c.tt_ty in
- let ty2 = Why_ty.shorten te2.c.tt_ty in
- match ty1, ty2 with
- | Why_ty.Tint, Why_ty.Tint ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpBin type %a@\n"
- Why_ty.print ty1;
- TTinfix(te1,s,te2) , ty1
- | Why_ty.Treal, Why_ty.Treal ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpBin type %a@\n"
- Why_ty.print ty2;
- TTinfix(te1,s,te2), ty2
- | Why_ty.Tint, _ -> error (ShouldHaveType(ty2,Why_ty.Tint)) t2.pp_loc
- | Why_ty.Treal, _ -> error (ShouldHaveType(ty2,Why_ty.Treal)) t2.pp_loc
- | _ -> error (ShouldHaveTypeIntorReal ty1) t1.pp_loc
- end
- | PPinfix(t1, PPmod, t2) ->
- begin
- let s = symbol_of PPmod in
- let te1 = type_term env t1 in
- let te2 = type_term env t2 in
- let ty1 = Why_ty.shorten te1.c.tt_ty in
- let ty2 = Why_ty.shorten te2.c.tt_ty in
- match ty1, ty2 with
- | Why_ty.Tint, Why_ty.Tint ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpMod type %a@\n"
- Why_ty.print ty1;
- TTinfix(te1,s,te2) , ty1
- | _ -> error (ShouldHaveTypeInt ty1) t1.pp_loc
- end
- | PPprefix(PPneg, {pp_desc=PPconst (ConstInt n)}) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpUnarith type %a@\n"
- Why_ty.print Why_ty.Tint;
- TTconst(Tint ("-"^n)), Why_ty.Tint
- | PPprefix(PPneg, {pp_desc=PPconst (ConstReal n)}) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpUnarith type %a@\n"
- Why_ty.print Why_ty.Treal;
- TTconst(Treal (Num.minus_num n)), Why_ty.Treal
- | PPprefix(PPneg, e) ->
- let te = type_term env e in
- let ty = Why_ty.shorten te.c.tt_ty in
- if ty<>Why_ty.Tint && ty<>Why_ty.Treal then
- error (ShouldHaveTypeIntorReal ty) e.pp_loc;
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpUnarith type %a@\n"
- Why_ty.print ty;
- TTprefix(Symbols.Op Symbols.Minus, te), ty
- | PPconcat(t1, t2) ->
- begin
- let te1 = type_term env t1 in
- let te2 = type_term env t2 in
- let ty1 = Why_ty.shorten te1.c.tt_ty in
- let ty2 = Why_ty.shorten te2.c.tt_ty in
- match ty1, ty2 with
- | Why_ty.Tbitv n , Why_ty.Tbitv m ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-OpConcat type %a@\n"
- Why_ty.print (Why_ty.Tbitv (n+m));
- TTconcat(te1, te2), Why_ty.Tbitv (n+m)
- | Why_ty.Tbitv _ , _ -> error (ShouldHaveTypeBitv ty2) t2.pp_loc
- | _ , Why_ty.Tbitv _ -> error (ShouldHaveTypeBitv ty1) t1.pp_loc
- | _ -> error (ShouldHaveTypeBitv ty1) t1.pp_loc
- end
- | PPextract(e, ({pp_desc=PPconst(ConstInt i)} as ei),
- ({pp_desc=PPconst(ConstInt j)} as ej)) ->
- begin
- let te = type_term env e in
- let tye = Why_ty.shorten te.c.tt_ty in
- let i = int_of_string i in
- let j = int_of_string j in
- match tye with
- | Why_ty.Tbitv n ->
- if i>j then error (BitvExtract(i,j)) loc;
- if j>=n then error (BitvExtractRange(n,j) ) loc;
- let tei = type_term env ei in
- let tej = type_term env ej in
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-OpExtract type %a@\n"
- Why_ty.print (Why_ty.Tbitv (j-i+1));
- TTextract(te, tei, tej), Why_ty.Tbitv (j-i+1)
- | _ -> error (ShouldHaveType(tye,Why_ty.Tbitv (j+1))) loc
- end
- | PPget (t1, t2) ->
- begin
- let te1 = type_term env t1 in
- let te2 = type_term env t2 in
- let tyarray = Why_ty.shorten te1.c.tt_ty in
- let tykey2 = Why_ty.shorten te2.c.tt_ty in
- match tyarray with
- | Why_ty.Tfarray (tykey,tyval) ->
- begin try
- Why_ty.unify tykey tykey2;
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-OpGet type %a@\n"
- Why_ty.print tyval;
- TTget(te1, te2), tyval
- with
- | Why_ty.TypeClash(t1,t2) ->
- error (Unification(t1,t2)) loc
- end
- | _ -> error ShouldHaveTypeArray t1.pp_loc
- end
- | PPset (t1, t2, t3) ->
- begin
- let te1 = type_term env t1 in
- let te2 = type_term env t2 in
- let te3 = type_term env t3 in
- let ty1 = Why_ty.shorten te1.c.tt_ty in
- let tykey2 = Why_ty.shorten te2.c.tt_ty in
- let tyval2 = Why_ty.shorten te3.c.tt_ty in
- try
- match ty1 with
- | Why_ty.Tfarray (tykey,tyval) ->
- Why_ty.unify tykey tykey2;Why_ty.unify tyval tyval2;
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-OpSet type %a@\n"
- Why_ty.print ty1;
- TTset(te1, te2, te3), ty1
- | _ -> error ShouldHaveTypeArray t1.pp_loc
- with
- | Why_ty.TypeClash(t, t') ->
- error (Unification(t, t')) loc
- end
- | PPif(t1,t2,t3) ->
- begin
- let te1 = type_term env t1 in
- let ty1 = Why_ty.shorten te1.c.tt_ty in
- if not (Why_ty.equal ty1 Why_ty.Tbool) then
- error (ShouldHaveType(ty1,Why_ty.Tbool)) t1.pp_loc;
- let te2 = type_term env t2 in
- let te3 = type_term env t3 in
- let ty2 = Why_ty.shorten te2.c.tt_ty in
- let ty3 = Why_ty.shorten te3.c.tt_ty in
- if not (Why_ty.equal ty2 ty3) then
- error (ShouldHaveType(ty3,ty2)) t3.pp_loc;
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Ite type %a@\n" Why_ty.print ty2;
- TTapp(Symbols.name "ite",[te1;te2;te3]) , ty2
- end
- | PPdot(t, a) ->
- begin
- let te = type_term env t in
- let ty = Why_ty.shorten te.c.tt_ty in
- match ty with
- | Why_ty.Trecord {Why_ty.name=g; lbs=lbs} ->
- begin
- try
- let a = Hstring.make a in
- TTdot(te, a), Hstring.list_assoc a lbs
- with Not_found ->
- let g = Hstring.view g in
- error (ShouldHaveLabel(g,a)) t.pp_loc
- end
- | _ -> error (ShouldHaveTypeRecord ty) t.pp_loc
- end
- | PPrecord lbs ->
- begin
- let lbs =
- List.map (fun (lb, t) -> Hstring.make lb, type_term env t) lbs in
- let lbs = List.sort
- (fun (l1, _) (l2, _) -> Hstring.compare l1 l2) lbs in
- let ty = Types.from_labels env.Env.types lbs loc in
- let ty, _ = Why_ty.fresh (Why_ty.shorten ty) Why_ty.esubst in
- match ty with
- | Why_ty.Trecord {Why_ty.lbs=ty_lbs} ->
- begin
- try
- let lbs =
- List.map2
- (fun (s, te) (lb,ty_lb)->
- Why_ty.unify te.c.tt_ty ty_lb;
- lb, te) lbs ty_lbs
- in
- TTrecord(lbs), ty
- with Why_ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) loc
- end
- | _ -> error ShouldBeARecord loc
- end
- | PPwith(e, lbs) ->
- begin
- let te = type_term env e in
- let lbs =
- List.map
- (fun (lb, t) -> Hstring.make lb, (type_term env t, t.pp_loc)) lbs in
- let ty = Why_ty.shorten te.c.tt_ty in
- match ty with
- | Why_ty.Trecord {Why_ty.lbs=ty_lbs} ->
- let nlbs =
- List.map
- (fun (lb, ty_lb) ->
- try
- let v, _ = Hstring.list_assoc lb lbs in
- Why_ty.unify ty_lb v.c.tt_ty;
- lb, v
- with
- | Not_found ->
- lb, {c = { tt_desc = TTdot(te, lb); tt_ty = ty_lb};
- annot = te.annot }
- | Why_ty.TypeClash(t1,t2) ->
- error (Unification(t1,t2)) loc
- ) ty_lbs
- in
- List.iter
- (fun (lb, _) ->
- try ignore (Hstring.list_assoc lb ty_lbs)
- with Not_found -> error (NoLabelInType(lb, ty)) loc) lbs;
- TTrecord(nlbs), ty
- | _ -> error ShouldBeARecord loc
- end
- | PPlet(x, t1, t2) ->
- let te1 = type_term env t1 in
- let ty1 = Why_ty.shorten te1.c.tt_ty in
- let env = Env.add env [x] Symbols.name ty1 in
- let te2 = type_term env t2 in
- let ty2 = Why_ty.shorten te2.c.tt_ty in
- let s, _ = Env.find env x in
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-Let type %a@\n" Why_ty.print ty2;
- TTlet(s, te1, te2), ty2
-
- (* | PPnamed(lbl, t) -> *)
- (* let te = type_term env t in *)
- (* te.c.tt_desc, te.c.tt_ty *)
-
- | PPnamed (lbl, t) ->
- let te = type_term env t in
- let ty = Why_ty.shorten te.c.tt_ty in
- let lbl = Hstring.make lbl in
- TTnamed (lbl, te), ty
-
- | PPcast (t,ty) ->
- let ty = Types.ty_of_pp loc env.Env.types None ty in
- let te = type_term env t in
- begin try
- Why_ty.unify te.c.tt_ty ty;
- te.c.tt_desc, Why_ty.shorten te.c.tt_ty
- with
- | Why_ty.TypeClash(t1,t2) ->
- error (Unification(t1,t2)) loc
- end
-
- | _ -> error SyntaxError loc
-
-
-let rec join_forall f = match f.pp_desc with
- | PPforall(vs, ty, trs1, f) ->
- let tyvars,trs2,f = join_forall f in
- (vs,ty)::tyvars , trs1@trs2 , f
- | PPforall_named (vs, ty, trs1, f) ->
- let vs = List.map fst vs in
- join_forall {f with pp_desc = PPforall (vs, ty, trs1, f)}
- | PPnamed(lbl, f) ->
- join_forall f
- | _ -> [] , [] , f
-
-let rec join_exists f = match f.pp_desc with
- | PPexists (vars, ty, trs1, f) ->
- let tyvars,trs2,f = join_exists f in
- (vars, ty)::tyvars , trs1@trs2, f
- | PPexists_named (vs, ty, trs1, f) ->
- let vs = List.map fst vs in
- join_exists {f with pp_desc = PPexists (vs, ty, trs1, f)}
- | PPnamed (_, f) -> join_exists f
- | _ -> [] , [] , f
-
-let rec type_form env f =
- let rec type_pp_desc pp_desc = match pp_desc with
- | PPconst ConstTrue ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-True$_F$@\n";
- TFatom {c=TAtrue; annot=new_id ()}, Sy.empty
- | PPconst ConstFalse ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-False$_F$@\n";
- TFatom {c=TAfalse; annot=new_id ()}, Sy.empty
- | PPvar p ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Var$_F$@\n";
- let r = begin
- match Env.fresh_type env p f.pp_loc with
- | s, { Env.args = []; result = Why_ty.Tbool} ->
- let t2 = {c = {tt_desc=TTconst Ttrue;tt_ty=Why_ty.Tbool};
- annot = new_id ()} in
- let t1 = {c = {tt_desc=TTvar s; tt_ty=Why_ty.Tbool};
- annot = new_id ()} in
- TFatom {c = TAeq [t1;t2]; annot=new_id ()}
- | _ -> error (NotAPropVar p) f.pp_loc
- end in r, freevars_form r
-
- | PPapp(p,args ) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-App$_F$@\n";
- let r =
- begin
- let te_args = List.map (type_term env) args in
- let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in
- match Env.fresh_type env p f.pp_loc with
- | s , { Env.args = lt; result = Why_ty.Tbool} ->
- begin
- try
- List.iter2 Why_ty.unify lt lt_args;
- if p = "<=" || p = "<" then
- TFatom { c = TAbuilt(Hstring.make p,te_args);
- annot=new_id ()}
- else
- let t1 = {
- c = {tt_desc=TTapp(s,te_args); tt_ty=Why_ty.Tbool};
- annot=new_id (); }
- in
- TFatom { c = TApred t1; annot=new_id () }
- with
- | Why_ty.TypeClash(t1,t2) ->
- error (Unification(t1,t2)) f.pp_loc
- | Invalid_argument _ ->
- error (WrongNumberofArgs p) f.pp_loc
- end
- | _ -> error (NotAPredicate p) f.pp_loc
- end
- in r, freevars_form r
-
- | PPdistinct (args) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Distinct$_F$@\n";
- let r =
- begin
- let te_args = List.map (type_term env) args in
- let lt_args = List.map (fun {c={tt_ty=t}} -> t) te_args in
- try
- let t = match lt_args with
- | t::_ -> t
- | [] ->
- error (WrongNumberofArgs "distinct") f.pp_loc
- in
- List.iter (Why_ty.unify t) lt_args;
- TFatom { c = TAdistinct te_args; annot=new_id () }
- with
- | Why_ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc
- end
- in r, freevars_form r
-
- | PPinfix
- ({pp_desc = PPinfix (_, (PPlt|PPle|PPgt|PPge|PPeq|PPneq), a)} as p,
- (PPlt | PPle | PPgt | PPge | PPeq | PPneq as r), b) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpComp$_F$@\n";
- let r =
- let q = { pp_desc = PPinfix (a, r, b); pp_loc = f.pp_loc } in
- let f1,_ = type_form env p in
- let f2,_ = type_form env q in
- TFop(OPand, [f1;f2])
- in r, freevars_form r
- | PPinfix(t1, (PPeq | PPneq as op), t2) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpBin$_F$@\n";
- let r =
- let tt1 = type_term env t1 in
- let tt2 = type_term env t2 in
- try
- Why_ty.unify tt1.c.tt_ty tt2.c.tt_ty;
- match op with
- | PPeq -> TFatom {c = TAeq [tt1; tt2]; annot = new_id()}
- | PPneq -> TFatom {c = TAneq [tt1; tt2]; annot = new_id()}
- | _ -> assert false
- with Why_ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc
- in r, freevars_form r
- | PPinfix(t1, (PPlt | PPgt | PPge | PPle as op), t2) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpComp$_F$@\n";
- let r =
- let tt1 = type_term env t1 in
- let tt2 = type_term env t2 in
- try
- Why_ty.unify tt1.c.tt_ty tt2.c.tt_ty;
- let ty = Why_ty.shorten tt1.c.tt_ty in
- match ty with
- | Why_ty.Tint | Why_ty.Treal ->
- let top =
- match op with
- | PPlt -> TAlt [tt1; tt2]
- | PPgt -> TAlt [tt2; tt1]
- | PPle -> TAle [tt1; tt2]
- | PPge -> TAle [tt2; tt1]
- | PPeq -> TAeq [tt1; tt2]
- | PPneq -> TAneq [tt1; tt2]
- | _ -> assert false
- in
- TFatom {c = top; annot=new_id ()}
- | _ -> error (ShouldHaveTypeIntorReal ty) t1.pp_loc
- with Why_ty.TypeClash(t1,t2) -> error (Unification(t1,t2)) f.pp_loc
- in r, freevars_form r
- | PPinfix(f1,op ,f2) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpConnectors$_F$@\n";
- begin
- let f1,fv1 = type_form env f1 in
- let f2,fv2 = type_form env f2 in
- ((match op with
- | PPand ->
- TFop(OPand,[f1;f2])
- | PPor -> TFop(OPor,[f1;f2])
- | PPimplies -> TFop(OPimp,[f1;f2])
- | PPiff -> TFop(OPiff,[f1;f2])
- | _ -> assert false), Sy.union fv1 fv2)
- end
- | PPprefix(PPnot,f) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-OpNot$_F$@\n";
- let f, fv = type_form env f in TFop(OPnot,[f]),fv
- | PPif(f1,f2,f3) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Ite$_F$@\n";
- let f1 = type_term env f1 in
- let f2,fv2 = type_form env f2 in
- let f3,fv3 = type_form env f3 in
- TFop(OPif f1,[f2;f3]), Sy.union fv2 fv3
- | PPnamed(lbl,f) ->
- let f, fv = type_form env f in
- let lbl = Hstring.make lbl in
- TFnamed(lbl, f), fv
- | PPforall _ | PPexists _ ->
- let ty_vars, ty, triggers, f' =
- match pp_desc with
- | PPforall(vars,ty,triggers,f') ->
- let ty_vars, triggers', f' = join_forall f' in
- (vars, ty)::ty_vars,ty ,triggers@triggers', f'
- | PPexists(vars,ty,triggers,f') ->
- let ty_vars, triggers', f' = join_exists f' in
- (vars, ty)::ty_vars, ty, triggers@triggers', f'
- | _ -> assert false
- in
- let env' =
- List.fold_left
- (fun env (lv, pp_ty) ->
- Env.add_var env lv pp_ty f.pp_loc) env ty_vars in
- let f', fv = type_form env' f' in
- let ty_triggers = List.map (List.map (type_term env')) triggers in
- let upbvars = Env.list_of env in
- let bvars =
- List.fold_left
- (fun acc (l,_) ->
- let tys = List.map (Env.find env') l in
- let tys = List.filter (fun (s,_) -> Sy.mem s fv) tys in
- tys @ acc) [] ty_vars in
- let qf_form = {
- qf_upvars = upbvars ;
- qf_bvars = bvars ;
- qf_triggers = ty_triggers ;
- qf_form = f'}
- in
- (match pp_desc with
- | PPforall _ ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Forall$_F$@\n";
- TFforall qf_form
- | PPexists _ ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Exists$_F$@\n";
- Existantial.make qf_form
- | _ -> assert false),
- (List.fold_left (fun acc (l,_) -> Sy.remove l acc) fv bvars)
- | PPlet (var,t,f) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-Let$_F$@\n";
- let {c= { tt_ty = ttype }} as tt = type_term env t in
- let svar = Symbols.var var in
- let up = Env.list_of env in
- let env =
- {env with
- Env.var_map = MString.add var (svar, ttype) env.Env.var_map} in
- let f,fv = type_form env f in
- TFlet (up ,svar , tt, f), freevars_term (Sy.remove svar fv) tt
-
-
- (* Remove labels : *)
- | PPforall_named (lx, tys, trs, f) ->
- let lx = List.map fst lx in
- type_pp_desc (PPforall (lx, tys, trs, f))
- | PPexists_named (lx, tys, trs, f) ->
- let lx = List.map fst lx in
- type_pp_desc (PPexists (lx, tys, trs, f))
-
- | PPcheck _ | PPcut _ -> assert false
-
- | _ ->
- let te1 = type_term env f in
- let ty = te1.c.tt_ty in
- match ty with
- | Why_ty.Tbool ->
- let te2 = {c = {tt_desc=TTconst Ttrue;tt_ty=Why_ty.Tbool};
- annot = new_id ()}
- in
- let r = TFatom {c = TAeq [te1;te2]; annot=new_id ()} in
- r, freevars_form r
- | _ -> error ShouldHaveTypeProp f.pp_loc
- in
- let form, vars = type_pp_desc f.pp_desc in
- {c = form; annot = new_id ()}, vars
-
-
-let make_rules loc f = match f.c with
- | TFforall {qf_bvars = vars; qf_form = {c = TFatom {c = TAeq [t1; t2]}}} ->
- {rwt_vars = vars; rwt_left = t1; rwt_right = t2}
- | TFatom {c = TAeq [t1; t2]} ->
- {rwt_vars = []; rwt_left = t1; rwt_right = t2}
- | _ -> error SyntaxError loc
-
-
-let fresh_var =
- let cpt = ref 0 in
- fun x -> incr cpt; ("_"^x^(string_of_int !cpt))
-
-let rec alpha_renaming_b s f =
- { f with pp_desc = alpha_rec s f.pp_desc }
-and alpha_rec ((up, m) as s) f =
- match f with
- | PPvar x ->
- begin
- try
- let y = MString.find x m in
- PPvar y
- with Not_found -> f
- end
- | PPapp(k, l) ->
- PPapp(k, List.map (alpha_renaming_b s) l)
- | PPdistinct l ->
- PPdistinct (List.map (alpha_renaming_b s) l)
- | PPconst _ -> f
- | PPinfix(f1, op, f2) ->
- let ff1 = alpha_renaming_b s f1 in
- let ff2 = alpha_renaming_b s f2 in
- PPinfix(ff1, op, ff2)
- | PPprefix(op, f1) ->
- PPprefix(op, alpha_renaming_b s f1)
- | PPget(f1,f2) ->
- let ff1 = alpha_renaming_b s f1 in
- let ff2 = alpha_renaming_b s f2 in
- PPget(ff1, ff2)
- | PPset(f1, f2, f3) ->
- let ff1 = alpha_renaming_b s f1 in
- let ff2 = alpha_renaming_b s f2 in
- let ff3 = alpha_renaming_b s f3 in
- PPset(ff1, ff2, ff3)
- | PPextract(f1, f2, f3) ->
- let ff1 = alpha_renaming_b s f1 in
- let ff2 = alpha_renaming_b s f2 in
- let ff3 = alpha_renaming_b s f3 in
- PPextract(ff1, ff2, ff3)
- | PPconcat(f1, f2) ->
- let ff1 = alpha_renaming_b s f1 in
- let ff2 = alpha_renaming_b s f2 in
- PPconcat(ff1, ff2)
- | PPif(f1, f2, f3) ->
- let ff1 = alpha_renaming_b s f1 in
- let ff2 = alpha_renaming_b s f2 in
- let ff3 = alpha_renaming_b s f3 in
- PPif(ff1, ff2, ff3)
- | PPnamed(n, f1) ->
- PPnamed(n, alpha_renaming_b s f1)
- | PPforall(xs, ty, trs, f1) ->
- let xs1, xs2 = List.partition (fun x -> S.mem x up) xs in
- let nv = List.map fresh_var xs1 in
- let m = List.fold_left2
- (fun m x nx -> MString.add x nx m) m xs1 nv in
- let xs = nv@xs2 in
- let up = List.fold_left (fun up x -> S.add x up) up xs in
- let s = (up, m) in
- let ff1 = alpha_renaming_b s f1 in
- let trs = List.map (List.map (alpha_renaming_b s)) trs in
- PPforall(xs, ty, trs, ff1)
- | PPforall_named (xs, ty, trs, f1) ->
- let xs1, xs2 = List.partition (fun (x, _) -> S.mem x up) xs in
- let nv = List.map (fun (x, lbl) -> fresh_var x, lbl) xs1 in
- let m = List.fold_left2
- (fun m (x,_) (nx, _) -> MString.add x nx m) m xs1 nv in
- let xs = nv@xs2 in
- let up = List.fold_left (fun up (x, _) -> S.add x up) up xs in
- let s = (up, m) in
- let ff1 = alpha_renaming_b s f1 in
- let trs = List.map (List.map (alpha_renaming_b s)) trs in
- PPforall_named (xs, ty, trs, ff1)
- | PPdot(f1, a) ->
- PPdot(alpha_renaming_b s f1, a)
- | PPrecord l ->
- PPrecord (List.map (fun (a,e) -> a, alpha_renaming_b s e) l)
- | PPwith(e, l) ->
- let l = List.map (fun (a,e) -> a, alpha_renaming_b s e) l in
- PPwith(alpha_renaming_b s e, l)
- | PPlet(x, f1, f2) ->
- let ff1 = alpha_renaming_b s f1 in
- let s, x =
- if S.mem x up then
- let nx = fresh_var x in
- let m = MString.add x nx m in
- let up = S.add nx up in
- (up, m), nx
- else
- (S.add x up, m), x
- in
- let ff2 = alpha_renaming_b s f2 in
- PPlet(x, ff1, ff2)
-
- | PPexists(lx, ty, trs, f1) ->
- let s, lx =
- List.fold_left
- (fun (s, lx) x ->
- if S.mem x up then
- let nx = fresh_var x in
- let m = MString.add x nx m in
- let up = S.add nx up in
- (up, m), nx :: lx
- else
- (S.add x up, m), x :: lx)
- (s, []) lx
- in
- let trs = List.map (List.map (alpha_renaming_b s)) trs in
- let ff1 = alpha_renaming_b s f1 in
- PPexists(lx, ty, trs, ff1)
- | PPexists_named (lx, ty, trs, f1) ->
- let s, lx =
- List.fold_left
- (fun (s, lx) (x, lbl) ->
- if S.mem x up then
- let nx = fresh_var x in
- let m = MString.add x nx m in
- let up = S.add nx up in
- (up, m), (nx, lbl) :: lx
- else
- (S.add x up, m), (x, lbl) :: lx)
- (s, []) lx
- in
- let ff1 = alpha_renaming_b s f1 in
- let trs = List.map (List.map (alpha_renaming_b s)) trs in
- PPexists_named (lx, ty, trs, ff1)
- | PPcheck f' -> PPcheck (alpha_renaming_b s f')
- | PPcut f' -> PPcut (alpha_renaming_b s f')
- | PPcast (f',ty) -> PPcast (alpha_renaming_b s f',ty)
-
-let alpha_renaming = alpha_renaming_b (S.empty, MString.empty)
-
-
-let alpha_renaming_env env =
- let up = MString.fold (fun s _ up -> S.add s up)
- env.Env.logics S.empty in
- let up = MString.fold (fun s _ up -> S.add s up) env.Env.var_map up in
- alpha_renaming_b (up, MString.empty)
-
-
-let inv_infix = function
- | PPand -> PPor | PPor -> PPand | _ -> assert false
-
-let rec elim_toplevel_forall env bnot f =
- (* bnot = true : nombre impaire de not *)
- match f.pp_desc with
- | PPforall (lv, pp_ty, _, f) when bnot->
- elim_toplevel_forall (Env.add_names env lv pp_ty f.pp_loc) bnot f
-
- | PPforall_named (lvb, pp_ty, _, f) when bnot->
- elim_toplevel_forall (Env.add_names_lbl env lvb pp_ty f.pp_loc) bnot f
-
- | PPinfix (f1, PPand, f2) when not bnot ->
- let f1 , env = elim_toplevel_forall env false f1 in
- let f2 , env = elim_toplevel_forall env false
- (alpha_renaming_env env f2) in
- { f with pp_desc = PPinfix(f1, PPand , f2)}, env
-
- | PPinfix (f1, PPor, f2) when bnot ->
- let f1 , env = elim_toplevel_forall env true f1 in
- let f2 , env = elim_toplevel_forall env true
- (alpha_renaming_env env f2) in
- { f with pp_desc = PPinfix(f1, PPand , f2)}, env
-
- | PPinfix (f1, PPimplies, f2) when bnot ->
- let f1 , env = elim_toplevel_forall env false f1 in
- let f2 , env = elim_toplevel_forall env true
- (alpha_renaming_env env f2) in
- { f with pp_desc = PPinfix(f1,PPand,f2)}, env
-
- | PPprefix (PPnot, f) -> elim_toplevel_forall env (not bnot) f
-
-
- | _ when bnot ->
- { f with pp_desc = PPprefix (PPnot, f) }, env
-
- | _ -> f , env
-
-
-let rec intro_hypothesis env valid_mode f =
- match f.pp_desc with
- | PPinfix(f1,PPimplies,f2) when valid_mode ->
- let ((f1, env) as f1_env) =
- elim_toplevel_forall env (not valid_mode) f1 in
- let axioms, goal = intro_hypothesis env valid_mode
- (alpha_renaming_env env f2) in
- f1_env::axioms, goal
- | PPforall (lv, pp_ty, _, f) when valid_mode ->
- intro_hypothesis (Env.add_names env lv pp_ty f.pp_loc) valid_mode f
- | PPexists (lv, pp_ty, _, f) when not valid_mode->
- intro_hypothesis (Env.add_names env lv pp_ty f.pp_loc) valid_mode f
- | PPforall_named (lvb, pp_ty, _, f) when valid_mode ->
- intro_hypothesis (Env.add_names_lbl env lvb pp_ty f.pp_loc) valid_mode f
- | PPexists_named (lvb, pp_ty, _, f) when not valid_mode->
- intro_hypothesis (Env.add_names_lbl env lvb pp_ty f.pp_loc) valid_mode f
- | _ ->
- let f_env = elim_toplevel_forall env valid_mode f in
- [] , f_env
-
-let fresh_hypothesis_name =
- let cpt = ref 0 in
- fun sort ->
- incr cpt;
- match sort with
- | Thm -> "@H"^(string_of_int !cpt)
- | _ -> "@L"^(string_of_int !cpt)
-
-let fresh_check_name =
- let cpt = ref 0 in fun () -> incr cpt; "check_"^(string_of_int !cpt)
-
-let fresh_cut_name =
- let cpt = ref 0 in fun () -> incr cpt; "cut_"^(string_of_int !cpt)
-
-let check_duplicate_params l =
- let rec loop l acc =
- match l with
- | [] -> ()
- | (loc,x,_)::rem ->
- if List.mem x acc then
- error (ClashParam x) loc
- else loop rem (x::acc)
- in
- loop l []
-
-let rec make_pred loc trs f = function
- [] -> f
- | [x,t] ->
- { pp_desc = PPforall([x],t,trs,f) ; pp_loc = loc }
- | (x,t)::l ->
- { pp_desc = PPforall([x],t,[],(make_pred loc trs f l)) ;
- pp_loc = loc }
-
-let rec max_terms acc f =
- match f.pp_desc with
- | PPinfix(f1, ( PPand | PPor | PPimplies | PPiff ), f2)
- | PPconcat(f1, f2) ->
- let acc = max_terms acc f1 in
- max_terms acc f2
-
- | PPforall(_, _, _, _)
- | PPexists(_, _, _, _)
- | PPforall_named(_, _, _, _)
- | PPexists_named(_, _, _, _)
- | PPvar _
- | PPlet(_, _, _)
- | PPinfix(_, _, _) -> raise Exit
-
- | PPif(f1, f2, f3) ->
- let acc = max_terms acc f1 in
- let acc = max_terms acc f2 in
- max_terms acc f3
- | PPextract(f1, _, _) | PPprefix(_, f1)
- | PPnamed(_, f1) ->
- max_terms acc f1
- | _ -> f::acc
-
-let max_terms f = try max_terms [] f with Exit -> []
-
-let rec mono_term {c = {tt_ty=tt_ty; tt_desc=tt_desc}; annot = id} =
- let tt_desc = match tt_desc with
- | TTconst _ | TTvar _ ->
- tt_desc
- | TTinfix (t1, sy, t2) ->
- TTinfix(mono_term t1, sy, mono_term t2)
- | TTprefix (sy,t) ->
- TTprefix(sy, mono_term t)
- | TTapp (sy,tl) ->
- TTapp (sy, List.map mono_term tl)
- | TTget (t1,t2) ->
- TTget (mono_term t1, mono_term t2)
- | TTset (t1,t2,t3) ->
- TTset(mono_term t1, mono_term t2, mono_term t3)
- | TTextract (t1,t2,t3) ->
- TTextract(mono_term t1, mono_term t2, mono_term t3)
- | TTconcat (t1,t2)->
- TTconcat (mono_term t1, mono_term t2)
- | TTdot (t1, a) ->
- TTdot (mono_term t1, a)
- | TTrecord lbs ->
- TTrecord (List.map (fun (x, t) -> x, mono_term t) lbs)
- | TTlet (sy,t1,t2)->
- TTlet (sy, mono_term t1, mono_term t2)
- | TTnamed (lbl, t)->
- TTnamed (lbl, mono_term t)
- in
- { c = {tt_ty = Why_ty.monomorphize tt_ty; tt_desc=tt_desc}; annot = id}
-
-
-let monomorphize_atom tat =
- let c = match tat.c with
- | TAtrue | TAfalse -> tat.c
- | TAeq tl -> TAeq (List.map mono_term tl)
- | TAneq tl -> TAneq (List.map mono_term tl)
- | TAle tl -> TAle (List.map mono_term tl)
- | TAlt tl -> TAlt (List.map mono_term tl)
- | TAdistinct tl -> TAdistinct (List.map mono_term tl)
- | TApred t -> TApred (mono_term t)
- | TAbuilt (hs, tl) -> TAbuilt(hs, List.map mono_term tl)
- in
- { tat with c = c }
-
-let monomorphize_var (s,ty) = s, Why_ty.monomorphize ty
-
-let rec monomorphize_form tf =
- let c = match tf.c with
- | TFatom tat -> TFatom (monomorphize_atom tat)
- | TFop (oplogic , tfl) ->
- TFop(oplogic, List.map monomorphize_form tfl)
- | TFforall qf ->
- TFforall
- { qf_bvars = List.map monomorphize_var qf.qf_bvars;
- qf_upvars = List.map monomorphize_var qf.qf_upvars;
- qf_form = monomorphize_form qf.qf_form;
- qf_triggers = List.map (List.map mono_term) qf.qf_triggers}
- | TFexists qf ->
- TFexists
- { qf_bvars = List.map monomorphize_var qf.qf_bvars;
- qf_upvars = List.map monomorphize_var qf.qf_upvars;
- qf_form = monomorphize_form qf.qf_form;
- qf_triggers = List.map (List.map mono_term) qf.qf_triggers}
- | TFlet (l, sy, tt, tf) ->
- let l = List.map monomorphize_var l in
- TFlet(l,sy, mono_term tt, monomorphize_form tf)
- | TFnamed (hs,tf) ->
- TFnamed(hs, monomorphize_form tf)
- in
- { tf with c = c }
-
-let axioms_of_rules keep_triggers loc name lf acc env =
- let acc =
- List.fold_left
- (fun acc (f, _) ->
- let f = Triggers.make keep_triggers false f in
- let name = (Common.fresh_string ()) ^ "_" ^ name in
- let td = {c = TAxiom(loc,name,false,f); annot = new_id () } in
- (td, env)::acc
- ) acc lf
- in
- acc, env
-
-
-
-let type_hypothesis keep_triggers acc env_f loc sort f =
- let f,_ = type_form env_f f in
- let f = monomorphize_form f in
- let f = Triggers.make keep_triggers false f in
- let td =
- {c = TAxiom(loc, fresh_hypothesis_name sort, false,f);
- annot = new_id () } in
- (td, env_f)::acc
-
-
-let type_goal keep_triggers acc env_g loc sort n goal =
- let goal, _ = type_form env_g goal in
- let goal = monomorphize_form goal in
- let goal = Triggers.make keep_triggers true goal in
- let td = {c = TGoal(loc, sort, n, goal); annot = new_id () } in
- (td, env_g)::acc
-
-
-let rec type_and_intro_goal keep_triggers acc env loc sort n f =
- let axioms, (goal, env_g) =
- intro_hypothesis env (not (!smtfile or !smt2file or !satmode)) f in
- let acc =
- List.fold_left
- (fun acc (f, env_f) -> match f.pp_desc with
- | PPcut f ->
- let acc = type_and_intro_goal keep_triggers acc env_f
- loc Cut (fresh_cut_name ()) f in
- type_hypothesis keep_triggers acc env_f loc sort f
-
- | PPcheck f ->
- type_and_intro_goal keep_triggers acc env_f
- loc Check (fresh_check_name ()) f
-
- | _ ->
- type_hypothesis keep_triggers acc env_f loc sort f
- ) acc axioms
- in
- type_goal keep_triggers acc env_g loc sort n goal
-
-
-let type_decl keep_triggers (acc, env) d =
- Types.to_tyvars := MString.empty;
- try
- match d with
- | Logic (loc, ac, lp, pp_ty) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-LogicFun$_F$@\n";
- let env' = Env.add_logics env ac lp pp_ty loc in
- let lp = List.map fst lp in
- let td = {c = TLogic(loc,lp,pp_ty); annot = new_id () } in
- (td, env)::acc, env'
-
- | Axiom(loc,name,inv,f) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-AxiomDecl$_F$@\n";
- let f, _ = type_form env f in
- let f = Triggers.make keep_triggers false f in
- let td = {c = TAxiom(loc,name,inv,f); annot = new_id () } in
- (td, env)::acc, env
-
- | Rewriting(loc, name, lr) ->
- let lf = List.map (type_form env) lr in
- if Options.rewriting () then
- let rules = List.map (fun (f,_) -> make_rules loc f) lf in
- let td = {c = TRewriting(loc, name, rules); annot = new_id () } in
- (td, env)::acc, env
- else
- axioms_of_rules keep_triggers loc name lf acc env
-
-
- | Goal(loc, n, f) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-GoalDecl$_F$@\n";
- (*let f = move_up f in*)
- let f = alpha_renaming_env env f in
- type_and_intro_goal keep_triggers acc env loc Thm n f, env
-
- | Predicate_def(loc,n,l,e)
- | Function_def(loc,n,l,_,e) ->
- check_duplicate_params l;
- let ty =
- let l = List.map (fun (_,_,x) -> x) l in
- match d with
- Function_def(_,_,_,t,_) -> PFunction(l,t)
- | _ -> PPredicate l
- in
- let l = List.map (fun (_,x,t) -> (x,t)) l in
-
- let env = Env.add_logics env Symbols.Other [n] ty loc in (* TODO *)
-
- let n = fst n in
-
- let lvar = List.map (fun (x,_) -> {pp_desc=PPvar x;pp_loc=loc}) l in
- let p = {pp_desc=PPapp(n,lvar) ; pp_loc=loc } in
- let infix = match d with Function_def _ -> PPeq | _ -> PPiff in
- let f = { pp_desc = PPinfix(p,infix,e) ; pp_loc = loc } in
- (* le trigger [[p]] ne permet pas de replier la definition,
- donc on calcule les termes maximaux de la definition pour
- laisser une possibilite de replier *)
- let trs = max_terms e in
- let f = make_pred loc ([p]::[trs]) f l in
- let f,_ = type_form env f in
- let f = Triggers.make keep_triggers false f in
- let td =
- match d with
- | Function_def(_,_,_,t,_) ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-LogicFun$_F$@\n";
- TFunction_def(loc,n,l,t,f)
- | _ ->
- if rules () = 1 then
- fprintf fmt "[rule] TR-Typing-LogicPred$_F$@\n";
- TPredicate_def(loc,n,l,f)
- in
- let td_a = { c = td; annot=new_id () } in
- (td_a, env)::acc, env
-
- | TypeDecl(loc, ls, s, body) ->
- if rules () = 1 then fprintf fmt "[rule] TR-Typing-TypeDecl$_F$@\n";
- let env1 = Env.add_type_decl env ls s body loc in
- let td1 = TTypeDecl(loc, ls, s, body) in
- let td1_a = { c = td1; annot=new_id () } in
- let tls = List.map (fun s -> PPTvarid (s,loc)) ls in
- let ty = PFunction([], PPTexternal(tls, s, loc)) in
- match body with
- | Enum lc ->
- let lcl = List.map (fun c -> c, "") lc in (* TODO change this *)
- let env2 = Env.add_logics env1 Symbols.Constructor lcl ty loc in
- let td2 = TLogic(loc, lc, ty) in
- let td2_a = { c = td2; annot=new_id () } in
- (td1_a, env1)::(td2_a,env2)::acc, env2
- | _ -> (td1_a, env1)::acc, env1
-
- with Warning(e,loc) ->
- Loc.report std_formatter loc;
- acc, env
-
-let file keep_triggers env ld =
- let ltd, env =
- List.fold_left
- (fun acc d -> type_decl keep_triggers acc d)
- ([], env) ld
- in
- List.rev ltd, env
-
-let is_local_hyp s =
- try String.sub s 0 2 = "@L" with Invalid_argument _ -> false
-
-let is_global_hyp s =
- try String.sub s 0 2 = "@H" with Invalid_argument _ -> false
-
-let split_goals l =
- let _, _, _, ret =
- List.fold_left
- (fun (ctx, global_hyp, local_hyp, ret) ( (td, env) as x) ->
- match td.c with
- | TGoal (_, (Check | Cut), _, _) ->
- ctx, global_hyp, [], (x::(local_hyp@global_hyp@ctx))::ret
-
- | TGoal (_, _, _, _) ->
- ctx, [], [], (x::(local_hyp@global_hyp@ctx))::ret
-
- | TAxiom (_, s, _, _) when is_global_hyp s ->
- ctx, x::global_hyp, local_hyp, ret
-
- | TAxiom (_, s, _, _) when is_local_hyp s ->
- ctx, global_hyp, x::local_hyp, ret
-
- | _ -> x::ctx, global_hyp, local_hyp, ret
- ) ([],[],[],[]) l
- in
- List.rev_map List.rev ret
-
-let term env vars t =
- let vmap =
- List.fold_left
- (fun m (s,ty)->
- let str = Symbols.to_string s in
- MString.add str (s,ty) m
- ) env.Env.var_map vars in
- let env = { env with Env.var_map = vmap } in
- type_term env t
-
-type env = Env.t
-
-let empty_env = Env.empty
diff --git a/src/inputlang/altergo/why_typing.mli b/src/inputlang/altergo/why_typing.mli
deleted file mode 100644
index 9e1b8c91f..000000000
--- a/src/inputlang/altergo/why_typing.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-open Why_ptree
-
-type env
-
-val empty_env : env
-
-val file : bool -> env -> file ->
- ((int tdecl, int) annoted * env) list * env
-
-val split_goals :
- ((int tdecl, int) annoted * env) list ->
- ((int tdecl, int) annoted * env) list list
-
-val term : env -> (Symbols.t * Ty.t) list -> Why_ptree.lexpr ->
- (int tterm, int) annoted
-
-val new_id : unit -> int
diff --git a/src/inputlang/dimacs_cnf/dimacs.mll b/src/inputlang/dimacs_cnf/dimacs.mll
deleted file mode 100644
index fcbba9ad7..000000000
--- a/src/inputlang/dimacs_cnf/dimacs.mll
+++ /dev/null
@@ -1,127 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-{
-open Popop
-type vars = Types.Cl.t array
-
-let init_vars nb_var : vars =
- let a = Array.make nb_var Bool._true in
- for i = 0 to nb_var - 1 do
- a.(i) <- Variable.fresh Bool.ty (Printf.sprintf "x%i" (i+1))
- done;
- a
-
-
-let get_lit vars i =
- let i = int_of_string i in
- let i,b = abs i - 1, i<0 in
- vars.(i),b
-
-exception SyntaxError of string
-
-let syntax_error s = raise (SyntaxError s)
-
-let () = Exn_printer.register (fun fmt e -> match e with
- | SyntaxError s -> Format.pp_print_string fmt s
- | _ -> raise e)
-
-}
-
-let newline = '\n'
-let space = [' ' '\t' '\r']+
-let digit = ['0'-'9']
-let sign = '-' | '+'
-let integer = sign? digit+
-
-rule find_header = parse
-| newline { Lexing.new_line lexbuf; find_header lexbuf }
-| space { find_header lexbuf }
-| 'p'
- space+ "cnf"
- space+ (digit+ as nb_var)
- space+ (digit+ as nb_cls) { int_of_string nb_var,
- int_of_string nb_cls }
-| 'c' [^'\n']* '\n' { Lexing.new_line lexbuf; find_header lexbuf }
-| _
- { syntax_error "Can't find header" }
-
-and clause vars acc = parse
-| newline { Lexing.new_line lexbuf; clause vars acc lexbuf }
-| space { clause vars acc lexbuf }
-| '0' { List.rev acc }
-| integer as i { clause vars ((get_lit vars i)::acc) lexbuf }
-| _ { syntax_error "Bad clause" }
-
-and file sched vars = parse
-| newline { Lexing.new_line lexbuf; file sched vars lexbuf }
-| space { file sched vars lexbuf }
-| '0' { file sched vars lexbuf }
-| integer as i { let lits = clause vars [get_lit vars i] lexbuf in
- let d = Scheduler.Scheduler.get_delayed sched in
- let cl = Bool.gen false lits in
- Solver.Delayed.register d cl;
- let pexp = Solver.Delayed.mk_pexp d Explanation.expfact () in
- Bool.set_true d pexp cl;
- Scheduler.Scheduler.flush_delayed sched;
- file sched vars lexbuf
- }
-| 'c' [^'\n']* ('\n' | eof) { Lexing.new_line lexbuf; file sched vars lexbuf }
-| eof { () }
-| _ { syntax_error "Bad clauses" }
-
-{
-
-type answer =
-| Sat
-| Unsat
-let parse sched s =
- let cin = open_in s in
- let lb = Lexing.from_channel cin in
- Loc.set_file s lb;
- let res =
- Loc.with_location (fun lexbuf ->
- let nb_vars, _ = find_header lexbuf in
- let vars = init_vars nb_vars in
- try
- file sched vars lexbuf;
- Scheduler.Scheduler.stop_delayed sched;
- Sat
- with Scheduler.Scheduler.Contradiction ->
- Unsat
- ) lb in
- if res = Unsat then raise Scheduler.Scheduler.Contradiction
-
-
-
-let check_file filename =
- let sched = Scheduler.new_env [Variable.th_register;
- Bool.th_register_alone] () in
- try
- parse sched filename;
- Scheduler.Scheduler.run_inf_step sched;
- Sat
- with Scheduler.Scheduler.Contradiction -> Unsat
-
-
-}
-
diff --git a/src/inputlang/smtlib2/COPYRIGHT b/src/inputlang/smtlib2/COPYRIGHT
deleted file mode 100644
index ccc09c777..000000000
--- a/src/inputlang/smtlib2/COPYRIGHT
+++ /dev/null
@@ -1,3 +0,0 @@
-The lexer, parser and ast have been written for Alt-Ergo from it seems
-the output generated by gt from the stlib grammar written by Aron
-Stump and Kyle Krchak for smtlib2
\ No newline at end of file
diff --git a/src/inputlang/smtlib2/popop_of_smtlib2.ml b/src/inputlang/smtlib2/popop_of_smtlib2.ml
deleted file mode 100644
index 48976ee80..000000000
--- a/src/inputlang/smtlib2/popop_of_smtlib2.ml
+++ /dev/null
@@ -1,247 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Types
-open Stdlib
-open Smtlib2_ast
-
-let debug_rename = Debug.register_flag
- ~desc:"for renaming the debug name of class"
- "rename"
-
-type benv = {
- ctr : Ty.Constr.t DStr.H.t;
- term: Types.Cl.t DStr.H.t;
-}
-
-exception Not_supported of Loc.position
-
-exception Unbound of (Loc.position * string)
-
-(** TODO check arity? *)
-let declare_sort benv name _arity =
- let ctr = Ty.Constr.create name in
- DStr.H.add benv.ctr name ctr
-
-let rec sort benv = function
- | SortIdentifier (_,IdSymbol(_,Symbol(loc,id))) ->
- let ctr = DStr.H.find_exn benv.ctr (Unbound(loc,id)) id in
- Ty.ctr ctr
- | SortIdSortMulti (_,IdSymbol(_,Symbol(loc,id)),(_,l)) ->
- let l = List.map (sort benv) l in
- let ctr = DStr.H.find_exn benv.ctr (Unbound(loc,id)) id in
- Ty.app ctr (IArray.of_list l)
- | SortIdentifier (loc,_)
- | SortIdSortMulti (loc,_,_) -> raise (Not_supported loc)
-
-(** TODO: check that it is not a builtin construction? or allows to hide them *)
-let declare_fun benv name sorts result =
- let arity = (List.length sorts) in
- let result = sort benv result in
- let cl = if arity > 0 then
- Uninterp.fresh_fun ~result
- ~arity name
- else
- Variable.fresh result name
- in
- DStr.H.add benv.term name cl
-
-let qualidentifier benv args = function
- (** = *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,"=")),None) ->
- if List.length args != 2 then raise (Not_supported loc);
- Equality.equality (Shuffle.shufflel args)
- (** distinct *)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"xor")),None)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"distinct")),None) ->
- Equality.disequality (Shuffle.shufflel args)
- (** not *)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"not")),None) ->
- assert (List.length args == 1);
- Bool._not (List.hd args)
- (** or *)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"or")),None) ->
- Bool._or (Shuffle.shufflel args)
- (** and *)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"and")),None) ->
- Bool._and (Shuffle.shufflel args)
- (** false *)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"false")),None) ->
- assert (args = []);
- Bool._false
- (** true *)
- | QualIdentifier(_,IdSymbol(_,Symbol(_,"true")),None) ->
- assert (args = []);
- Bool._true
- (** => *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,"=>")),None) ->
- begin match args with
- | [b1;b2] -> Bool.gen false [b1,true;b2,false]
- | _ -> raise (Not_supported loc)
- end
- (** ite *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,"ite")),None) ->
- begin match args with
- | [cond;then_;else_] -> Equality.ite cond then_ else_
- | _ -> raise (Not_supported loc)
- end
- (** * *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,"*")),None) ->
- begin match args with
- | [a1;a2] -> Arith.mult a1 a2
- | _ -> raise (Not_supported loc)
- end
- (** + *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,"+")),None) ->
- begin match args with
- | [a1;a2] -> Arith.add a1 a2
- | _ -> raise (Not_supported loc)
- end
- (** - *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,"-")),None) ->
- begin match args with
- | [a1] -> Arith.mult_cst Q.minus_one a1
- | [a1;a2] -> Arith.sub a1 a2
- | _ -> raise (Not_supported loc)
- end
- (** UserDefined *)
- | QualIdentifier(loc,IdSymbol(_,Symbol(_,name)),None) ->
- let cl = DStr.H.find_exn benv.term (Unbound(loc,name)) name in
- if args = [] then cl
- else Uninterp.app_fun cl args
- (** Not supported *)
- | QualIdentifier(loc,_,_) -> raise (Not_supported loc)
-
-
-let unbind benv = function
- | VarBindingSymTerm (_, (Symbol(_,s)), _) ->
- DStr.H.remove benv.term s
-
-let rec bind env benv = function
- | VarBindingSymTerm (_, (Symbol(_,s)), t) ->
- let cl = term env benv t in
- begin if Debug.test_flag debug_rename then
- let old_name = Pp.string_of Types.Cl.print cl in
- Types.Cl.rename cl s;
- Debug.dprintf3 debug_rename "[Smtlib2] @[rename cl: %s -> %a@]@\n"
- old_name Types.Cl.print cl
- end;
- DStr.H.add benv.term s cl
-
-and term env benv = function
- | TermQualIdentifier (_,qualid) ->
- qualidentifier benv [] qualid
- | TermQualIdTerm (_,f,(_,args)) ->
- let args = List.map (fun e -> term env benv e) args in
- qualidentifier benv args f
- | TermLetTerm (_,(_,bl),t) ->
- List.iter (fun b -> bind env benv b) bl;
- let cl = term env benv t in
- List.iter (unbind benv) bl;
- cl
- | TermSpecConst (_,SpecConstsDec(_,q)) ->
- Arith.cst q
- | TermSpecConst (_,SpecConstNum(_,z)) ->
- Arith.cst (Q.of_bigint z)
- | TermForAllTerm (loc,_,_) | TermExistsTerm (loc,_,_)
- | TermSpecConst (loc,_) | TermExclimationPt (loc, _, _) ->
- raise (Not_supported loc)
-
-
-let of_decl sched benv = function
- (** Noop *)
- | CSetInfo _ | CSetOption _ -> ()
- (** Supported *)
- | CSetLogic (_,Symbol(_,"QF_UF")) ->
- let env = Scheduler.Scheduler.get_delayed sched in
- Uninterp.th_register env
- | CSetLogic (_,Symbol(_,"QF_LRA")) ->
- let env = Scheduler.Scheduler.get_delayed sched in
- Arith.th_register env;
- DStr.H.add benv.ctr "Real" Arith.real_ctr
- | CSetLogic (_,Symbol(_,"QF_UFLRA")) ->
- let env = Scheduler.Scheduler.get_delayed sched in
- Uninterp.th_register env;
- Arith.th_register env;
- DStr.H.add benv.ctr "Real" Arith.real_ctr
- | CSetLogic (loc,_) -> raise (Not_supported loc)
- | CDeclareSort(_,Symbol(_,name),arity) ->
- declare_sort benv name arity
- | CDeclareFun(_,Symbol(_,s),(_,sorts),result) ->
- declare_fun benv s sorts result;
- Scheduler.Scheduler.flush_delayed sched
- | CAssert(_,t) ->
- let env = Scheduler.Scheduler.get_delayed sched in
- let cl = term env benv t in
- Solver.Delayed.register env cl;
- Bool.set_true env Explanation.pexpfact cl;
- Scheduler.Scheduler.flush_delayed sched
- | CCheckSat _ | CExit(_) -> () (** TODO better *)
- (** Not supported *)
- | CDefineSort (loc,_,_,_) | CDefineFun (loc,_,_,_,_) | CPush (loc,_)
- | CPop (loc,_) | CGetAssert(loc) | CGetProof(loc) | CGetUnsatCore(loc)
- | CGetValue(loc,_) | CGetAssign(loc) | CGetOption(loc,_) | CGetInfo(loc,_)
- -> raise (Not_supported loc)
-
-
-type status =
- | Sat
- | Unsat
- | Unknown
-
-let print_status fmt = function
- | Sat -> Format.pp_print_string fmt "sat"
- | Unsat -> Format.pp_print_string fmt "unsat"
- | Unknown -> Format.pp_print_string fmt "unknown"
-
-let check_file l =
- let sched = Scheduler.new_env [Variable.th_register;
- Bool.th_register;
- Equality.th_register] () in
- try
- let benv = {term = DStr.H.create 100; ctr = DStr.H.create 10} in
- DStr.H.add benv.ctr "Bool" Bool.ty_ctr;
- List.iter (fun e -> of_decl sched benv e) l;
- Scheduler.Scheduler.stop_delayed sched;
- Scheduler.Scheduler.run_inf_step sched;
- Sat
- with Scheduler.Scheduler.Contradiction ->
- Unsat
-
-let read_file s =
- let cin = open_in s in
- let lb = Lexing.from_channel cin in
- Loc.set_file s lb;
- Loc.with_location (Smtlib2_parser.commands Smtlib2_lexer.token) lb
-
-
-let () = Exn_printer.register (fun fmt exn ->
- match exn with
- | Not_supported pos ->
- Format.fprintf fmt
- "%a@ popop can't convert smtlib2 construct"
- Loc.report_position pos
- | Unbound (pos,s) ->
- Format.fprintf fmt
- "%a@ unbound identifier %s"
- Loc.report_position pos s
- | _ -> raise exn)
diff --git a/src/inputlang/smtlib2/smtlib2_ast.ml b/src/inputlang/smtlib2/smtlib2_ast.ml
deleted file mode 100644
index 4a11c11d2..000000000
--- a/src/inputlang/smtlib2/smtlib2_ast.ml
+++ /dev/null
@@ -1,180 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-type loc = Loc.position
-
-type specconstant =
- | SpecConstsDec of loc * Q.t
- | SpecConstNum of loc * Z.t
- | SpecConstString of loc * string
- | SpecConstsHex of loc * string
- | SpecConstsBinary of loc * string
-
-type symbol =
- | Symbol of loc * string
-
-type sexpr =
- | SexprSpecConst of loc * specconstant
- | SexprSymbol of loc * symbol
- | SexprKeyword of loc * string
- | SexprInParen of loc * (loc * sexpr list)
-
-type attributevalue =
- | AttributeValSpecConst of loc * specconstant
- | AttributeValSymbol of loc * symbol
- | AttributeValSexpr of loc * (loc * sexpr list)
-
-type attribute =
- | AttributeKeyword of loc * string
- | AttributeKeywordValue of loc * string * attributevalue
-
-type an_option = AnOptionAttribute of loc * attribute
-
-type infoflag = InfoFlagKeyword of loc * string
-
-type identifier =
- | IdSymbol of loc * symbol
- | IdUnderscoreSymNum of loc * symbol * (loc * Z.t list)
-
-type sort =
- | SortIdentifier of loc * identifier
- | SortIdSortMulti of loc * identifier * (loc * sort list)
-
-type qualidentifier =
- | QualIdentifier of loc * identifier * sort option
-
-type sortedvar =
- | SortedVarSymSort of loc * symbol * sort
-
-type varbinding = VarBindingSymTerm of loc * symbol * term
-
-and term =
- | TermSpecConst of loc * specconstant
- | TermQualIdentifier of loc * qualidentifier
- | TermQualIdTerm of loc * qualidentifier * (loc * term list)
- | TermLetTerm of loc * (loc * varbinding list) * term
- | TermForAllTerm of loc * (loc * sortedvar list) * term
- | TermExistsTerm of loc * (loc * sortedvar list) * term
- | TermExclimationPt of loc * term * (loc * attribute list)
-
-type command =
- | CSetLogic of loc * symbol
- | CSetOption of loc * an_option
- | CSetInfo of loc * attribute
- | CDeclareSort of loc * symbol * Z.t
- | CDefineSort of loc * symbol * (loc * symbol list) * sort
- | CDeclareFun of loc * symbol * (loc * sort list) * sort
- | CDefineFun of loc * symbol * (loc * sortedvar list) * sort * term
- | CPush of loc * Z.t
- | CPop of loc * Z.t
- | CAssert of loc * term
- | CCheckSat of loc
- | CGetAssert of loc
- | CGetProof of loc
- | CGetUnsatCore of loc
- | CGetValue of loc * (loc * term list)
- | CGetAssign of loc
- | CGetOption of loc * string
- | CGetInfo of loc * infoflag
- | CExit of loc
-
-type commands = command list
-
-
-(* loc stands for pos (position) and extradata *)
-
-let loc_an_option = function
- | AnOptionAttribute(d,_) -> d
-
-let loc_attribute = function
- | AttributeKeyword(d,_) -> d
- | AttributeKeywordValue(d,_,_) -> d
-
-let loc_attributevalue = function
- | AttributeValSpecConst(d,_) -> d
- | AttributeValSymbol(d,_) -> d
- | AttributeValSexpr(d,_) -> d
-
-let loc_command = function
- | CSetLogic(d,_) -> d
- | CSetOption(d,_) -> d
- | CSetInfo(d,_) -> d
- | CDeclareSort(d,_,_) -> d
- | CDefineSort(d,_,_,_) -> d
- | CDeclareFun(d,_,_,_) -> d
- | CDefineFun(d,_,_,_,_) -> d
- | CPush(d,_) -> d
- | CPop(d,_) -> d
- | CAssert(d,_) -> d
- | CCheckSat(d) -> d
- | CGetAssert(d) -> d
- | CGetProof(d) -> d
- | CGetUnsatCore(d) -> d
- | CGetValue(d,_) -> d
- | CGetAssign(d) -> d
- | CGetOption(d,_) -> d
- | CGetInfo(d,_) -> d
- | CExit(d) -> d
-
-let loc_identifier = function
- | IdSymbol(d,_) -> d
- | IdUnderscoreSymNum(d,_,_) -> d
-
-let loc_infoflag = function
- | InfoFlagKeyword(d,_) -> d
-
-let loc_qualidentifier = function
- | QualIdentifier(d,_,_) -> d
-
-let loc_sexpr = function
- | SexprSpecConst(d,_) -> d
- | SexprSymbol(d,_) -> d
- | SexprKeyword(d,_) -> d
- | SexprInParen(d,_) -> d
-
-let loc_sort = function
- | SortIdentifier(d,_) -> d
- | SortIdSortMulti(d,_,_) -> d
-
-let loc_sortedvar = function
- | SortedVarSymSort(d,_,_) -> d
-
-let loc_specconstant = function
- | SpecConstsDec(d,_) -> d
- | SpecConstNum(d,_) -> d
- | SpecConstString(d,_) -> d
- | SpecConstsHex(d,_) -> d
- | SpecConstsBinary(d,_) -> d
-
-let loc_symbol = function
- | Symbol(d,_) -> d
-
-let loc_term = function
- | TermSpecConst(d,_) -> d
- | TermQualIdentifier(d,_) -> d
- | TermQualIdTerm(d,_,_) -> d
- | TermLetTerm(d,_,_) -> d
- | TermForAllTerm(d,_,_) -> d
- | TermExistsTerm(d,_,_) -> d
- | TermExclimationPt(d,_,_) -> d
-
-let loc_varbinding = function
- | VarBindingSymTerm(d,_,_) -> d
-
-let loc_couple = fst
diff --git a/src/inputlang/smtlib2/smtlib2_lexer.mll b/src/inputlang/smtlib2/smtlib2_lexer.mll
deleted file mode 100644
index 7fcbe5fa7..000000000
--- a/src/inputlang/smtlib2/smtlib2_lexer.mll
+++ /dev/null
@@ -1,95 +0,0 @@
-(**************************************************************************)
-(* *)
-(* The Alt-Ergo theorem prover *)
-(* Copyright (C) 2006-2011 *)
-(* *)
-(* Sylvain Conchon *)
-(* Evelyne Contejean *)
-(* *)
-(* Francois Bobot *)
-(* Mohamed Iguernelala *)
-(* Stephane Lescuyer *)
-(* Alain Mebsout *)
-(* *)
-(* CNRS - INRIA - Universite Paris Sud *)
-(* *)
-(* This file is distributed under the terms of the CeCILL-C licence *)
-(* *)
-(**************************************************************************)
-
-{
-open Lexing
-open Smtlib2_parser
-
-
-let newline lexbuf =
- let pos = lexbuf.lex_curr_p in
- lexbuf.lex_curr_p <-
- { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum;
- pos_cnum=0 }
-
-}
-
-rule token = parse
-| ['\t' ' ' ]+
- { token lexbuf }
-| ';' (_ # '\n')*
- { token lexbuf }
-| ['\n']+
- { Lexing.new_line lexbuf; token lexbuf }
-| "_" { UNDERSCORE }
-| "(" { LPAREN }
-| ")" { RPAREN }
-| "as" { AS }
-| "let" { LET }
-| "forall" { FORALL }
-| "exists" { EXISTS }
-| "!" { EXCLIMATIONPT }
-| "set-logic" { SETLOGIC }
-| "set-option" { SETOPTION }
-| "set-info" { SETINFO }
-| "declare-sort" { DECLARESORT }
-| "define-sort" { DEFINESORT }
-| "declare-fun" { DECLAREFUN }
-| "declare-const" { DECLARECONST }
-| "define-fun" { DEFINEFUN }
-| "push" { PUSH }
-| "pop" { POP }
-| "assert" { ASSERT }
-| "check-sat" { CHECKSAT }
-| "get-assertions" { GETASSERT }
-| "get-proof" { GETPROOF }
-| "get-unsat-core" { GETUNSATCORE }
-| "get-value" { GETVALUE }
-| "get-assignment" { GETASSIGN }
-| "get-option" { GETOPTION }
-| "get-info" { GETINFO }
-| "exit" { EXIT }
-| '#' 'x' ['0'-'9' 'A'-'F' 'a'-'f']+ as str
- { HEXADECIMAL(str) }
-| '#' 'b' ['0'-'1']+ as str
- { BINARY(str) }
-| '|' ([ '!'-'~' ' ' '\n' '\t' '\r'] # ['\\' '|'])* '|' as str
- { ASCIIWOR(str) }
-| ':' ['a'-'z' 'A'-'Z' '0'-'9' '+' '-' '/' '*' '=' '%' '?' '!' '.' '$' '_' '~'
- '&' '^' '<' '>' '@']+ as str
- { KEYWORD(str) }
-| ['a'-'z' 'A'-'Z' '+' '-' '/' '*' '=''%' '?' '!' '.' '$' '_' '~' '&' '^' '<'
- '>' '@']
- ['a'-'z' 'A'-'Z' '0'-'9' '+' '-' '/' '*' '=''%' '?' '!' '.' '$'
- '_' '~' '&' '^' '<' '>' '@']* as str
- { SYMBOL(str) }
-| '"' (([ '!'-'~' ' ' '\n' '\t' '\r' ] # ['\\' '"']) |
- ('\\' ['!'-'~' ' ' '\n' '\t' '\r'] ))* '"' as str
- { STRINGLIT(str) }
-| ( '0' | ['1'-'9'] ['0'-'9']* ) as str
- { NUMERAL(Z.of_string str) }
-| (( '0' | ['1'-'9'] ['0'-'9']* ) as num) '.' (['0'-'9']+ as den)
- { DECIMAL(
- Q.make (Z.of_string (num^den))
- (Z.pow (Z.of_int 10) (String.length den)))
- }
-| eof
- { EOF }
-| _
- { Loc.errorm "unknwon character: %s" (Lexing.lexeme lexbuf) }{}
diff --git a/src/inputlang/smtlib2/smtlib2_parser.mly b/src/inputlang/smtlib2/smtlib2_parser.mly
deleted file mode 100644
index a971acc6c..000000000
--- a/src/inputlang/smtlib2/smtlib2_parser.mly
+++ /dev/null
@@ -1,290 +0,0 @@
-/**************************************************************************/
-/* */
-/* The Alt-Ergo theorem prover */
-/* Copyright (C) 2006-2011 */
-/* */
-/* Sylvain Conchon */
-/* Evelyne Contejean */
-/* */
-/* Francois Bobot */
-/* Mohamed Iguernelala */
-/* Stephane Lescuyer */
-/* Alain Mebsout */
-/* */
-/* CNRS - INRIA - Universite Paris Sud */
-/* */
-/* This file is distributed under the terms of the CeCILL-C licence */
-/* */
-/**************************************************************************/
-
-%{
-
- open Smtlib2_ast
-
-(* let parse_error s = *)
-(* print_string s; *)
-(* print_string " on line "; *)
-(* print_int !Smtlib_util.line; *)
-(* print_string "\n" *)
-
-
- let loc () = Loc.extract (symbol_start_pos (), symbol_end_pos ())
-
-%}
-
-%start commands
-
-/* general */
-%token EXCLIMATIONPT
-%token UNDERSCORE
-%token AS
-%token EXISTS
-%token FORALL
-%token LET
-
-/* commands */
-%token SETLOGIC
-%token SETOPTION
-%token SETINFO
-%token DECLARESORT
-%token DEFINESORT
-%token DECLAREFUN
-%token DECLARECONST
-%token DEFINEFUN
-%token PUSH
-%token POP
-%token ASSERT
-%token CHECKSAT
-%token GETASSERT
-%token GETPROOF
-%token GETUNSATCORE
-%token GETVALUE
-%token GETASSIGN
-%token GETOPTION
-%token GETINFO
-%token EXIT
-
-/* Other tokens */
-%token LPAREN
-%token RPAREN
-%token EOF
-
-%token <Z.t> NUMERAL
-%token <Q.t> DECIMAL
-%token <string> HEXADECIMAL
-%token <string> BINARY
-%token <string> STRINGLIT
-%token <string> ASCIIWOR
-%token <string> KEYWORD
-%token <string> SYMBOL
-
-
-%type <Smtlib2_ast.commands> commands
-%type <Smtlib2_ast.an_option> an_option
-%type <Smtlib2_ast.attribute> attribute
-%type <Smtlib2_ast.attributevalue> attributevalue
-%type <Smtlib2_ast.command> command
-%type <Smtlib2_ast.identifier> identifier
-%type <Smtlib2_ast.infoflag> infoflag
-%type <Smtlib2_ast.qualidentifier> qualidentifier
-%type <Smtlib2_ast.sexpr> sexpr
-%type <Smtlib2_ast.sort> sort
-%type <Smtlib2_ast.sortedvar> sortedvar
-%type <Smtlib2_ast.specconstant> specconstant
-%type <Smtlib2_ast.symbol> symbol
-%type <Smtlib2_ast.term> term
-%type <Smtlib2_ast.varbinding> varbinding
-%%
-
-an_option:
-| attribute { AnOptionAttribute(loc_attribute $1, $1) }
-;
-
-attribute:
-| KEYWORD { AttributeKeyword(loc (), $1) }
-| KEYWORD attributevalue { AttributeKeywordValue(loc (), $1, $2) }
-;
-
-sexpr_list:
-/*sexprinparen_sexpr_sexpr41:*/
-/*attributevalsexpr_attributevalue_sexpr5:*/
-| { (loc (), []) }
-| sexpr sexpr_list { let (_, l1) = $2 in (loc_sexpr $1, ($1)::(l1)) }
-;
-
-attributevalue:
-| specconstant { AttributeValSpecConst(loc_specconstant $1, $1) }
-| symbol { AttributeValSymbol(loc_symbol $1, $1) }
-| LPAREN sexpr_list RPAREN { AttributeValSexpr(loc (), $2) }
-;
-
-symbol_list: /*commanddefinesort_command_symbol11:*/
-| { (loc (), []) }
-| symbol symbol_list { let (_, l1) = $2 in (loc_symbol $1, ($1)::(l1)) }
-;
-
-sort_list0: /*commanddeclarefun_command_sort13:*/
-| { (loc (), []) }
-| sort sort_list0 { let (_, l1) = $2 in (loc_sort $1, ($1)::(l1)) }
-;
-
-sortedvar_list: /*commanddefinefun_command_sortedvar15:*/
-| { (loc (), []) }
-| sortedvar sortedvar_list
- { let (_, l1) = $2 in (loc_sortedvar $1, ($1)::(l1)) }
-;
-
-command:
-| LPAREN SETLOGIC symbol RPAREN
- { CSetLogic(loc (), $3) }
-| LPAREN SETOPTION an_option RPAREN
- { CSetOption(loc (), $3) }
-| LPAREN SETINFO attribute RPAREN
- { CSetInfo(loc (), $3) }
-| LPAREN DECLARESORT symbol NUMERAL RPAREN
- { CDeclareSort(loc (), $3, $4) }
-| LPAREN DECLARESORT symbol RPAREN
- { CDeclareSort(loc (), $3, Z.zero ) }
-| LPAREN DEFINESORT symbol LPAREN symbol_list RPAREN sort RPAREN
- { CDefineSort(loc (), $3, $5, $7) }
-| LPAREN DECLAREFUN symbol LPAREN sort_list0 RPAREN sort RPAREN
- { CDeclareFun(loc (), $3, $5, $7) }
-| LPAREN DECLARECONST symbol sort RPAREN
- { CDeclareFun(loc (), $3, (loc (), []), $4) }
-| LPAREN DEFINEFUN symbol LPAREN sortedvar_list RPAREN sort term RPAREN
- { CDefineFun(loc (), $3, $5, $7, $8) }
-| LPAREN PUSH NUMERAL RPAREN
- { CPush(loc (), $3) }
-| LPAREN POP NUMERAL RPAREN
- { CPop(loc (), $3) }
-| LPAREN ASSERT term RPAREN
- { CAssert(loc (), $3) }
-| LPAREN CHECKSAT RPAREN
- { CCheckSat(loc ()) }
-| LPAREN GETASSERT RPAREN
- { CGetAssert(loc ()) }
-| LPAREN GETPROOF RPAREN
- { CGetProof(loc ()) }
-| LPAREN GETUNSATCORE RPAREN
- { CGetUnsatCore(loc ()) }
-| LPAREN GETVALUE LPAREN term_list1 RPAREN RPAREN
- { CGetValue(loc (), $4) }
-| LPAREN GETASSIGN RPAREN
- { CGetAssign(loc ()) }
-| LPAREN GETOPTION KEYWORD RPAREN
- { CGetOption(loc (), $3) }
-| LPAREN GETINFO infoflag RPAREN
- { CGetInfo(loc (), $3) }
-| LPAREN EXIT RPAREN
- { CExit(loc ()) }
-;
-
-
-commands: /*commands_commands_command30:*/
-| { [] }
-| EOF { [] }
-| command commands { ($1)::($2) }
-;
-
-numeral_list: /*idunderscoresymnum_identifier_numeral33:*/
-| NUMERAL { (loc (), ($1)::[]) }
-| NUMERAL numeral_list { let (_, l1) = $2 in (loc (), ($1)::(l1)) }
-;
-
-identifier:
-| symbol { IdSymbol(loc_symbol $1, $1) }
-| LPAREN UNDERSCORE symbol numeral_list RPAREN
- { IdUnderscoreSymNum(loc (), $3, $4) }
-;
-
-infoflag:
-| KEYWORD { InfoFlagKeyword(loc (), $1) }
-;
-
-qualidentifier:
-| identifier { QualIdentifier(loc_identifier $1, $1, None) }
-| LPAREN AS identifier sort RPAREN { QualIdentifier(loc (), $3, Some $4) }
-;
-
-sexpr:
-| specconstant { SexprSpecConst(loc_specconstant $1, $1) }
-| symbol { SexprSymbol(loc_symbol $1, $1) }
-| KEYWORD { SexprKeyword(loc (), $1) }
-| LPAREN sexpr_list RPAREN { SexprInParen(loc (), $2) }
-;
-
-
-sort_list1: /*sortidsortmulti_sort_sort44:*/
-| sort { (loc_sort $1, ($1)::[]) }
-| sort sort_list1 { let (_, l1) = $2 in (loc_sort $1, ($1)::(l1)) }
-;
-
-sort:
-| identifier { SortIdentifier(loc_identifier $1, $1) }
-| LPAREN identifier sort_list1 RPAREN { SortIdSortMulti(loc (), $2, $3) }
-;
-
-sortedvar:
-| LPAREN symbol sort RPAREN { SortedVarSymSort(loc (), $2, $3) }
-;
-
-specconstant:
-| DECIMAL { SpecConstsDec(loc (), $1) }
-| NUMERAL { SpecConstNum(loc (), $1) }
-| STRINGLIT { SpecConstString(loc (), $1) }
-| HEXADECIMAL { SpecConstsHex(loc (), $1) }
-| BINARY { SpecConstsBinary(loc (), $1) }
-;
-
-symbol:
-| SYMBOL { Symbol(loc (), $1) }
-| ASCIIWOR { Symbol(loc (), $1) }
-;
-
-term_list1:
-/*termqualidterm_term_term56:*/
-/*commandgetvalue_command_term24:*/
-| term { (loc_term $1, ($1)::[]) }
-| term term_list1 { let (_, l1) = $2 in (loc_term $1, ($1)::(l1)) }
-;
-
-varbinding_list1: /*termletterm_term_varbinding58:*/
-| varbinding { (loc_varbinding $1, ($1)::[]) }
-| varbinding varbinding_list1
- { let (_, l1) = $2 in (loc_varbinding $1, ($1)::(l1)) }
-;
-
-sortedvar_list1:
-/*termforallterm_term_sortedvar60:*/
-/*termexiststerm_term_sortedvar62:*/
-| sortedvar { (loc_sortedvar $1, ($1)::[]) }
-| sortedvar sortedvar_list1
- { let (_, l1) = $2 in (loc_sortedvar $1, ($1)::(l1)) }
-;
-
-attribute_list1: /*termexclimationpt_term_attribute64:*/
-| attribute { (loc_attribute $1, ($1)::[]) }
-| attribute attribute_list1
- { let (_, l1) = $2 in (loc_attribute $1, ($1)::(l1)) }
-;
-
-term:
-| specconstant
- { TermSpecConst(loc_specconstant $1, $1) }
-| qualidentifier
- { TermQualIdentifier(loc_qualidentifier $1, $1) }
-| LPAREN qualidentifier term_list1 RPAREN
- { TermQualIdTerm(loc (), $2, $3) }
-| LPAREN LET LPAREN varbinding_list1 RPAREN term RPAREN
- { TermLetTerm(loc (), $4, $6) }
-| LPAREN FORALL LPAREN sortedvar_list1 RPAREN term RPAREN
- { TermForAllTerm(loc (), $4, $6) }
-| LPAREN EXISTS LPAREN sortedvar_list1 RPAREN term RPAREN
- { TermExistsTerm(loc (), $4, $6) }
-| LPAREN EXCLIMATIONPT term attribute_list1 RPAREN
- { TermExclimationPt(loc (), $3, $4) }
-;
-
-varbinding:
-| LPAREN symbol term RPAREN { VarBindingSymTerm(loc (), $2, $3) }
-;
diff --git a/src/util/IArray.ml b/src/popop_lib/IArray.ml
similarity index 79%
rename from src/util/IArray.ml
rename to src/popop_lib/IArray.ml
index e65521dcd..11fd5592c 100644
--- a/src/util/IArray.ml
+++ b/src/popop_lib/IArray.ml
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
type 'a t = 'a array
@@ -101,4 +99,4 @@ let foldi f x a =
done;
!r
-let print sep p fmt a = Pp.print_iter1 iter sep p fmt a
+let pp sep p fmt a = Pp.iter1 iter sep p fmt a
diff --git a/src/util/IArray.mli b/src/popop_lib/IArray.mli
similarity index 69%
rename from src/util/IArray.mli
rename to src/popop_lib/IArray.mli
index 2716fb3ee..c0aa105d8 100644
--- a/src/util/IArray.mli
+++ b/src/popop_lib/IArray.mli
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
(** immutable arrays, like arrays but you can't modify them after
@@ -47,4 +45,4 @@ val iteri : (int -> 'a -> unit) -> 'a t -> unit
val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b
val foldi : (int -> 'b -> 'a -> 'b) -> 'b -> 'a t -> 'b
-val print: unit Pp.printer -> 'a Pp.printer -> 'a t Pp.printer
+val pp: unit Pp.pp -> 'a Pp.pp -> 'a t Pp.pp
diff --git a/src/util/bag.ml b/src/popop_lib/bag.ml
similarity index 92%
rename from src/util/bag.ml
rename to src/popop_lib/bag.ml
index cd744f7ef..6b0c87eaf 100644
--- a/src/util/bag.ml
+++ b/src/popop_lib/bag.ml
@@ -1,24 +1,24 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2007-2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(*************************************************************************)
(* ------------------------------------------------------------------------ *)
(* --- List with constant-time concat --- *)
@@ -191,4 +191,4 @@ let rec collect t xs =
let elements t = collect t []
-let print sep pelt fmt t = Pp.print_iter1 iter sep pelt fmt t
+let pp sep pelt fmt t = Pp.iter1 iter sep pelt fmt t
diff --git a/src/util/bag.mli b/src/popop_lib/bag.mli
similarity index 81%
rename from src/util/bag.mli
rename to src/popop_lib/bag.mli
index b9ef1f5ae..36ed27e03 100644
--- a/src/util/bag.mli
+++ b/src/popop_lib/bag.mli
@@ -1,24 +1,24 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2007-2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(*************************************************************************)
(** List with constant-time concat operation.
@since Carbon-20101201
@@ -54,7 +54,7 @@ val singleton : 'a t -> 'a option
val elements : 'a t -> 'a list
val choose: 'a t -> 'a
-val print:
- (unit Pp.printer) ->
- ('a Pp.printer) ->
- 'a t Pp.printer
+val pp:
+ (unit Pp.pp) ->
+ ('a Pp.pp) ->
+ 'a t Pp.pp
diff --git a/src/util/cmdline.ml b/src/popop_lib/cmdline.ml
similarity index 94%
rename from src/util/cmdline.ml
rename to src/popop_lib/cmdline.ml
index 49104b9f8..1b89d929a 100644
--- a/src/util/cmdline.ml
+++ b/src/popop_lib/cmdline.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -43,11 +43,11 @@ let cmdline_split s =
| '\\' -> cstate := Escape
| c when is_blank c ->
let n = Queue.length cur_arg in
- let s = String.create n in
+ let s = Bytes.create n in
for i = 0 to pred n do
- String.set s i (Queue.take cur_arg)
+ Bytes.set s i (Queue.take cur_arg)
done;
- argv := s :: !argv;
+ argv := (Bytes.to_string s) :: !argv;
cstate := Blank
| c -> Queue.add c cur_arg
in
diff --git a/src/util/cmdline.mli b/src/popop_lib/cmdline.mli
similarity index 93%
rename from src/util/cmdline.mli
rename to src/popop_lib/cmdline.mli
index ef9761ea6..9c24b15ba 100644
--- a/src/util/cmdline.mli
+++ b/src/popop_lib/cmdline.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/debug.ml b/src/popop_lib/debug.ml
similarity index 55%
rename from src/util/debug.ml
rename to src/popop_lib/debug.ml
index 390bab5ac..01f313e3c 100644
--- a/src/util/debug.ml
+++ b/src/popop_lib/debug.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -65,7 +65,7 @@ let unset_flag s = assert (modifiable s); s := false
let toggle_flag s = assert (modifiable s); s := not !s
let () = Exn_printer.register (fun fmt e -> match e with
- | UnknownFlag s -> Format.fprintf fmt "unknown debug flag `%s'@\n" s
+ | UnknownFlag s -> Format.fprintf fmt "unknown debug flag `%s'" s
| _ -> raise e)
let stack_trace = register_flag "stack_trace"
@@ -78,68 +78,87 @@ let timestamp = register_info_flag "timestamp"
let time_start = Unix.gettimeofday ()
-let set_debug_formatter f =
+let set_debug_formatter fmt =
(** enable the usual behavior of stderr: flush at every new line *)
- let out,flush,newline,spaces =
- Format.pp_get_all_formatter_output_functions f () in
- Format.pp_set_all_formatter_output_functions
- f
- ~out
- ~flush
- ~newline:(fun () -> newline (); flush ())
- ~spaces;
- formatter := f
+ let out = Format.pp_get_formatter_out_functions fmt () in
+ Format.pp_set_formatter_out_functions
+ fmt {out with out_newline =
+ (fun () ->
+ out.out_newline ();
+ out.out_flush ();
+ if !timestamp then
+ let s =
+ Printf.sprintf "<%f>"
+ (Unix.gettimeofday () -. time_start) in
+ out.out_string s 0 (String.length s) ;
+ ) };
+ Format.pp_open_vbox fmt 0;
+ formatter := fmt
let get_debug_formatter () = !formatter
let () = set_debug_formatter Format.err_formatter
-let real_dprintf s =
- if !timestamp then Format.fprintf !formatter "<%f>"
- (Unix.gettimeofday () -. time_start);
- Format.fprintf !formatter s
+let real_dprintf ?nobox s =
+ let box = match nobox with None -> true | Some () -> false in
+ if box then begin
+ Format.pp_print_cut !formatter ();
+ Format.pp_open_box !formatter 0;
+ end;
+ Format.kfprintf
+ (fun fmt -> if box then begin
+ Format.pp_close_box fmt ();
+ end
+ )
+ !formatter s
-let dprintf0 flag s =
- if !flag then real_dprintf s
+let dprintf0 ?nobox flag s =
+ if !flag then real_dprintf ?nobox s
-let dprintf1 flag s a1 =
- if !flag then real_dprintf s a1
+let dprintf1 ?nobox flag s a1 =
+ if !flag then real_dprintf ?nobox s a1
-let dprintf2 flag s a1 a2 =
- if !flag then real_dprintf s a1 a2
+let dprintf2 ?nobox flag s a1 a2 =
+ if !flag then real_dprintf ?nobox s a1 a2
-let dprintf3 flag s a1 a2 a3 =
- if !flag then real_dprintf s a1 a2 a3
+let dprintf3 ?nobox flag s a1 a2 a3 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3
-let dprintf4 flag s a1 a2 a3 a4 =
- if !flag then real_dprintf s a1 a2 a3 a4
+let dprintf4 ?nobox flag s a1 a2 a3 a4 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4
-let dprintf5 flag s a1 a2 a3 a4 a5 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5
+let dprintf5 ?nobox flag s a1 a2 a3 a4 a5 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5
-let dprintf6 flag s a1 a2 a3 a4 a5 a6 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6
+let dprintf6 ?nobox flag s a1 a2 a3 a4 a5 a6 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6
-let dprintf7 flag s a1 a2 a3 a4 a5 a6 a7 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7
+let dprintf7 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7
-let dprintf8 flag s a1 a2 a3 a4 a5 a6 a7 a8 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7 a8
+let dprintf8 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8
-let dprintf9 flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7 a8 a9
+let dprintf9 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9
-let dprintf10 flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10
+let dprintf10 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10
-let dprintf11 flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
+let dprintf11 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
-let dprintf12 flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12
+let dprintf12 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12
-let dprintfn flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 =
- if !flag then real_dprintf s a1 a2 a3 a4 a5 a6 a7 a8 a9
+let dprintf13 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13
+
+let dprintf14 ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14
+
+let dprintfn ?nobox flag s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 =
+ if !flag then real_dprintf ?nobox s a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
else
(* ifprintf take too many times for computing the format *)
let rec aux = fun _ -> Obj.magic aux in
@@ -160,22 +179,26 @@ module Args = struct
let list =
Hashtbl.fold (fun s (_,info,desc) acc -> (s,info,desc)::acc)
flag_table [] in
- let print fmt (p,info,desc) =
- Format.fprintf fmt "@[%s%s@\n @[%a@]@]"
+ let pp fmt (p,info,desc) =
+ Format.fprintf fmt "@[%s%s @[%a@]@]"
p (if info then " *" else "")
Pp.formatted desc
in
- Format.printf "@[<hov 2>Known debug flags \
- (`*' marks the flags selected by --debug-all):@\n%a@]@\n"
- (Pp.print_list Pp.newline print)
- (List.sort Pervasives.compare list);
+ Format.printf "@[<v 2>@[Known debug flags \
+ (`*' marks the flags selected by --debug-all):@]@,%a@]"
+ (Pp.list Pp.newline pp)
+ (List.sort Stdlib.compare list);
end;
!opt_list_flags in
desc,list
- let opt_list_flags = Queue.create ()
+ let opt_list_flags = ref []
- let add_flag s = Queue.add s opt_list_flags
+ let add_flag s = opt_list_flags := s::!opt_list_flags
+ let add_all_flags () =
+ Hashtbl.iter (fun s (_,info,_) -> if info then add_flag s) flag_table
+ let remove_flag s =
+ opt_list_flags := List.filter (fun x -> x <> s) !opt_list_flags
let desc_shortcut flag option desc =
let set_flag () = add_flag flag in
@@ -183,29 +206,24 @@ module Args = struct
(option, Arg.Unit set_flag, desc)
let desc_debug =
- ("--debug", Arg.String add_flag, "<flag> Set a debug flag")
-
- let opt_debug_all = ref false
+ ["--debug", Arg.String add_flag, "<flag> Set a debug flag";
+ "--no-debug", Arg.String remove_flag, "<flag> Remove a debug flag"]
let desc_debug_all =
let desc_debug =
Pp.sprintf
" Set all debug flags that do not change Why3 behaviour" in
- ("--debug-all", Arg.Set opt_debug_all, desc_debug)
+ ("--debug-all", Arg.Unit add_all_flags, desc_debug)
let set_flags_selected () =
- if !opt_debug_all then
- List.iter
- (fun (s,f,_,_) -> if is_info_flag s then set_flag f)
- (list_flags ());
- Queue.iter (fun flag -> let flag = lookup_flag flag in set_flag flag)
- opt_list_flags;
+ List.iter (fun flag -> let flag = lookup_flag flag in set_flag flag)
+ !opt_list_flags;
if test_flag stack_trace then Printexc.record_backtrace true
end
(** Stats *)
let stats = register_info_flag "stats"
- ~desc:"Compute and print statistics."
+ ~desc:"Compute and pp statistics."
type 'a stat = 'a ref
@@ -213,7 +231,7 @@ let max_name_size = ref 0
type stats =
-| Stat : ('a Pp.printer) * string * 'a ref -> stats
+| Stat : ('a Pp.pp) * string * 'a ref -> stats
let registered_stats : stats list ref = ref []
@@ -221,14 +239,14 @@ let rec print_nb_char fmt = function
| n when n <= 0 -> ()
| n -> Format.pp_print_char fmt ' '; print_nb_char fmt (n-1)
-let print_stat fmt (Stat(print,name,r)) =
+let print_stat fmt (Stat(pp,name,r)) =
Format.fprintf fmt "@[%s%a: %a@]"
name print_nb_char (!max_name_size - String.length name)
- print !r
+ pp !r
let print_stats () =
dprintf2 stats "@[%a@]@\n"
- (Pp.print_list Pp.newline print_stat)
+ (Pp.list Pp.newline print_stat)
!registered_stats
@@ -241,10 +259,10 @@ let _ =
(** TODO? have a possible callback for printing different message*)
Sys.signal Sys.sigint (Sys.Signal_handle (fun _ -> exit 2))
-let register_stats ~print ~name ~init =
+let register_stats ~pp ~name ~init =
let s = ref init in
max_name_size := max !max_name_size (String.length name);
- registered_stats := Stat(print,name,s)::!registered_stats;
+ registered_stats := Stat(pp,name,s)::!registered_stats;
s
let modstats0 r f =
@@ -255,7 +273,7 @@ let modstats2 r f x y =
if test_flag stats then r := f !r x y
let register_stats_int ~name ~init =
- register_stats ~print:Format.pp_print_int ~name ~init
+ register_stats ~pp:Format.pp_print_int ~name ~init
let incr r = if test_flag stats then incr r
let decr r = if test_flag stats then decr r
diff --git a/src/util/debug.mli b/src/popop_lib/debug.mli
similarity index 75%
rename from src/util/debug.mli
rename to src/popop_lib/debug.mli
index adc92f8a7..1434f1ffe 100644
--- a/src/util/debug.mli
+++ b/src/popop_lib/debug.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -55,77 +55,92 @@ val set_debug_formatter : Format.formatter -> unit
val get_debug_formatter : unit -> Format.formatter
(** Get the formatter used when printing debug material *)
-val dprintf0 : flag -> (unit,
+val dprintf0 : ?nobox:unit -> flag -> (unit,
Format.formatter, unit) format -> unit
(** Print only if the flag is set *)
-val dprintf1 : flag -> ('a -> unit,
+val dprintf1 : ?nobox:unit -> flag -> ('a -> unit,
Format.formatter, unit) format -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf2 : flag -> ('b -> 'a -> unit,
+val dprintf2 : ?nobox:unit -> flag -> ('b -> 'a -> unit,
Format.formatter, unit) format ->
'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf3 : flag -> ('c -> 'b -> 'a -> unit,
+val dprintf3 : ?nobox:unit -> flag -> ('c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf4 : flag -> ('d -> 'c -> 'b -> 'a -> unit,
+val dprintf4 : ?nobox:unit -> flag -> ('d -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf5 : flag -> ('e -> 'd -> 'c -> 'b -> 'a -> unit,
+val dprintf5 : ?nobox:unit -> flag -> ('e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf6 : flag -> ('f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
+val dprintf6 : ?nobox:unit -> flag ->
+ ('f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf7 : flag -> ('g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
+val dprintf7 : ?nobox:unit -> flag ->
+ ('g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf8 : flag -> ('h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
+val dprintf8 : ?nobox:unit -> flag ->
+ ('h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf9 : flag ->
+val dprintf9 : ?nobox:unit -> flag ->
('i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf10 : flag ->
+val dprintf10 : ?nobox:unit -> flag ->
('j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf11 : flag ->
+val dprintf11 : ?nobox:unit -> flag ->
('k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintf12 : flag ->
+val dprintf12 : ?nobox:unit -> flag ->
('l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
(** Print only if the flag is set *)
-val dprintfn : flag ->
- ('i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> 'z,
+val dprintf13 : ?nobox:unit -> flag ->
+ ('m -> 'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
Format.formatter, unit) format ->
- 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> 'z
+ 'm -> 'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
+(** Print only if the flag is set *)
+
+val dprintf14 : ?nobox:unit -> flag ->
+ ('n -> 'm -> 'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit,
+ Format.formatter, unit) format ->
+ 'n -> 'm -> 'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> unit
+(** Print only if the flag is set *)
+
+val dprintfn : ?nobox:unit -> flag ->
+ ('o -> 'n -> 'm -> 'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> 'z,
+ Format.formatter, unit) format ->
+ 'o -> 'n -> 'm -> 'l -> 'k -> 'j -> 'i -> 'h -> 'g -> 'f -> 'e -> 'd -> 'c -> 'b -> 'a -> 'z
(** Print only if the flag is set *)
(* val dprintf : flag -> ('a, Format.formatter, unit) format -> 'a *)
@@ -151,7 +166,7 @@ module Args : sig
val desc_debug_all : spec
(** Option for setting all info flags *)
- val desc_debug : spec
+ val desc_debug : spec list
(** Option for specifying a debug flag to set *)
val desc_shortcut : string -> Arg.key -> Arg.doc -> spec
@@ -168,7 +183,7 @@ val stats: flag
type 'a stat
val register_stats :
- print:('a Pp.printer) ->
+ pp:('a Pp.pp) ->
name:string ->
init:'a -> 'a stat
diff --git a/src/popop_lib/dune b/src/popop_lib/dune
new file mode 100644
index 000000000..35ba3fe2c
--- /dev/null
+++ b/src/popop_lib/dune
@@ -0,0 +1,10 @@
+; library to replace by containers
+
+(library
+ (name witan_popop_lib)
+ (public_name witan.popop_lib)
+ (synopsis "Temporary for witan (intended to be replaced by another library)")
+ (libraries str unix zarith)
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/util/enum.ml b/src/popop_lib/enum.ml
similarity index 80%
rename from src/util/enum.ml
rename to src/popop_lib/enum.ml
index 2803db944..3d7eb0c17 100644
--- a/src/util/enum.ml
+++ b/src/popop_lib/enum.ml
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
type 'a t =
| List: (** content *) 'b list *
diff --git a/src/util/enum.mli b/src/popop_lib/enum.mli
similarity index 68%
rename from src/util/enum.mli
rename to src/popop_lib/enum.mli
index 07008895a..01200b460 100644
--- a/src/util/enum.mli
+++ b/src/popop_lib/enum.mli
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
(** Use enum for deforesting *)
diff --git a/src/util/exn_printer.ml b/src/popop_lib/exn_printer.ml
similarity index 89%
rename from src/util/exn_printer.ml
rename to src/popop_lib/exn_printer.ml
index 8ef435952..7efec44d2 100644
--- a/src/util/exn_printer.ml
+++ b/src/popop_lib/exn_printer.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -9,10 +9,10 @@
(* *)
(********************************************************************)
-type exn_printer = exn Pp.printer
+type exn_printer = exn Pp.pp
let exn_printers =
- (Stack.create () : (exn Pp.printer) Stack.t)
+ (Stack.create () : (exn Pp.pp) Stack.t)
let register exn_printer = Stack.push exn_printer exn_printers
diff --git a/src/util/exn_printer.mli b/src/popop_lib/exn_printer.mli
similarity index 88%
rename from src/util/exn_printer.mli
rename to src/popop_lib/exn_printer.mli
index d4c271d77..6002bca5b 100644
--- a/src/util/exn_printer.mli
+++ b/src/popop_lib/exn_printer.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -9,7 +9,7 @@
(* *)
(********************************************************************)
-type exn_printer = exn Pp.printer
+type exn_printer = exn Pp.pp
(* an [exn_printer] is a formatter of exception which prints on the
given formatter a message for the user if it knows the given
exception. Otherwise it raises the exception *)
@@ -19,4 +19,4 @@ val register : exn_printer -> unit
val exn_printer : exn_printer
(* [exn_printer fmt exn] prints exception [exn] using all previously
- registered printers and returns *)
+ registered pps and returns *)
diff --git a/src/util/exthtbl.ml b/src/popop_lib/exthtbl.ml
similarity index 95%
rename from src/util/exthtbl.ml
rename to src/popop_lib/exthtbl.ml
index 0ae76fddf..d6931d37a 100644
--- a/src/util/exthtbl.ml
+++ b/src/popop_lib/exthtbl.ml
@@ -1,14 +1,14 @@
(***********************************************************************)
-(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../LICENSE. *)
+(* en Automatique. *)
(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
(***********************************************************************)
(********************************************************************)
@@ -56,7 +56,7 @@ module type HashedType =
(provided objects do not contain floats)
- ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
for comparing objects by structure
- and handling {!Pervasives.nan} correctly
+ and handling {!Stdlib.nan} correctly
- ([(==)], {!Hashtbl.hash}) for comparing objects by physical
equality (e.g. for mutable or cyclic objects). *)
end
@@ -91,7 +91,7 @@ module type S =
val find_opt : 'a t -> key -> 'a option
val find_exn : 'a t -> exn -> key -> 'a
val mapi : (key -> 'a -> 'a) -> 'a t -> unit
- val memo : int -> (key -> 'a) -> key -> 'a
+ val memo : (key -> 'a) -> 'a t -> key -> 'a
val is_empty : 'a t -> bool
val remove_all: 'a t -> key -> unit
val change : ('a option -> 'a option) -> 'a t -> key -> unit
@@ -379,10 +379,9 @@ module MakeSeeded(H: SeededHashedType) =
let find h k = find_exn h Not_found k
- let memo size f =
- let h = create size in
- fun x -> try find h x
- with Not_found -> let y = f x in add h x y; y
+ let memo f h x =
+ try find h x
+ with Not_found -> let y = f x in add h x y; y
let find_def h d k =
try find h k with Not_found -> d
diff --git a/src/util/exthtbl.mli b/src/popop_lib/exthtbl.mli
similarity index 88%
rename from src/util/exthtbl.mli
rename to src/popop_lib/exthtbl.mli
index de0384eda..5f3ea84a9 100644
--- a/src/util/exthtbl.mli
+++ b/src/popop_lib/exthtbl.mli
@@ -1,13 +1,15 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
+(***********************************************************************)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(***********************************************************************)
type statistics = {
@@ -58,7 +60,7 @@ module type HashedType =
(provided objects do not contain floats)
- ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
for comparing objects by structure
- and handling {!Pervasives.nan} correctly
+ and handling {!Stdlib.nan} correctly
- ([(==)], {!Hashtbl.hash}) for comparing objects by physical
equality (e.g. for mutable or cyclic objects). *)
end
@@ -96,7 +98,7 @@ module type S =
(** change the value of all the key,
don't modify the table during this run *)
- val memo : int -> (key -> 'a) -> key -> 'a
+ val memo : (key -> 'a) -> 'a t -> key -> 'a
(** convenience function, memoize a function *)
val is_empty : 'a t -> bool
diff --git a/src/popop_lib/extmap.ml b/src/popop_lib/extmap.ml
new file mode 100644
index 000000000..4daaf9f3e
--- /dev/null
+++ b/src/popop_lib/extmap.ml
@@ -0,0 +1,667 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* This file originates from the OCaml v 3.12 Standard Library.
+ It was extended and modified for the needs of the Why3 project.
+ It is distributed under the terms of its initial license, which
+ is provided in the file OCAML-LICENSE. *)
+
+module type S = sig
+ include Map_intf.Map with type 'a data = 'a
+
+ type 'a view =
+ | Empty
+ | Node of 'a view * key * 'a * 'a view * int
+
+ val view: 'a t -> 'a view
+
+end
+
+module Make(Ord: Map_intf.OrderedType) = struct
+ type key = Ord.t
+ type 'a data = 'a
+ type 'a t =
+ Empty
+ | Node of 'a t * key * 'a * 'a t * int
+
+ type 'a view = 'a t =
+ | Empty
+ | Node of 'a view * key * 'a * 'a view * int
+
+ let view x = x
+
+ let height = function
+ Empty -> 0
+ | Node(_,_,_,_,h) -> h
+
+ let create l x d r =
+ let hl = height l and hr = height r in
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ let singleton x d = Node(Empty, x, d, Empty, 1)
+
+ let bal l x d r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Map.bal"
+ | Node(ll, lv, ld, lr, _) ->
+ if height ll >= height lr then
+ create ll lv ld (create lr x d r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Map.bal"
+ | Node(lrl, lrv, lrd, lrr, _)->
+ create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rl, rv, rd, rr, _) ->
+ if height rr >= height rl then
+ create (create l x d rl) rv rd rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rll, rlv, rld, rlr, _) ->
+ create (create l x d rll) rlv rld (create rlr rv rd rr)
+ end
+ end else
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
+ let rec add x data = function
+ Empty ->
+ Node(Empty, x, data, Empty, 1)
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ Node(l, x, data, r, h)
+ else if c < 0 then
+ bal (add x data l) v d r
+ else
+ bal l v d (add x data r)
+
+ let rec find x = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then d
+ else find x (if c < 0 then l else r)
+
+ let rec mem x = function
+ Empty ->
+ false
+ | Node(l, v, _d, r, _) ->
+ let c = Ord.compare x v in
+ c = 0 || mem x (if c < 0 then l else r)
+
+ let rec min_binding = function
+ Empty -> raise Not_found
+ | Node(Empty, x, d, _r, _) -> (x, d)
+ | Node(l, _x, _d, _r, _) -> min_binding l
+
+ let rec max_binding = function
+ Empty -> raise Not_found
+ | Node(_l, x, d, Empty, _) -> (x, d)
+ | Node(_l, _x, _d, r, _) -> max_binding r
+
+ let rec remove_min_binding = function
+ Empty -> invalid_arg "Map.remove_min_elt"
+ | Node(Empty, _x, _d, r, _) -> r
+ | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
+
+ let merge t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (_, _) ->
+ let (x, d) = min_binding t2 in
+ bal t1 x d (remove_min_binding t2)
+
+ let merge_bal = merge
+
+ let rec remove x = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, _h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ merge l r
+ else if c < 0 then
+ bal (remove x l) v d r
+ else
+ bal l v d (remove x r)
+
+ let rec iter f = function
+ Empty -> ()
+ | Node(l, v, d, r, _) ->
+ iter f l; f v d; iter f r
+
+ let rec map f = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ let l' = map f l in
+ let d' = f d in
+ let r' = map f r in
+ Node(l', v, d', r', h)
+
+ let rec mapi f = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ let l' = mapi f l in
+ let d' = f v d in
+ let r' = mapi f r in
+ Node(l', v, d', r', h)
+
+ let rec fold f m accu =
+ match m with
+ Empty -> accu
+ | Node(l, v, d, r, _) ->
+ fold f r (f v d (fold f l accu))
+
+ let rec for_all p = function
+ Empty -> true
+ | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r
+
+ let rec exists p = function
+ Empty -> false
+ | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
+
+ let filter p s =
+ let rec filt accu = function
+ | Empty -> accu
+ | Node(l, v, d, r, _) ->
+ filt (filt (if p v d then add v d accu else accu) l) r in
+ filt Empty s
+
+ let partition p s =
+ let rec part (t, f as accu) = function
+ | Empty -> accu
+ | Node(l, v, d, r, _) ->
+ part (part (if p v d then (add v d t, f)
+ else (t, add v d f)) l) r in
+ part (Empty, Empty) s
+
+ (* Same as create and bal, but no assumptions are made on the
+ relative heights of l and r. *)
+
+ let rec join l v d r =
+ match (l, r) with
+ (Empty, _) -> add v d r
+ | (_, Empty) -> add v d l
+ | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
+ if lh > rh + 2 then bal ll lv ld (join lr v d r) else
+ if rh > lh + 2 then bal (join l v d rl) rv rd rr else
+ create l v d r
+
+ (* Merge two trees l and r into one.
+ All elements of l must precede the elements of r.
+ No assumption on the heights of l and r. *)
+
+ let concat t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (_, _) ->
+ let (x, d) = min_binding t2 in
+ join t1 x d (remove_min_binding t2)
+
+ let concat_or_join t1 v d t2 =
+ match d with
+ | Some d -> join t1 v d t2
+ | None -> concat t1 t2
+
+ let rec split x = function
+ Empty ->
+ (Empty, None, Empty)
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then (l, Some d, r)
+ else if c < 0 then
+ let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
+ else
+ let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
+
+ let rec merge f s1 s2 =
+ match (s1, s2) with
+ (Empty, Empty) -> Empty
+ | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
+ let (l2, d2, r2) = split v1 s2 in
+ concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
+ | (_, Node (l2, v2, d2, r2, _h2)) ->
+ let (l1, d1, r1) = split v2 s1 in
+ concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
+ | _ ->
+ assert false
+
+ type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
+
+ let rec cons_enum m e =
+ match m with
+ Empty -> e
+ | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
+
+ let compare cmp m1 m2 =
+ let rec compare_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> 0
+ | (End, _) -> -1
+ | (_, End) -> 1
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ let c = Ord.compare v1 v2 in
+ if c <> 0 then c else
+ let c = cmp d1 d2 in
+ if c <> 0 then c else
+ compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in compare_aux (cons_enum m1 End) (cons_enum m2 End)
+
+ let equal cmp m1 m2 =
+ let rec equal_aux e1 e2 =
+ match (e1, e2) with
+ (End, End) -> true
+ | (End, _) -> false
+ | (_, End) -> false
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ Ord.compare v1 v2 = 0 && cmp d1 d2 &&
+ equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
+ in equal_aux (cons_enum m1 End) (cons_enum m2 End)
+
+
+ let pp pp fmt m =
+ Pp.iter2 iter Pp.arrow Pp.colon
+ Ord.pp pp
+ fmt m
+
+ let rec cardinal = function
+ Empty -> 0
+ | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r
+
+ let rec keys_aux accu = function
+ Empty -> accu
+ | Node(l, v, _, r, _) -> keys_aux (v :: keys_aux accu r) l
+
+ let keys s =
+ keys_aux [] s
+
+ let rec bindings_aux accu = function
+ Empty -> accu
+ | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l
+
+ let bindings s =
+ bindings_aux [] s
+
+ let rec values_aux accu = function
+ Empty -> accu
+ | Node(l, _, v, r, _) -> values_aux (v :: values_aux accu r) l
+
+ let values s =
+ values_aux [] s
+
+ let choose = min_binding
+
+ (** Added into why stdlib version *)
+
+ let rec change f x = function
+ | Empty ->
+ begin match f None with
+ | None -> Empty
+ | Some d -> Node(Empty, x, d, Empty, 1)
+ end
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ (* concat or bal *)
+ match f (Some d) with
+ | None -> merge_bal l r
+ | Some d -> Node(l, x, d, r, h)
+ else if c < 0 then
+ bal (change f x l) v d r
+ else
+ bal l v d (change f x r)
+
+ let rec add_change empty add x b = function
+ | Empty -> Node(Empty, x, empty b, Empty, 1)
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ Node(l, x, add b d, r, h)
+ else if c < 0 then
+ bal (add_change empty add x b l) v d r
+ else
+ bal l v d (add_change empty add x b r)
+
+ let rec union f s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> t2
+ | (t1, Empty) -> t1
+ | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
+ if h1 >= h2 then
+ if h2 = 1 then
+ change (function None -> Some d2 | Some d1 -> f v2 d1 d2) v2 s1
+ else begin
+ let (l2, d2, r2) = split v1 s2 in
+ match d2 with
+ | None -> join (union f l1 l2) v1 d1 (union f r1 r2)
+ | Some d2 ->
+ concat_or_join (union f l1 l2) v1 (f v1 d1 d2)
+ (union f r1 r2)
+ end
+ else
+ if h1 = 1 then
+ change (function None -> Some d1 | Some d2 -> f v1 d1 d2) v1 s2
+ else begin
+ let (l1, d1, r1) = split v2 s1 in
+ match d1 with
+ | None -> join (union f l1 l2) v2 d2 (union f r1 r2)
+ | Some d1 ->
+ concat_or_join (union f l1 l2) v2 (f v2 d1 d2)
+ (union f r1 r2)
+ end
+
+ let rec union_merge f s1 s2 =
+ match (s1, s2) with
+ (Empty, Empty) -> Empty
+ | (t1,Empty) -> t1
+ | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
+ let (l2, d2, r2) = split v1 s2 in
+ begin match d2 with
+ | None -> join (union_merge f l1 l2) v1 d1 (union_merge f r1 r2)
+ | Some d2 ->
+ concat_or_join (union_merge f l1 l2) v1 (f v1 (Some d1) d2)
+ (union_merge f r1 r2)
+ end
+ | (_, Node (l2, v2, d2, r2, _h2)) ->
+ let (l1, d1, r1) = split v2 s1 in
+ concat_or_join (union_merge f l1 l2) v2 (f v2 d1 d2)
+ (union_merge f r1 r2)
+
+ let rec inter f s1 s2 =
+ match (s1, s2) with
+ | (Empty, _) | (_, Empty) -> Empty
+ | (Node(l1, v1, d1, r1, _), t2) ->
+ match split v1 t2 with
+ (l2, None, r2) ->
+ concat (inter f l1 l2) (inter f r1 r2)
+ | (l2, Some d2, r2) ->
+ concat_or_join (inter f l1 l2) v1 (f v1 d1 d2) (inter f r1 r2)
+
+
+ let rec diff f s1 s2 =
+ match (s1, s2) with
+ (Empty, _t2) -> Empty
+ | (t1, Empty) -> t1
+ | (Node(l1, v1, d1, r1, _), t2) ->
+ match split v1 t2 with
+ | (l2, None, r2) -> join (diff f l1 l2) v1 d1 (diff f r1 r2)
+ | (l2, Some d2, r2) ->
+ concat_or_join (diff f l1 l2) v1 (f v1 d1 d2) (diff f r1 r2)
+
+
+ let rec submap pr s1 s2 =
+ match (s1, s2) with
+ | Empty, _ -> true
+ | _, Empty -> false
+ | Node (l1, v1, d1, r1, _), (Node (l2, v2, d2, r2, _) as t2) ->
+ let c = Ord.compare v1 v2 in
+ if c = 0 then
+ pr v1 d1 d2 && submap pr l1 l2 && submap pr r1 r2
+ else if c < 0 then
+ submap pr (Node (l1, v1, d1, Empty, 0)) l2 && submap pr r1 t2
+ else
+ submap pr (Node (Empty, v1, d1, r1, 0)) r2 && submap pr l1 t2
+
+
+ let rec disjoint pr s1 s2 =
+ match (s1, s2) with
+ | Empty, _ -> true
+ | _, Empty -> true
+ | Node (l1, v1, d1, r1, _), (Node (l2, v2, d2, r2, _) as t2) ->
+ let c = Ord.compare v1 v2 in
+ if c = 0 then
+ pr v1 d1 d2 && disjoint pr l1 l2 && disjoint pr r1 r2
+ else if c < 0 then
+ disjoint pr (Node (l1, v1, d1, Empty, 0)) l2 && disjoint pr r1 t2
+ else
+ disjoint pr (Node (Empty, v1, d1, r1, 0)) r2 && disjoint pr l1 t2
+
+ let set_union m1 m2 = union (fun _ x _ -> Some x) m1 m2
+ let set_inter m1 m2 = inter (fun _ x _ -> Some x) m1 m2
+ let set_diff m1 m2 = diff (fun _ _ _ -> None) m1 m2
+ let set_submap m1 m2 = submap (fun _ _ _ -> true) m1 m2
+ let set_disjoint m1 m2 = disjoint (fun _ _ _ -> false) m1 m2
+ let set_compare m1 m2 = compare (fun _ _ -> 0) m1 m2
+ let set_equal m1 m2 = equal (fun _ _ -> true) m1 m2
+
+ let rec find_def def x = function
+ Empty -> def
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then d
+ else find_def def x (if c < 0 then l else r)
+
+ let rec find_opt x = function
+ Empty -> None
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then Some d
+ else find_opt x (if c < 0 then l else r)
+
+ let rec find_exn exn x = function
+ Empty -> raise exn
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then d
+ else find_exn exn x (if c < 0 then l else r)
+
+ let rec find_remove x = function
+ Empty ->
+ Empty, None
+ | Node(l, v, d, r, _h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ merge_bal l r, Some d
+ else if c < 0 then
+ let l,f = find_remove x l in
+ bal l v d r,f
+ else
+ let r,f = find_remove x r in
+ bal l v d r,f
+
+ let rec find_smaller_opt cand x = function
+ | Empty -> cand
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then Some(x,d)
+ else if c < 0 then
+ find_smaller_opt cand x l
+ else
+ find_smaller_opt (Some(x,d)) x r
+
+ let find_smaller_opt x t = find_smaller_opt None x t
+
+ let rec map_filter f = function
+ Empty -> Empty
+ | Node(l, v, d, r, _h) ->
+ concat_or_join (map_filter f l) v (f d) (map_filter f r)
+
+ let rec mapi_filter f = function
+ Empty -> Empty
+ | Node(l, v, d, r, _h) ->
+ concat_or_join (mapi_filter f l) v (f v d) (mapi_filter f r)
+
+ let rec mapi_fold f m acc =
+ match m with
+ Empty -> acc, Empty
+ | Node(l, v, d, r, h) ->
+ let acc,l' = mapi_fold f l acc in
+ let acc,d' = f v d acc in
+ let acc,r' = mapi_fold f r acc in
+ acc,Node(l', v, d', r', h)
+
+ let fold2_inter f m1 m2 acc =
+ let rec aux acc e1_0 e2_0 =
+ match (e1_0, e2_0) with
+ (End, End) -> acc
+ | (End, _) -> acc
+ | (_, End) -> acc
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ let c = Ord.compare v1 v2 in
+ if c = 0 then
+ aux (f v1 d1 d2 acc) (cons_enum r1 e1) (cons_enum r2 e2)
+ else if c < 0 then
+ aux acc (cons_enum r1 e1) e2_0
+ else
+ aux acc e1_0 (cons_enum r2 e2)
+ in aux acc (cons_enum m1 End) (cons_enum m2 End)
+
+ let fold2_union f m1 m2 acc =
+ let rec aux acc e1_0 e2_0 =
+ match (e1_0, e2_0) with
+ (End, End) -> acc
+ | (End, More(v2, d2, r2, e2)) ->
+ aux (f v2 None (Some d2) acc) End (cons_enum r2 e2)
+ | (More(v1, d1, r1, e1), End) ->
+ aux (f v1 (Some d1) None acc) (cons_enum r1 e1) End
+ | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
+ let c = Ord.compare v1 v2 in
+ if c = 0 then
+ aux (f v1 (Some d1) (Some d2) acc)
+ (cons_enum r1 e1) (cons_enum r2 e2)
+ else if c < 0 then
+ aux (f v1 (Some d1) None acc) (cons_enum r1 e1) e2_0
+ else
+ aux (f v2 None (Some d2) acc) e1_0 (cons_enum r2 e2)
+ in aux acc (cons_enum m1 End) (cons_enum m2 End)
+
+ let translate f m =
+ let rec aux last = function
+ | Empty -> Empty,last
+ | Node(l, v, d, r, h) ->
+ let l,last = aux last l in
+ let v = f v in
+ begin match last with
+ | None -> ()
+ | Some last ->
+ if Ord.compare last v >= 0
+ then invalid_arg "Map.translate : given function incorrect"
+ end;
+ let r,last = aux (Some v) r in
+ Node(l,v,d,r,h),last in
+ let m,_ = aux None m in m
+
+ let rec mapi_filter_fold f m acc =
+ match m with
+ Empty -> acc, Empty
+ | Node(l, v, d, r, _h) ->
+ let acc,l' = mapi_filter_fold f l acc in
+ let acc,d' = f v d acc in
+ let acc,r' = mapi_filter_fold f r acc in
+ acc, concat_or_join l' v d' r'
+
+ let add_new e x v m = change (function
+ | Some _ -> raise e
+ | None -> Some v) x m
+
+ let is_num_elt n m =
+ try
+ fold (fun _ _ n -> if n < 0 then raise Exit else n-1) m n = 0
+ with Exit -> false
+
+ (** the goal is to choose randomly but often the same than [choose] *)
+ let choose_rnd f m =
+ let rec aux f m ret =
+ match m with
+ | Empty -> ()
+ | Node(l, v, d, r, _) ->
+ aux f l ret;
+ if f () then (ret := (v,d); raise Exit) else aux f r ret
+ in
+ let ret = ref (Obj.magic 0) in
+ try
+ aux f m ret;
+ choose m
+ with Exit -> !ret
+
+ let start_enum s = cons_enum s End
+
+ let val_enum = function
+ | End -> None
+ | More (v,d,_,_) -> Some (v,d)
+
+ let next_enum = function
+ | End -> End
+ | More(_,_,r,e) -> cons_enum r e
+
+ let rec cons_ge_enum k m e =
+ match m with
+ Empty -> e
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare k v in
+ if c = 0 then More(v,d,r,e)
+ else if c < 0 then cons_ge_enum k l (More(v, d, r, e))
+ else (* c > 0 *) cons_ge_enum k r e
+
+ let start_ge_enum k m = cons_ge_enum k m End
+
+ let rec next_ge_enum k l0 = function
+ | End -> start_ge_enum k l0
+ | More(v,_,r,e) as e0 ->
+ let c = Ord.compare k v in
+ if c = 0 then e0
+ else if c < 0 then cons_ge_enum k l0 e0
+ else (* c > 0 *) next_ge_enum k r e
+
+ let next_ge_enum k e = next_ge_enum k Empty e
+
+ let rec fold_left f accu m =
+ match m with
+ Empty -> accu
+ | Node(l, v, d, r, _) ->
+ fold_left f (f (fold_left f accu l) v d) r
+
+ let rec fold_decr f accu m =
+ match m with
+ Empty -> accu
+ | Node(l, v, d, r, _) ->
+ fold_decr f (f (fold_decr f accu r) v d) l
+
+ let of_list l =
+ List.fold_left (fun acc (k,d) -> add k d acc) empty l
+
+ let add_opt x o m =
+ match o with
+ | None -> remove x m
+ | Some y -> add x y m
+
+ let check_invariant m =
+ let rec aux = function
+ | Empty -> 0, true
+ | Node(l,_,_,r,h) ->
+ let h1,b1 = aux l in
+ let h2,b2 = aux r in
+ if b1 && b2
+ then
+ let h' = (if h1 >= h2 then h1 + 1 else h2 + 1) in
+ h', h' = h
+ else -1,false in
+ snd (aux m)
+
+end
diff --git a/src/util/extmap.mli b/src/popop_lib/extmap.mli
similarity index 90%
rename from src/util/extmap.mli
rename to src/popop_lib/extmap.mli
index e044ef20c..a3eea0f8e 100644
--- a/src/util/extmap.mli
+++ b/src/popop_lib/extmap.mli
@@ -26,7 +26,16 @@
and insertion take time logarithmic in the size of the map.
*)
-module type S = Map_intf.Map with type 'a data = 'a
+module type S = sig
+ include Map_intf.Map with type 'a data = 'a
+
+ type 'a view =
+ | Empty
+ | Node of 'a view * key * 'a * 'a view * int
+
+ val view: 'a t -> 'a view
+
+end
module Make (Ord : Map_intf.OrderedType) : S with type key = Ord.t
(** Functor building an implementation of the map structure
diff --git a/src/util/extset.ml b/src/popop_lib/extset.ml
similarity index 77%
rename from src/util/extset.ml
rename to src/popop_lib/extset.ml
index c27aa03dc..6c86e2945 100644
--- a/src/util/extset.ml
+++ b/src/popop_lib/extset.ml
@@ -1,13 +1,15 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
+(***********************************************************************)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(***********************************************************************)
module type S = Map_intf.Set
@@ -54,13 +56,13 @@ module MakeOfMap (M: Map_intf.MapUnit) = struct
let add_new e x s = M.add_new e x () s
let is_num_elt n m = M.is_num_elt n m
let of_list l = List.fold_left (fun acc a -> add a acc) empty l
+ let pp _ = assert false (*M.pp Pp.unit*)
end
module Make(Ord: Map_intf.OrderedType) = MakeOfMap(Extmap.Make(Ord))
module MakeHashcons(MH:Map_intf.Map_hashcons with type 'a data = unit):
- Map_intf.Set_hashcons with type 'a M.data = unit
- and type 'a poly = 'a MH.poly
+ Map_intf.Set_hashcons with type 'a poly = 'a MH.poly
and type M.key = MH.key
= struct
include MakeOfMap(MH)
diff --git a/src/util/extset.mli b/src/popop_lib/extset.mli
similarity index 62%
rename from src/util/extset.mli
rename to src/popop_lib/extset.mli
index 80f9c9cbe..609145e64 100644
--- a/src/util/extset.mli
+++ b/src/popop_lib/extset.mli
@@ -1,13 +1,15 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
+(***********************************************************************)
+(* OCaml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. *)
+(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
+(***********************************************************************)
(** Sets over ordered types *)
@@ -16,7 +18,6 @@ module type S = Map_intf.Set
module MakeOfMap (M : Map_intf.MapUnit) : S with type 'a M.t = 'a M.t
and type M.key = M.key
- and type 'a M.data = 'a M.data
(** Functor building an implementation of the set structure
given a totally ordered type. *)
@@ -25,8 +26,7 @@ module Make (Ord : Map_intf.OrderedType) : S with type M.key = Ord.t
given a totally ordered type. *)
module MakeHashcons(MH:Map_intf.Map_hashcons with type 'a data = unit):
- Map_intf.Set_hashcons with type 'a M.data = unit
- and type 'a poly = 'a MH.poly
+ Map_intf.Set_hashcons with type 'a poly = 'a MH.poly
and type M.key = MH.key
(** Functor building an implementation of the hasconsed set structure
given a totally ordered hashconsed map. *)
diff --git a/src/util/hashcons.ml b/src/popop_lib/hashcons.ml
similarity index 93%
rename from src/util/hashcons.ml
rename to src/popop_lib/hashcons.ml
index 7175b6596..83f54d339 100644
--- a/src/util/hashcons.ml
+++ b/src/popop_lib/hashcons.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -9,7 +9,7 @@
(* *)
(********************************************************************)
-open Stdlib
+open Popop_stdlib
(*s Hash tables for hash-consing. (Some code is borrowed from the ocaml
standard library, which is copyright 1996 INRIA.) *)
@@ -20,7 +20,7 @@ module type HashedType =
val hash : t -> int
val set_tag : int -> t -> t
val tag : t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module type S =
@@ -69,10 +69,10 @@ struct
type t = H.t
let hash = H.tag
let equal ts1 ts2 = ts1 == ts2
- let compare ts1 ts2 = Pervasives.compare (H.tag ts1) (H.tag ts2)
- let print = H.print
+ let compare ts1 ts2 = Stdlib.compare (H.tag ts1) (H.tag ts2)
+ let pp = H.pp
end
-
+ include T
include MkDatatype(T)
end
@@ -125,10 +125,10 @@ struct
type t = H.t
let hash = H.tag
let equal ts1 ts2 = ts1 == ts2
- let compare ts1 ts2 = Pervasives.compare (H.tag ts1) (H.tag ts2)
- let print = H.print
+ let compare ts1 ts2 = Stdlib.compare (H.tag ts1) (H.tag ts2)
+ let pp = H.pp
end
-
+ include T
include MkDatatype(T)
end
diff --git a/src/util/hashcons.mli b/src/popop_lib/hashcons.mli
similarity index 96%
rename from src/util/hashcons.mli
rename to src/popop_lib/hashcons.mli
index 5034ee5bb..b47719db5 100644
--- a/src/util/hashcons.mli
+++ b/src/popop_lib/hashcons.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -29,12 +29,12 @@ module type HashedType =
val hash : t -> int
val set_tag : int -> t -> t
val tag : t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module type S =
sig
- include Stdlib.Datatype
+ include Popop_stdlib.Datatype
val hashcons : t -> t
(** [hashcons n] hash-cons the value [n] i.e. returns
diff --git a/src/popop_lib/intmap.ml b/src/popop_lib/intmap.ml
new file mode 100644
index 000000000..5ca0731c1
--- /dev/null
+++ b/src/popop_lib/intmap.ml
@@ -0,0 +1,1726 @@
+(*************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(*************************************************************************)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Bit library --- *)
+(* -------------------------------------------------------------------------- *)
+
+let hsb =
+ let hsb p = if p land 2 != 0 then 1 else 0
+ in let hsb p = let n = p lsr 2 in if n != 0 then 2 + hsb n else hsb p
+ in let hsb p = let n = p lsr 4 in if n != 0 then 4 + hsb n else hsb p
+ in let hsb = Array.init 256 hsb
+ in let hsb p = let n = p lsr 8 in if n != 0 then 8 + hsb.(n) else hsb.(p)
+ in let hsb p = let n = p lsr 16 in if n != 0 then 16 + hsb n else hsb p
+ in match Sys.word_size with
+ | 32 -> hsb
+ | 64 -> (function p -> let n = p lsr 32 in
+ if n != 0 then 32 + hsb n else hsb p)
+ | _ -> assert false (** absurd: No other possible achitecture supported *)
+
+let highest_bit x = 1 lsl (hsb x)
+let lowest_bit x = x land (-x)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Bit utilities --- *)
+(* -------------------------------------------------------------------------- *)
+let decode_mask p = lowest_bit (lnot p)
+
+let branching_bit p0 p1 = highest_bit (p0 lxor p1)
+let mask p m = (p lor (m-1)) land (lnot m)
+
+let zero_bit_int k m = (k land m) == 0
+let zero_bit k p = zero_bit_int k (decode_mask p)
+
+let match_prefix_int k p m = (mask k m) == p
+let match_prefix k p = match_prefix_int k p (decode_mask p)
+
+let included_mask_int m n =
+ (* m mask is strictly included into n *)
+ (* can not use (m < n) when n is (1 lsl 62) = min_int < 0 *)
+ (* must use (0 < (n-m) instead *)
+ 0 > n - m
+(* let included_mask p q = included_mask_int (decode_mask p) (decode_mask q) *)
+
+let included_prefix p q =
+ let m = decode_mask p in
+ let n = decode_mask q in
+ included_mask_int m n && match_prefix_int q p m
+
+
+(* -------------------------------------------------------------------------- *)
+(* --- Debug --- *)
+(* -------------------------------------------------------------------------- *)
+
+let pp_mask m fmt p =
+ begin
+ let bits = Array.make 63 false in
+ let last = ref 0 in
+ for i = 0 to 62 do
+ let u = 1 lsl i in
+ if u land p <> 0 then
+ bits.(i) <- true ;
+ if u == m then last := i ;
+ done ;
+ Format.pp_print_char fmt '*' ;
+ for i = !last - 1 downto 0 do
+ Format.pp_print_char fmt (if bits.(i) then '1' else '0') ;
+ done ;
+ end
+
+let pp_bits fmt k =
+ begin
+ let bits = Array.make 63 false in
+ let last = ref 0 in
+ for i = 0 to 62 do
+ if (1 lsl i) land k <> 0 then
+ ( bits.(i) <- true ;
+ if i > !last then last := i ) ;
+ done ;
+ for i = !last downto 0 do
+ Format.pp_print_char fmt (if bits.(i) then '1' else '0') ;
+ done ;
+ end
+
+(* ---------------------------------------------------------------------- *)
+(* --- Patricia Trees By L. Correnson & P. Baudin & F. Bobot --- *)
+(* ---------------------------------------------------------------------- *)
+
+module Make(K:Map_intf.TaggedEqualType) :
+ Map_intf.Gen_Map_hashcons with type NT.key = K.t = struct
+
+ module Gen(G:sig
+ type (+'a) t
+ type 'a data
+ type 'a view = private
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a t * 'a t
+ val view: 'a data t -> 'a data view
+ val mk_Empty: 'a data t
+ val mk_Lf: K.t -> 'a data -> 'a data t
+ val mk_Br: int -> 'a data t -> 'a data t -> 'a data t
+ val ktag : 'a data t -> int
+ end)
+ = struct
+ open G
+
+ type key = K.t
+ type 'a data = 'a G.data
+ type 'a t = 'a G.t
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Smart Constructors --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let empty = mk_Empty
+ let singleton = mk_Lf
+
+ let br p t0 t1 = match view t0 , view t1 with
+ | Empty,_ -> t1
+ | _,Empty -> t0
+ | _ -> mk_Br p t0 t1
+
+ let lf k = function None -> mk_Empty | Some x -> mk_Lf k x
+
+ (* good sharing *)
+ let lf0 k x' t' = function
+ | None -> mk_Empty
+ | Some x -> if x == x' then t' else mk_Lf k x
+
+ (* good sharing *)
+ let br0 p t0' t1' t' t0 = match view t0 with
+ | Empty -> t1'
+ | _ -> if t0' == t0 then t' else mk_Br p t0 t1'
+
+ (* good sharing *)
+ let br1 p t0' t1' t' t1 = match view t1 with
+ | Empty -> t0'
+ | _ -> if t1' == t1 then t' else mk_Br p t0' t1
+
+ let join p t0 q t1 =
+ let m = branching_bit p q in
+ let r = mask p m in
+ if zero_bit p r
+ then mk_Br r t0 t1
+ else mk_Br r t1 t0
+
+ let side p q = (* true this side, false inverse *)
+ let m = branching_bit p q in
+ let r = mask p m in
+ zero_bit p r
+
+ (* t0 and t1 has different prefix, but best common prefix is unknown *)
+ let glue t0 t1 =
+ match view t0 , view t1 with
+ | Empty,_ -> t1
+ | _,Empty -> t0
+ | _,_ -> join (ktag t0) t0 (ktag t1) t1
+
+
+ let glue' ~old ~cur ~other ~all =
+ if old == cur then all else glue cur other
+
+ let glue0 t0 t0' t1' t' =
+ if t0 == t0' then t' else glue t0 t1'
+
+ let glue1 t1 t0' t1' t' =
+ if t1 == t1' then t' else glue t0' t1
+
+ let glue01 t0 t1 t0' t1' t' =
+ if t0 == t0' && t1 == t1' then t' else glue t0 t1
+
+ let glue2 t0 t1 t0' t1' t' s0' s1' s' =
+ if t0 == s0' && t1 == s1' then s' else
+ if t0 == t0' && t1 == t1' then t' else glue t0 t1
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Access API --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let is_empty x = match view x with
+ | Empty -> true
+ | Lf _ | Br _ -> false
+
+ let size t =
+ let rec walk n t = match view t with
+ | Empty -> n
+ | Lf _ -> succ n
+ | Br(_,a,b) -> walk (walk n a) b
+ in walk 0 t
+
+ let cardinal = size
+
+ let rec mem k t = match view t with
+ | Empty -> false
+ | Lf(i,_) -> K.equal i k
+ | Br(p,t0,t1) ->
+ match_prefix (K.tag k) p &&
+ mem k (if zero_bit (K.tag k) p then t0 else t1)
+
+ let rec findq k t = match view t with
+ | Empty -> raise Not_found
+ | Lf(i,x) -> if K.equal k i then (x,t) else raise Not_found
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ findq k (if zero_bit (K.tag k) p then t0 else t1)
+ else
+ raise Not_found
+
+ let rec find_exn exn k t = match view t with
+ | Empty -> raise exn
+ | Lf(i,x) -> if K.equal k i then x else raise exn
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ find_exn exn k (if zero_bit (K.tag k) p then t0 else t1)
+ else
+ raise exn
+
+ let find k m = find_exn Not_found k m
+
+ let rec find_opt k t = match view t with
+ | Empty -> None
+ | Lf(i,x) -> if K.equal k i then Some x else None
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ find_opt k (if zero_bit (K.tag k) p then t0 else t1)
+ else
+ None
+
+ let rec find_def def k t = match view t with
+ | Empty -> def
+ | Lf(i,x) -> if K.equal k i then x else def
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ find_def def k (if zero_bit (K.tag k) p then t0 else t1)
+ else
+ def
+
+ (* good sharing *)
+ let rec find_remove k t = match view t with
+ | Empty -> mk_Empty, None
+ | Lf(i,y) ->
+ if K.equal i k then
+ mk_Empty, Some y
+ else
+ t, None
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ (* k belongs to tree *)
+ if zero_bit (K.tag k) p
+ then let t0', r = find_remove k t0 in
+ br0 p t0 t1 t t0', r (* k is in t0 *)
+ else let t1', r = find_remove k t1 in
+ br1 p t0 t1 t t1', r (* k is in t1 *)
+ else
+ (* k is disjoint from tree *)
+ t, None
+
+ (** shouldn't be used at top *)
+ let rec max_binding_opt t = match view t with
+ | Empty -> None
+ | Lf(k,x) -> Some(k,x)
+ | Br(_,_,t1) -> max_binding_opt t1
+
+ let rec find_smaller_opt' cand k t = match view t with
+ | Empty -> assert false
+ | Lf(i,y) ->
+ let c = Stdlib.compare (K.tag i) (K.tag k) in
+ if c <= 0 then Some(i,y)
+ else (* c > 0 *) max_binding_opt cand
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ (* k belongs to tree *)
+ if zero_bit (K.tag k) p
+ then find_smaller_opt' cand k t0
+ else find_smaller_opt' t0 k t1
+ else
+ (* k is disjoint from tree *)
+ if side (K.tag k) p
+ then (* k p *) max_binding_opt cand
+ else (* p k *) max_binding_opt t1
+
+ let find_smaller_opt k t = match view t with
+ | Empty -> None
+ | Br(p,t0,t1) when p = max_int ->
+ (* k belongs to tree *)
+ if zero_bit (K.tag k) p
+ then find_smaller_opt' t1 k t0
+ else find_smaller_opt' mk_Empty k t1
+ | _ ->
+ find_smaller_opt' mk_Empty k t
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Comparison --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let rec compare cmp s t =
+ if (Obj.magic s) == t then 0 else
+ match view s , view t with
+ | Empty , Empty -> 0
+ | Empty , _ -> (-1)
+ | _ , Empty -> 1
+ | Lf(i,x) , Lf(j,y) ->
+ let ck = Stdlib.compare (K.tag i) (K.tag j) in
+ if ck = 0 then cmp x y else ck
+ | Lf _ , _ -> (-1)
+ | _ , Lf _ -> 1
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ let cp = Stdlib.compare p q in
+ if cp <> 0 then cp else
+ let c0 = compare cmp s0 t0 in
+ if c0 <> 0 then c0 else
+ compare cmp s1 t1
+
+ let rec equal eq s t =
+ if (Obj.magic s) == t then true else
+ match view s , view t with
+ | Empty , Empty -> true
+ | Lf(i,x) , Lf(j,y) -> K.equal i j && eq x y
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ p==q && equal eq s0 t0 && equal eq s1 t1
+ | _ -> false
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Addition, Insert, Change, Remove --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ (* good sharing *)
+ let rec change phi k x t = match view t with
+ | Empty -> (match phi k x None with
+ | None -> t
+ | Some w -> mk_Lf k w)
+ | Lf(i,y) ->
+ if K.equal i k then
+ lf0 k y t (phi k x (Some y))
+ else
+ (match phi k x None with
+ | None -> t
+ | Some w -> let s = mk_Lf k w in
+ join (K.tag k) s (K.tag i) t)
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ (* k belongs to tree *)
+ if zero_bit (K.tag k) p
+ then br0 p t0 t1 t (change phi k x t0) (* k is in t0 *)
+ else br1 p t0 t1 t (change phi k x t1) (* k is in t1 *)
+ else
+ (* k is disjoint from tree *)
+ (match phi k x None with
+ | None -> t
+ | Some w -> let s = mk_Lf k w in
+ join (K.tag k) s p t)
+
+ (* good sharing *)
+ let insert f k x = change (fun _k x -> function
+ | None -> Some x
+ | Some old -> Some (f k x old)) k x
+
+ (* good sharing *)
+ let add k x m = change (fun _k x _old -> Some x) k x m
+
+ (* good sharing *)
+ let remove k m = change (fun _k () _old -> None) k () m
+
+ (* good sharing *)
+ let add_new e x v m = change (fun _k (e,v) -> function
+ | Some _ -> raise e
+ | None -> Some v) x (e,v) m
+
+ (* good sharing *)
+ let rec add_change empty add k b t = match view t with
+ | Empty -> mk_Lf k (empty b)
+ | Lf(i,y) ->
+ if K.equal i k then
+ let y' = (add b y) in
+ if y == y' then t else mk_Lf i y'
+ else
+ let s = mk_Lf k (empty b) in
+ join (K.tag k) s (K.tag i) t
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ (* k belongs to tree *)
+ if zero_bit (K.tag k) p
+ then mk_Br p (add_change empty add k b t0) t1 (* k is in t0 *)
+ else mk_Br p t0 (add_change empty add k b t1) (* k is in t1 *)
+ else
+ (* k is disjoint from tree *)
+ let s = mk_Lf k (empty b) in
+ join (K.tag k) s p t
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Map --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let mapi phi t =
+ let rec mapi phi t = match view t with
+ | Empty -> mk_Empty
+ | Lf(k,x) -> mk_Lf k (phi k x)
+ | Br(p,t0,t1) ->
+ let t0 = mapi phi t0 in
+ let t1 = mapi phi t1 in
+ mk_Br p t0 t1
+ in match view t with (* in order to be sorted *)
+ | Empty -> mk_Empty
+ | Lf(k,x) -> mk_Lf k (phi k x)
+ | Br(p,t0,t1) when p = max_int -> let t1 = mapi phi t1 in
+ let t0 = mapi phi t0 in mk_Br p t0 t1
+ | Br(p,t0,t1) -> let t0 = mapi phi t0 in
+ let t1 = mapi phi t1 in mk_Br p t0 t1
+ let map phi = mapi (fun _ x -> phi x)
+
+ let mapf phi t =
+ let rec mapf phi t = match view t with
+ | Empty -> mk_Empty
+ | Lf(k,x) -> lf k (phi k x)
+ | Br(_,t0,t1) -> glue (mapf phi t0) (mapf phi t1)
+ in match view t with (* in order to be sorted *)
+ | Empty -> mk_Empty
+ | Lf(k,x) -> lf k (phi k x)
+ | Br(p,t0,t1) when p = max_int -> let t1 = mapf phi t1 in
+ let t0 = mapf phi t0 in glue t0 t1
+ | Br(_,t0,t1) -> let t0 = mapf phi t0 in
+ let t1 = mapf phi t1 in glue t0 t1
+
+ (* good sharing *)
+ let mapq phi t =
+ let rec mapq phi t = match view t with
+ | Empty -> t
+ | Lf(k,x) -> lf0 k x t (phi k x)
+ | Br(_,t0,t1) ->
+ let t0' = mapq phi t0 in
+ let t1' = mapq phi t1 in
+ glue01 t0' t1' t0 t1 t
+ in match view t with (* to be sorted *)
+ | Empty -> t
+ | Lf(k,x) -> lf0 k x t (phi k x)
+ | Br(p,t0,t1) when p = max_int ->
+ let t1' = mapq phi t1 in
+ let t0' = mapq phi t0 in
+ glue01 t0' t1' t0 t1 t
+ | Br(_,t0,t1) ->
+ let t0' = mapq phi t0 in
+ let t1' = mapq phi t1 in
+ glue01 t0' t1' t0 t1 t
+
+ (** bad sharing but polymorph *)
+ let mapq' :
+ type a b. (key -> a data -> b data option) -> a data t -> b data t=
+ fun phi t ->
+ let rec aux phi t = match view t with
+ | Empty -> mk_Empty
+ | Lf(k,x) -> lf k (phi k x)
+ | Br(_,t0,t1) ->
+ let t0' = aux phi t0 in
+ let t1' = aux phi t1 in
+ glue t0' t1'
+ in match view t with (* to be sorted *)
+ | Empty -> mk_Empty
+ | Lf(k,x) -> lf k (phi k x)
+ | Br(p,t0,t1) when p = max_int ->
+ let t1' = aux phi t1 in
+ let t0' = aux phi t0 in
+ glue t0' t1'
+ | Br(_,t0,t1) ->
+ let t0' = aux phi t0 in
+ let t1' = aux phi t1 in
+ glue t0' t1'
+
+ let filter f m = mapq' (fun k v -> if f k v then Some v else None) m
+ let mapi_filter = mapq'
+ let map_filter f m = mapq' (fun _ v -> f v) m
+
+ (*
+ bad sharing because the input type can be differente of the
+ output type it is possible but currently too many Obj.magic are
+ needed in lf0 and glue01
+ *)
+ let mapi_filter_fold:
+ type a b acc. (key -> a data -> acc -> acc * b data option) ->
+ a data t -> acc -> acc * b data t
+ = fun phi t acc ->
+ let rec aux phi t acc = match view t with
+ | Empty -> acc, mk_Empty
+ | Lf(k,x) -> let acc,x = (phi k x acc) in acc, lf k x
+ | Br(_,t0,t1) ->
+ let acc, t0' = aux phi t0 acc in
+ let acc, t1' = aux phi t1 acc in
+ acc, glue t0' t1'
+ in match view t with (* to be sorted *)
+ | Empty -> acc, mk_Empty
+ | Lf(k,x) -> let acc,x = (phi k x acc) in acc, lf k x
+ | Br(p,t0,t1) when p = max_int ->
+ let acc, t1' = aux phi t1 acc in
+ let acc, t0' = aux phi t0 acc in
+ acc, glue t0' t1'
+ | Br(_,t0,t1) ->
+ let acc, t0' = aux phi t0 acc in
+ let acc, t1' = aux phi t1 acc in
+ acc, glue t0' t1'
+
+ let mapi_fold phi t acc =
+ mapi_filter_fold (fun k v acc ->
+ let acc, v' = phi k v acc in
+ acc, Some v') t acc
+
+ (* good sharing *)
+ let rec partition p t = match view t with
+ | Empty -> (t,t)
+ | Lf(k,x) -> if p k x then t,mk_Empty else mk_Empty,t
+ | Br(_,t0,t1) ->
+ let (t0',u0') = partition p t0 in
+ let (t1',u1') = partition p t1 in
+ if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
+ else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
+ else (glue t0' t1'),(glue u0' u1')
+
+ (* good sharing *)
+ let split k t =
+ let rec aux k t = match view t with
+ | Empty -> assert false (** absurd: only at top *)
+ | Lf(k',x) -> let c = Stdlib.compare (K.tag k) (K.tag k') in
+ if c = 0 then (mk_Empty,Some x,mk_Empty)
+ else if c < 0 then (mk_Empty, None, t)
+ else (* c > 0 *) (t, None, mk_Empty)
+ | Br(p,t0,t1) ->
+ if match_prefix (K.tag k) p then
+ if zero_bit (K.tag k) p
+ then
+ let (t0',r,t1') = aux k t0 in
+ (t0',r,glue' ~old:t0 ~cur:t1' ~other:t1 ~all:t )
+ else
+ let (t0',r,t1') = aux k t1 in
+ (glue' ~old:t1 ~cur:t0' ~other:t0 ~all:t,r,t1')
+ else
+ if side (K.tag k) p
+ then (* k p *) (mk_Empty, None, t)
+ else (* p k *) (t, None, mk_Empty)
+ in match view t with
+ | Empty -> mk_Empty, None, mk_Empty
+ | Br(p,t0,t1) when p = max_int -> (** inverted *)
+ if zero_bit (K.tag k) p
+ then
+ let (t0',r,t1') = aux k t0 in
+ (glue' ~old:t0 ~cur:t0' ~other:t1 ~all:t,r,t1' )
+ else
+ let (t0',r,t1') = aux k t1 in
+ (t0',r,glue' ~old:t1 ~cur:t1' ~other:t0 ~all:t)
+ | _ -> aux k t
+
+ (* good sharing *)
+ let rec partition_split p t = match view t with
+ | Empty -> (t,t)
+ | Lf(k,x) -> let u,v = p k x in (lf0 k x t u), (lf0 k x t v)
+ | Br(_,t0,t1) ->
+ let t0',u0' = partition_split p t0 in
+ let t1',u1' = partition_split p t1 in
+ if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
+ else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
+ else (glue t0' t1'),(glue u0' u1')
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Iter --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let iteri phi t =
+ let rec aux t = match view t with
+ | Empty -> ()
+ | Lf(k,x) -> phi k x
+ | Br(_,t0,t1) -> aux t0 ; aux t1
+ in match view t with (* in order to be sorted *)
+ | Empty -> ()
+ | Lf(k,x) -> phi k x
+ | Br(p,t0,t1) when p = max_int -> aux t1 ; aux t0
+ | Br(_,t0,t1) -> aux t0 ; aux t1
+
+ let iter = iteri
+
+ let foldi phi t e = (* increasing order *)
+ let rec aux t e = match view t with
+ | Empty -> e
+ | Lf(i,x) -> phi i x e
+ | Br(_,t0,t1) -> aux t1 (aux t0 e)
+ in match view t with (* to be sorted *)
+ | Empty -> e
+ | Lf(i,x) -> phi i x e
+ | Br(p,t0,t1) when p = max_int -> aux t0 (aux t1 e)
+ | Br(_,t0,t1) -> aux t1 (aux t0 e)
+
+ let fold = foldi
+
+ let fold_left phi e t = (* increasing order *)
+ let rec aux t e = match view t with
+ | Empty -> e
+ | Lf(k,x) -> phi e k x
+ | Br(_,t0,t1) -> aux t1 (aux t0 e)
+ in match view t with (* to be sorted *)
+ | Empty -> e
+ | Lf(k,x) -> phi e k x
+ | Br(p,t0,t1) when p = max_int -> aux t0 (aux t1 e)
+ | Br(_,t0,t1) -> aux t1 (aux t0 e)
+
+ let foldd phi e t = (* decreasing order *)
+ let rec aux t e = match view t with
+ | Empty -> e
+ | Lf(i,x) -> phi e i x
+ | Br(_,t0,t1) -> aux t0 (aux t1 e)
+ in match view t with (* to be sorted *)
+ | Empty -> e
+ | Lf(i,x) -> phi e i x
+ | Br(p,t0,t1) when p = max_int -> aux t1 (aux t0 e)
+ | Br(_,t0,t1) -> aux t0 (aux t1 e)
+
+
+ let fold_decr = foldd
+
+ (* decreasing order on f to have the list in increasing order *)
+ let mapl f m = foldd (fun a k v -> (f k v)::a) [] m
+ let bindings m = mapl (fun k v -> (k,v)) m
+ let values m = mapl (fun _ v -> v) m
+ let keys m = mapl (fun k _ -> k) m
+
+ let for_all phi t = (* increasing order *)
+ let rec aux t = match view t with
+ | Empty -> true
+ | Lf(k,x) -> phi k x
+ | Br(_,t0,t1) -> aux t0 && aux t1
+ in match view t with (* in order to be sorted *)
+ | Empty -> true
+ | Lf(k,x) -> phi k x
+ | Br(p,t0,t1) when p = max_int -> aux t1 && aux t0
+ | Br(_,t0,t1) -> aux t0 && aux t1
+
+ let exists phi t = (* increasing order *)
+ let rec aux t = match view t with
+ | Empty -> false
+ | Lf(k,x) -> phi k x
+ | Br(_,t0,t1) -> aux t0 || aux t1
+ in match view t with (* in order to be sorted *)
+ | Empty -> false
+ | Lf(k,x) -> phi k x
+ | Br(p,t0,t1) when p = max_int -> aux t1 || aux t0
+ | Br(_,t0,t1) -> aux t0 || aux t1
+
+
+ let min_binding t = (* increasing order *)
+ let rec aux t = match view t with
+ | Empty -> assert false (** absurd: only at top *)
+ | Lf(k,x) -> (k,x)
+ | Br(_,t0,_) -> aux t0
+ in match view t with (* in order to be sorted *)
+ | Empty -> raise Not_found
+ | Lf(k,x) -> (k,x)
+ | Br(p,_,t1) when p = max_int -> aux t1
+ | Br(_,t0,_) -> aux t0
+
+ let max_binding t = (* increasing order *)
+ let rec aux t = match view t with
+ | Empty -> assert false (** absurd: only at top *)
+ | Lf(k,x) -> (k,x)
+ | Br(_,_,t1) -> aux t1
+ in match view t with (* in order to be sorted *)
+ | Empty -> raise Not_found
+ | Lf(k,x) -> (k,x)
+ | Br(p,t0,_) when p = max_int -> aux t0
+ | Br(_,_,t1) -> aux t1
+
+ let choose = min_binding
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Inter --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let occur i t = try Some (find i t) with Not_found -> None
+
+ let rec interi lf_phi s t =
+ match view s , view t with
+ | Empty , _ -> mk_Empty
+ | _ , Empty -> mk_Empty
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then lf_phi i x y
+ else mk_Empty
+ | Lf(i,x) , Br _ ->
+ (match occur i t with None -> mk_Empty | Some y -> lf_phi i x y)
+ | Br _ , Lf(j,y) ->
+ (match occur j s with None -> mk_Empty | Some x -> lf_phi j x y)
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ glue (interi lf_phi s0 t0) (interi lf_phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then interi lf_phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else interi lf_phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then interi lf_phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else interi lf_phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ mk_Empty
+
+ let interf phi = interi (fun i x y -> mk_Lf i (phi i x y))
+ let inter phi = interi (fun i x y -> lf i (phi i x y))
+
+ (* good sharing with s *)
+ let lfq phi i x y s t =
+ match phi i x y with
+ | None -> mk_Empty
+ | Some w -> if w == x then s else if w == y then t else mk_Lf i w
+ let occur0 phi i x s t =
+ try let (y,t) = findq i t in lfq phi i x y s t
+ with Not_found -> mk_Empty
+ let occur1 phi j y s t =
+ try let (x,s) = findq j s in lfq phi j x y s t
+ with Not_found -> mk_Empty
+
+ (* good sharing with s *)
+ let rec interq phi s t =
+ match view s , view t with
+ | Empty , _ -> s
+ | _ , Empty -> t
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then lfq phi i x y s t
+ else mk_Empty
+ | Lf(i,x) , Br _ -> occur0 phi i x s t
+ | Br _ , Lf(j,y) -> occur1 phi j y s t
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ glue2 (interq phi s0 t0) (interq phi s1 t1) s0 s1 s t0 t1 t
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then interq phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else interq phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then interq phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else interq phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ mk_Empty
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Union --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ (* good sharing with s *)
+ let br2u p s0' s1' s' t0' t1' t' t0 t1=
+ if s0'==t0 && s1'== t1 then s' else
+ if t0'==t0 && t1'== t1 then t' else
+ mk_Br p t0 t1
+
+ (* good sharing with s *)
+ let br0u p t0' t1' t' t0 = if t0'==t0 then t' else mk_Br p t0 t1'
+ let br1u p t0' t1' t' t1 = if t1'==t1 then t' else mk_Br p t0' t1
+
+ (* good sharing with s *)
+ let rec unionf phi s t =
+ match view s , view t with
+ | Empty , _ -> t
+ | _ , Empty -> s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then let w = phi i x y in
+ if w == x then s else if w == y then t else mk_Lf i w
+ else join (K.tag i) s (K.tag j) t
+ | Lf(i,x) , Br _ -> insert phi i x t
+ | Br _ , Lf(j,y) -> insert (fun j y x -> phi j x y) j y s
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ br2u p s0 s1 s t0 t1 t (unionf phi s0 t0) (unionf phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then
+ (* t has bit m = 0 => t is inside s0 *)
+ br0u p s0 s1 s (unionf phi s0 t)
+ else
+ (* t has bit m = 1 => t is inside s1 *)
+ br1u p s0 s1 s (unionf phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then
+ (* s has bit n = 0 => s is inside t0 *)
+ br0u q t0 t1 t (unionf phi s t0)
+ else
+ (* t has bit n = 1 => s is inside t1 *)
+ br1u q t0 t1 t (unionf phi s t1)
+ else
+ (* prefix disagree *)
+ join p s q t
+
+ (* good sharing with s *)
+ let rec union phi s t =
+ match view s , view t with
+ | Empty , _ -> t
+ | _ , Empty -> s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then match phi i x y with
+ | Some w when w == x -> s
+ | Some w when w == y -> t
+ | Some w -> mk_Lf i w
+ | None -> mk_Empty
+ else join (K.tag i) s (K.tag j) t
+ | Lf(i,x) , Br _ ->
+ change (fun i x -> function | None -> Some x
+ | Some old -> (phi i x old)) i x t
+ | Br _ , Lf(j,y) ->
+ change (fun j y -> function | None -> Some y
+ | Some old -> (phi j old y)) j y s
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ glue2 (union phi s0 t0) (union phi s1 t1) s0 s1 s t0 t1 t
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then
+ (* t has bit m = 0 => t is inside s0 *)
+ br0 p s0 s1 s (union phi s0 t)
+ else
+ (* t has bit m = 1 => t is inside s1 *)
+ br1 p s0 s1 s (union phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then
+ (* s has bit n = 0 => s is inside t0 *)
+ br0 q t0 t1 t (union phi s t0)
+ else
+ (* t has bit n = 1 => s is inside t1 *)
+ br1 q t0 t1 t (union phi s t1)
+ else
+ (* prefix disagree *)
+ join p s q t
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Merge --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let map1 phi s = mapf (fun i x -> phi i (Some x) None) s
+ let map2 phi t = mapf (fun j y -> phi j None (Some y)) t
+
+ let rec merge phi s t =
+ match view s , view t with
+ | Empty , _ -> map2 phi t
+ | _ , Empty -> map1 phi s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j then lf i (phi i (Some x) (Some y))
+ else
+ let a = lf i (phi i (Some x) None) in
+ let b = lf j (phi j None (Some y)) in
+ glue a b
+
+ | Lf(i,x) , Br(q,t0,t1) ->
+ if match_prefix (K.tag i) q then
+ (* leaf i is in tree t *)
+ if zero_bit (K.tag i) q
+ then glue (merge phi s t0) (map2 phi t1) (* s=i is in t0 *)
+ else glue (map2 phi t0) (merge phi s t1) (* s=i is in t1 *)
+ else
+ (* leaf i does not appear in t *)
+ glue (lf i (phi i (Some x) None)) (map2 phi t)
+
+ | Br(p,s0,s1) , Lf(j,y) ->
+ if match_prefix (K.tag j) p then
+ (* leaf j is in tree s *)
+ if zero_bit (K.tag j) p
+ then glue (merge phi s0 t) (map1 phi s1) (* t=j is in s0 *)
+ else glue (map1 phi s0) (merge phi s1 t) (* t=j is in s1 *)
+ else
+ (* leaf j does not appear in s *)
+ glue (map1 phi s) (lf j (phi j None (Some y)))
+
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ glue (merge phi s0 t0) (merge phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ glue (merge phi s0 t) (map1 phi s1)
+ else (* t has bit m = 1 => t is inside s1 *)
+ glue (map1 phi s0) (merge phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then (* s has bit n = 0 => s is inside t0 *)
+ glue (merge phi s t0) (map2 phi t1)
+ else (* s has bit n = 1 => s is inside t1 *)
+ glue (map2 phi t0) (merge phi s t1)
+ else
+ glue (map1 phi s) (map2 phi t)
+
+ let map2 phi t = mapf (fun j y -> phi j None y) t
+ let rec union_merge phi s t =
+ match view s , view t with
+ | Empty , _ -> map2 phi t
+ | _ , Empty -> s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j then lf i (phi i (Some x) y)
+ else
+ let b = lf j (phi j None y) in
+ glue s b
+
+ | Lf(i,_) , Br(q,t0,t1) ->
+ if match_prefix (K.tag i) q then
+ (* leaf i is in tree t *)
+ if zero_bit (K.tag i) q
+ then glue (union_merge phi s t0) (map2 phi t1) (* s=i is in t0 *)
+ else glue (map2 phi t0) (union_merge phi s t1) (* s=i is in t1 *)
+ else
+ (* leaf i does not appear in t *)
+ glue s (map2 phi t)
+
+ | Br(p,s0,s1) , Lf(j,y) ->
+ if match_prefix (K.tag j) p then
+ (* leaf j is in tree s *)
+ if zero_bit (K.tag j) p
+ then glue (union_merge phi s0 t) s1 (* t=j is in s0 *)
+ else glue s0 (union_merge phi s1 t) (* t=j is in s1 *)
+ else
+ (* leaf j does not appear in s *)
+ glue s (lf j (phi j None y))
+
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ glue (union_merge phi s0 t0) (union_merge phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ glue (union_merge phi s0 t) s1
+ else (* t has bit m = 1 => t is inside s1 *)
+ glue s0 (union_merge phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then (* s has bit n = 0 => s is inside t0 *)
+ glue (union_merge phi s t0) (map2 phi t1)
+ else (* s has bit n = 1 => s is inside t1 *)
+ glue (map2 phi t0) (union_merge phi s t1)
+ else
+ glue s (map2 phi t)
+
+
+
+ (* good sharing with s *)
+ let rec diffq phi s t =
+ match view s , view t with
+ | Empty , _ -> s
+ | _ , Empty -> s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then lfq phi i x y s t
+ else s
+ | Lf(i,x) , Br _ ->
+ (match occur i t with None -> s | Some y -> lfq phi i x y s t)
+ | Br _ , Lf(j,y) -> change (fun j y x -> match x with
+ | None -> None
+ | Some x -> phi j x y) j y s
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ let t0' = (diffq phi s0 t0) in
+ let t1' = (diffq phi s1 t1) in
+ glue01 t0' t1' s0 s1 s
+ else if included_prefix p q then
+ (* q contains p. *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ let s0' = (diffq phi s0 t) in
+ glue0 s0' s0 s1 s
+ else (* t has bit m = 1 => t is inside s1 *)
+ let s1' = (diffq phi s1 t) in
+ glue1 s1' s0 s1 s
+ else if included_prefix q p then
+ (* p contains q. *)
+ if zero_bit p q
+ then diffq phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else diffq phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ s
+
+ (* good sharing with s *)
+ let rec diff :
+ type a b. (key -> a data -> b data -> a data option) ->
+ a data t -> b data t -> a data t
+ = fun phi s t ->
+ match view s , view t with
+ | Empty , _ -> s
+ | _ , Empty -> s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then lf0 i x s (phi i x y)
+ else s
+ | Lf(i,x) , Br _ ->
+ (match occur i t with None -> s | Some y -> lf0 i x s (phi i x y))
+ | Br _ , Lf(j,y) -> change (fun j y x -> match x with
+ | None -> None
+ | Some x -> phi j x y) j y s
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ let t0' = (diff phi s0 t0) in
+ let t1' = (diff phi s1 t1) in
+ glue01 t0' t1' s0 s1 s
+ else if included_prefix p q then
+ (* q contains p. *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ let s0' = (diff phi s0 t) in
+ glue0 s0' s0 s1 s
+ else (* t has bit m = 1 => t is inside s1 *)
+ let s1' = (diff phi s1 t) in
+ glue1 s1' s0 s1 s
+ else if included_prefix q p then
+ (* p contains q. *)
+ if zero_bit p q
+ then diff phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else diff phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ s
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Iter Kernel --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let rec iterk phi s t =
+ match view s , view t with
+ | Empty , _ | _ , Empty -> ()
+ | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y
+ | Lf(i,x) , Br _ ->
+ (match occur i t with None -> () | Some y -> phi i x y)
+ | Br _ , Lf(j,y) ->
+ (match occur j s with None -> () | Some x -> phi j x y)
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ (iterk phi s0 t0 ; iterk phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then iterk phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else iterk phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then iterk phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else iterk phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ ()
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Iter2 --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let iter21 phi s = iteri (fun i x -> phi i (Some x) None) s
+ let iter22 phi t = iteri (fun j y -> phi j None (Some y)) t
+
+ let rec iter2 phi s t =
+ match view s , view t with
+ | Empty , _ -> iter22 phi t
+ | _ , Empty -> iter21 phi s
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j then phi i (Some x) (Some y)
+ else ( phi i (Some x) None ; phi j None (Some y) )
+
+ | Lf(i,x) , Br(q,t0,t1) ->
+ if match_prefix (K.tag i) q then
+ (* leaf i is in tree t *)
+ if zero_bit (K.tag i) q
+ then (iter2 phi s t0 ; iter22 phi t1) (* s=i is in t0 *)
+ else (iter22 phi t0 ; iter2 phi s t1) (* s=i is in t1 *)
+ else
+ (* leaf i does not appear in t *)
+ (phi i (Some x) None ; iter22 phi t)
+
+ | Br(p,s0,s1) , Lf(j,y) ->
+ if match_prefix (K.tag j) p then
+ (* leaf j is in tree s *)
+ if zero_bit (K.tag j) p
+ then (iter2 phi s0 t ; iter21 phi s1) (* t=j is in s0 *)
+ else (iter21 phi s0 ; iter2 phi s1 t) (* t=j is in s1 *)
+ else
+ (* leaf j does not appear in s *)
+ (iter21 phi s ; phi j None (Some y))
+
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ (iter2 phi s0 t0 ; iter2 phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then (* t has bit m = 0 => t is inside s0 *)
+ (iter2 phi s0 t ; iter21 phi s1)
+ else (* t has bit m = 1 => t is inside s1 *)
+ (iter21 phi s0 ; iter2 phi s1 t)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then (* s has bit n = 0 => s is inside t0 *)
+ (iter2 phi s t0 ; iter22 phi t1)
+ else (* s has bit n = 1 => s is inside t1 *)
+ (iter22 phi t0 ; iter2 phi s t1)
+ else
+ (iter21 phi s ; iter22 phi t)
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Intersects --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ (** TODO seems wrong *)
+ let rec intersectf phi s t =
+ match view s , view t with
+ | Empty , _ -> false
+ | _ , Empty -> false
+ | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y else false
+ | Lf(i,x) , Br _ -> (match occur i t with None -> false
+ | Some y -> phi i x y)
+ | Br _ , Lf(j,y) -> (match occur j s with None -> false
+ | Some x -> phi j x y)
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ (intersectf phi s0 t0) || (intersectf phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then intersectf phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else intersectf phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then intersectf phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else intersectf phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ false
+
+ let rec disjoint phi s t =
+ match view s , view t with
+ | Empty , _ -> true
+ | _ , Empty -> true
+ | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y else true
+ | Lf(i,x) , Br _ -> (match occur i t with None -> true
+ | Some y -> phi i x y)
+ | Br _ , Lf(j,y) -> (match occur j s with None -> true
+ | Some x -> phi j x y)
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ (disjoint phi s0 t0) && (disjoint phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then disjoint phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else disjoint phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then disjoint phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else disjoint phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ true
+
+ (** fold2 *)
+ let fold21 phi m acc = fold (fun i x acc -> phi i (Some x) None acc) m acc
+ let fold22 phi m acc = fold (fun j y acc -> phi j None (Some y) acc) m acc
+
+ (* good sharing with s *)
+ let rec fold2_union:
+ type a b c.
+ (key -> a data option -> b data option -> c -> c) ->
+ a data t -> b data t -> c -> c
+ = fun phi s t acc ->
+ match view s , view t with
+ | Empty , _ -> fold22 phi t acc
+ | _ , Empty -> fold21 phi s acc
+ | Lf(i,x) , Lf(j,y) ->
+ let c = Stdlib.compare (K.tag i) (K.tag j) in
+ if c = 0
+ then phi i (Some x) (Some y) acc
+ else if c < 0 then phi j None (Some y) (phi i (Some x) None acc)
+ else (* c > 0 *) phi i (Some x) None (phi j None (Some y) acc)
+ | Lf(k,x) , Br(p,t1,t2) ->
+ if match_prefix (K.tag k) p then
+ if zero_bit (K.tag k) p
+ then fold22 phi t2 (fold2_union phi s t1 acc)
+ else fold2_union phi s t2 (fold22 phi t1 acc)
+ else
+ if side (K.tag k) p
+ then (* k p *) fold22 phi t (phi k (Some x) None acc)
+ else (* p k *) phi k (Some x) None (fold22 phi t acc)
+ | Br(p,s1,s2) , Lf(k,y) ->
+ if match_prefix (K.tag k) p then
+ if zero_bit (K.tag k) p
+ then fold21 phi s2 (fold2_union phi s1 t acc)
+ else fold2_union phi s2 t (fold21 phi s1 acc)
+ else
+ if side (K.tag k) p
+ then (* k p *) fold21 phi s (phi k None (Some y) acc)
+ else (* p k *) phi k None (Some y) (fold21 phi s acc)
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ fold2_union phi s1 t1 (fold2_union phi s0 t0 acc)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then
+ (* t has bit m = 0 => t is inside s0 *)
+ fold21 phi s1 (fold2_union phi s0 t acc)
+ else
+ (* t has bit m = 1 => t is inside s1 *)
+ fold2_union phi s1 t (fold21 phi s0 acc)
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then
+ (* s has bit n = 0 => s is inside t0 *)
+ fold22 phi t1 (fold2_union phi s t0 acc)
+ else
+ (* t has bit n = 1 => s is inside t1 *)
+ fold2_union phi s t1 (fold22 phi t0 acc)
+ else
+ (* prefix disagree *)
+ if side p q
+ then (* p q *) fold22 phi t (fold21 phi s acc)
+ else (* q p *) fold21 phi s (fold22 phi t acc)
+
+ (* good sharing with s *)
+ let rec fold2_inter phi s t acc =
+ match view s , view t with
+ | Empty , _ -> acc
+ | _ , Empty -> acc
+ | Lf(i,x) , Lf(j,y) ->
+ if K.equal i j
+ then phi i x y acc
+ else acc
+ | Lf(k,x) , Br _ ->
+ begin match find_opt k t with
+ | Some y -> phi k x y acc
+ | None -> acc
+ end
+ | Br _ , Lf(k,y) ->
+ begin match find_opt k s with
+ | Some x -> phi k x y acc
+ | None -> acc
+ end
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ fold2_inter phi s1 t1 (fold2_inter phi s0 t0 acc)
+ else if included_prefix p q then
+ (* q contains p. Merge t with a subtree of s *)
+ if zero_bit q p
+ then
+ (* t has bit m = 0 => t is inside s0 *)
+ fold2_inter phi s0 t acc
+ else
+ (* t has bit m = 1 => t is inside s1 *)
+ fold2_inter phi s1 t acc
+ else if included_prefix q p then
+ (* p contains q. Merge s with a subtree of t *)
+ if zero_bit p q
+ then
+ (* s has bit n = 0 => s is inside t0 *)
+ fold2_inter phi s t0 acc
+ else
+ (* t has bit n = 1 => s is inside t1 *)
+ fold2_inter phi s t1 acc
+ else
+ (* prefix disagree *)
+ acc
+
+ (* ---------------------------------------------------------------------- *)
+ (* --- Subset --- *)
+ (* ---------------------------------------------------------------------- *)
+
+ let rec subsetf phi s t =
+ match view s , view t with
+ | Empty , _ -> true
+ | _ , Empty -> false
+ | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y else false
+ | Lf(i,x) , Br _ ->
+ (match occur i t with None -> false | Some y -> phi i x y)
+ | Br _ , Lf _ -> false
+ | Br(p,s0,s1) , Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ (subsetf phi s0 t0 && subsetf phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p: t is included in a (strict) subtree of s *)
+ false
+ else if included_prefix q p then
+ (* p contains q: s is included in a subtree of t *)
+ if zero_bit p q
+ then subsetf phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else subsetf phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ false
+
+ let subset = subsetf
+ let subsetk s t = subsetf (fun _i _x _y -> true) s t
+ let submap = subsetf
+
+ (* ---------------------------------------------------------------------- *)
+
+ let rec _pp_tree tab fmt t =
+ match view t with
+ | Empty -> ()
+ | Lf(k,_) ->
+ let k = K.tag k in
+ Format.fprintf fmt "%sL%a=%d" tab pp_bits k k
+ | Br(p,l,r) ->
+ let next = tab ^ " " in
+ _pp_tree next fmt l ;
+ Format.fprintf fmt "%s@@%a" tab (pp_mask (decode_mask p)) p ;
+ _pp_tree next fmt r
+
+
+ let is_num_elt n m =
+ try
+ fold (fun _ _ n -> if n < 0 then raise Exit else n-1) m n = 0
+ with Exit -> false
+
+ let of_list l =
+ List.fold_left (fun acc (k,d) -> add k d acc) empty l
+
+ let translate f m =
+ fold (fun k v acc -> add (f k) v acc) m empty
+
+ (** set_* *)
+
+ let set_union m1 m2 = unionf (fun _ x _ -> x) m1 m2
+ let set_inter m1 m2 = interf (fun _ x _ -> x) m1 m2
+ let set_diff m1 m2 = diff (fun _ _ _ -> None) m1 m2
+ let set_submap m1 m2 = submap (fun _ _ _ -> true) m1 m2
+ let set_disjoint m1 m2 = disjoint (fun _ _ _ -> false) m1 m2
+ let set_compare m1 m2 = compare (fun _ _ -> 0) m1 m2
+ let set_equal m1 m2 = equal (fun _ _ -> true) m1 m2
+
+ (** the goal is to choose randomly but often the same than [choose] *)
+ let choose_rnd f m =
+ let rec aux f m ret =
+ match view m with
+ | Empty -> ()
+ | Lf(k,v) -> if f () then (ret := (k,v); raise Exit)
+ | Br(_,t1,t2) ->
+ aux f t1 ret; aux f t2 ret
+ in
+ let ret = ref (Obj.magic 0) in
+ try
+ begin match view m with (* in order to be sorted *)
+ | Empty -> raise Not_found
+ | Br(p,_,t1) when p = max_int -> aux f t1 ret
+ | _ -> aux f m ret
+ end;
+ choose m
+ with Exit -> !ret
+
+ (** Enumeration *)
+ type 'a enumeration =
+ | EEmpty
+ | ELf of K.t * 'a * 'a enum2
+
+ and 'a enum2 =
+ | End
+ | EBr of 'a t * 'a enum2
+
+ let rec cons_enum m e =
+ match view m with
+ | Empty -> assert false (** absurd: Empty can appear only a toplevel *)
+ | Lf(i,x) -> ELf(i,x,e)
+ | Br(_,t1,t2) -> cons_enum t1 (EBr(t2,e))
+
+ let start_enum m = (* in order to be sorted *)
+ match view m with
+ | Empty -> EEmpty
+ | Lf(i,x) -> ELf(i,x,End)
+ | Br(p,t1,t2) when p = max_int -> cons_enum t2 (EBr(t1, End))
+ | Br(_,t1,t2) -> cons_enum t1 (EBr(t2, End))
+
+ let val_enum = function
+ | EEmpty -> None
+ | ELf(i,x,_) -> Some (i,x)
+
+ let next_enum_br = function
+ | End -> EEmpty
+ | EBr(t2,e) -> cons_enum t2 e
+
+ let next_enum = function
+ | EEmpty -> EEmpty
+ | ELf(_,_,e) -> next_enum_br e
+
+ let rec cons_ge_enum k m e =
+ match view m with
+ | Empty -> assert false (** absurd: Empty can appear only a toplevel *)
+ | Lf(i,x) ->
+ if side (K.tag i) (K.tag k)
+ then (* i k *) next_enum_br e
+ else (* k i *) ELf(i,x,e)
+ | Br(p,t1,t2) ->
+ if match_prefix (K.tag k) p then
+ if zero_bit (K.tag k) p
+ then cons_ge_enum k t1 (EBr(t2,e))
+ else cons_ge_enum k t2 e
+ else
+ if side (K.tag k) p
+ then (* k p *) cons_enum t1 (EBr(t2,e))
+ else (* p k *) next_enum_br e
+
+ let start_ge_enum k m =
+ match view m with
+ | Empty -> EEmpty
+ | Br(p,t1,t2) when p = max_int ->
+ if zero_bit (K.tag k) p
+ then cons_ge_enum k t1 End
+ else cons_ge_enum k t2 (EBr(t1,End))
+ | _ -> cons_ge_enum k m End
+
+ let rec next_ge_enum_br k = function
+ | End -> EEmpty
+ | EBr(t,e) -> match view t with
+ | Empty -> assert false (** absurd: Empty only at top *)
+ | Lf(i,d) when (K.tag k) <= (K.tag i) -> ELf(i,d,e)
+ | Lf(_,_) -> next_ge_enum_br k e
+ | Br(p,t1,t2) ->
+ if match_prefix (K.tag k) p then
+ if zero_bit (K.tag k) p
+ then cons_ge_enum k t1 (EBr(t2,e))
+ else cons_ge_enum k t2 e
+ else
+ if side (K.tag k) p
+ then (* k p *) cons_enum t1 (EBr(t2,e))
+ else (* p k *) next_ge_enum_br k e
+
+ let next_ge_enum k = function
+ | EEmpty -> EEmpty
+ | ELf(i,_,_) as e when (K.tag k) <= (K.tag i)-> e
+ | ELf(_,_,e) -> next_ge_enum_br k e
+
+ let change f k m = change (fun _ () v -> f v) k () m
+
+ let add_opt x o m =
+ match o with
+ | None -> remove x m
+ | Some y -> add x y m
+
+ (** TODO more checks? *)
+ let check_invariant m =
+ match view m with
+ | Empty -> true
+ | _ ->
+ let rec aux m =
+ match view m with
+ | Empty -> false
+ | Lf _ -> true
+ | Br (_,t1,t2) -> aux t1 && aux t2 in
+ aux m
+
+ let pp pp fmt m =
+ Pp.iter2 iter Pp.arrow Pp.colon
+ K.pp pp fmt m
+
+ end
+
+ module Def = struct
+ type 'a t =
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a t * 'a t
+ end
+
+ module NT = struct
+
+ module M : sig
+ type 'a t = 'a Def.t
+ type 'a data = 'a
+ type 'a view = private
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a t * 'a t
+ val view: 'a data t -> 'a data view
+ val ktag : 'a data t -> int
+ val mk_Empty: 'a data t
+ val mk_Lf: K.t -> 'a data -> 'a data t
+ val mk_Br: int -> 'a data t -> 'a data t -> 'a data t
+ end = struct
+ type 'a t = 'a Def.t
+ type 'a data = 'a
+
+ let ktag = function
+ | Def.Empty -> assert false (** absurd: precondition: not Empty *)
+ | Def.Lf(i,_) -> K.tag i
+ | Def.Br(i,_,_) -> i
+ let mk_Empty = Def.Empty
+ let mk_Lf k d = Def.Lf(k,d)
+ let mk_Br i t1 t2 =
+ (* assert (t1 != Def.Empty && t2 != Def.Empty); *)
+ Def.Br(i,t1,t2)
+
+ type 'a view = 'a Def.t =
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a t * 'a t
+
+ let view x = x
+
+ end
+
+ include Gen(M)
+
+ end
+
+ module Make(Data: Map_intf.HashType) :
+ Map_intf.Map_hashcons with type 'a data = Data.t
+ and type 'a poly := 'a NT.t
+ and type key = K.t = struct
+
+
+ (** Tag *)
+ module Tag: sig
+ type t
+ type gen
+ val mk_gen: unit -> gen
+ val to_int: t -> int
+ val dtag : t
+ val next_tag: gen -> t
+ val incr_tag: gen -> unit
+ (** all of them are different from dtag *)
+ end = struct
+ type t = int
+ type gen = int ref
+ let to_int x = x
+ let dtag = min_int (** tag used in the polymorphic non hashconsed case *)
+ let mk_gen () = ref (min_int + 1)
+ let next_tag gen = !gen
+ let incr_tag gen = incr gen; assert (!gen != dtag)
+
+ end
+
+ module M : sig
+ type (+'a) t
+ type 'a data = Data.t
+ val nt: 'a data t -> 'a data NT.t
+ val rebuild: 'a data NT.t -> 'a data t
+ type 'a view = private
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a t * 'a t
+ val view: 'a data t -> 'a data view
+ val tag : 'a data t -> int
+ val ktag : 'a data t -> int
+ val mk_Empty: 'a data t
+ val mk_Lf: K.t -> 'a data -> 'a data t
+ val mk_Br: int -> 'a data t -> 'a data t -> 'a data t
+ end = struct
+ module Check = struct
+ type 'a def = 'a Def.t = (** check the type of Def.t *)
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a def * 'a def
+ end
+
+ type 'a t =
+ | Empty
+ | Lf of K.t * 'a * Tag.t
+ | Br of int * 'a t * 'a t * Tag.t
+
+ type 'a data = Data.t
+
+ (** This obj.magic "just" hide the last field *)
+ let nt x = (Obj.magic (x : 'a t) : 'a Check.def)
+
+ let tag = function
+ | Empty -> Tag.to_int Tag.dtag
+ | Lf(_,_,tag) | Br(_,_,_,tag) -> Tag.to_int tag
+
+ let ktag = function
+ | Empty -> assert false (** absurd: Should'nt be used on Empty *)
+ | Lf(k,_,_) -> K.tag k
+ | Br(i,_,_,_) -> i
+
+ module WH = Weak.Make(struct
+ type 'a t' = 'a t
+ type t = Data.t t'
+
+ let equal x y =
+ match x, y with
+ | Empty, Empty -> true
+ | Lf(i1,d1,_), Lf(i2,d2,_) ->
+ K.equal i1 i2 && Data.equal d1 d2
+ | Br(_,l1,r1,_), Br(_,l2,r2,_) -> l1 == l2 && r1 == r2
+ | _ -> false
+
+ let hash = function
+ | Empty -> 0
+ | Lf(i1,d1,_) ->
+ 65599 * ((K.tag i1) + (Data.hash d1 * 65599 + 31))
+ | Br(_,l,r,_) ->
+ 65599 * ((tag l) + ((tag r) * 65599 + 17))
+ end)
+
+ let gentag = Tag.mk_gen ()
+ let htable = WH.create 5003
+
+ let hashcons d =
+ let o = WH.merge htable d in
+ if o == d then Tag.incr_tag gentag;
+ o
+
+ let mk_Empty = Empty
+ let mk_Lf k x = hashcons (Lf(k,x,Tag.next_tag gentag))
+ let mk_Br k t0 t1 =
+ (* assert (t0 != Empty && t1 != Empty); *)
+ hashcons (Br(k,t0,t1,Tag.next_tag gentag))
+
+
+ let rec rebuild t = match t with
+ | Def.Empty -> mk_Empty
+ | Def.Lf(i,d) -> mk_Lf i d
+ | Def.Br(i,l,r) -> mk_Br i (rebuild l) (rebuild r)
+
+ type 'a view =
+ | Empty
+ | Lf of K.t * 'a
+ | Br of int * 'a t * 'a t
+
+ (** implemntation without obj bust with copy of the next function *)
+ let view_ : 'a t -> 'a view = function
+ | Empty -> Empty
+ | Lf(k,v,_) -> Lf(k,v)
+ | Br(i,t1,t2,_) -> Br(i,t1,t2)
+
+ (** This obj.magic "just" hide the last field of the root node *)
+ let view x = (Obj.magic (x : 'a t): 'a view)
+
+ end
+
+ include Gen(M)
+
+ let mk_Empty = M.mk_Empty
+ let mk_Lf = M.mk_Lf
+
+ let nt = M.nt
+ let rebuild = M.rebuild
+
+ let compare_t s t = Stdlib.compare (M.tag s) (M.tag t)
+ let equal_t (s:'a data t) t = s == t
+
+ (** with Def.t *)
+ let rec interi_nt lf_phi s t =
+ match M.view s , t with
+ | M.Empty , _ -> mk_Empty
+ | _ , Def.Empty -> mk_Empty
+ | M.Lf(i,x) , Def.Lf(j,y) ->
+ if K.equal i j
+ then lf_phi i x y
+ else mk_Empty
+ | M.Lf(i,x) , Def.Br _ ->
+ (match NT.occur i t with None -> mk_Empty | Some y -> lf_phi i x y)
+ | M.Br _ , Def.Lf(j,y) ->
+ (match occur j s with None -> mk_Empty | Some x -> lf_phi j x y)
+ | M.Br(p,s0,s1) , Def.Br(q,t0,t1) ->
+ if p == q then
+ (* prefixes agree *)
+ glue (interi_nt lf_phi s0 t0) (interi_nt lf_phi s1 t1)
+ else if included_prefix p q then
+ (* q contains p. Intersect t with a subtree of s *)
+ if zero_bit q p
+ then interi_nt lf_phi s0 t (* t has bit m = 0 => t is inside s0 *)
+ else interi_nt lf_phi s1 t (* t has bit m = 1 => t is inside s1 *)
+ else if included_prefix q p then
+ (* p contains q. Intersect s with a subtree of t *)
+ if zero_bit p q
+ then interi_nt lf_phi s t0 (* s has bit n = 0 => s is inside t0 *)
+ else interi_nt lf_phi s t1 (* t has bit n = 1 => s is inside t1 *)
+ else
+ (* prefix disagree *)
+ mk_Empty
+
+ let inter_nt phi = interi_nt (fun i x y -> mk_Lf i (phi i x y))
+ let interf_nt phi = interi_nt (fun i x y -> lf i (phi i x y))
+ let set_inter_nt m1 m2 = interi_nt (fun i x _ -> mk_Lf i x) m1 m2
+
+ end
+
+end
diff --git a/src/util/intmap.mli b/src/popop_lib/intmap.mli
similarity index 76%
rename from src/util/intmap.mli
rename to src/popop_lib/intmap.mli
index a5269accb..1ab848491 100644
--- a/src/util/intmap.mli
+++ b/src/popop_lib/intmap.mli
@@ -1,24 +1,24 @@
-(**************************************************************************)
-(* *)
-(* This file is part of WP plug-in of Frama-C. *)
-(* *)
-(* Copyright (C) 2007-2013 *)
-(* CEA (Commissariat a l'energie atomique et aux energies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(*************************************************************************)
(** Maps with integers keys using Patricia Trees.
diff --git a/src/util/intmap_hetero.ml b/src/popop_lib/intmap_hetero.ml
similarity index 77%
rename from src/util/intmap_hetero.ml
rename to src/popop_lib/intmap_hetero.ml
index d7658bed2..6e27db652 100644
--- a/src/util/intmap_hetero.ml
+++ b/src/popop_lib/intmap_hetero.ml
@@ -1,26 +1,26 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Stdlib
+(*************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(*************************************************************************)
+
+open Popop_stdlib
module type S1 = sig
type 'a key
@@ -57,17 +57,24 @@ module type S1 = sig
{ union: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> ('a,'b) data option }
val union : 'b union -> 'b t -> 'b t -> 'b t
+ type ('b,'c) fold2_inter =
+ { fold2_inter: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> 'c -> 'c }
+ val fold2_inter: ('b,'c) fold2_inter -> 'b t -> 'b t -> 'c -> 'c
+
type 'b iter = { iter: 'a. 'a key -> ('a,'b) data -> unit }
val iter : 'b iter -> 'b t -> unit
type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> ('a,'b) data -> 'c }
val fold : ('b,'c) fold -> 'c -> 'b t -> 'c
- type 'b print = { print: 'a. ('a,'b) data Pp.printer }
- val print:
- (unit Pp.printer) ->
- 'b print ->
- 'b t Pp.printer
+ type 'b mapi = { mapi: 'a. 'a key -> ('a,'b) data -> ('a,'b) data }
+ val mapi : 'b mapi -> 'b t -> 'b t
+
+ type 'b pp = { pp: 'a. ('a,'b) data Pp.pp }
+ val pp:
+ (unit Pp.pp) ->
+ 'b pp ->
+ 'b t Pp.pp
end
@@ -130,6 +137,16 @@ module Make1
given *)
d1 d2) t1 t2
+ type ('b,'c) fold2_inter =
+ { fold2_inter: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> 'c -> 'c }
+ let fold2_inter f t1 t2 acc =
+ DInt.M.fold2_inter (fun i d1 d2 acc ->
+ f.fold2_inter
+ (Obj.magic (i : int) :> exi K.t) (* at some time this key have been
+ given *)
+ d1 d2 acc) t1 t2 acc
+
+
type 'b iter = { iter: 'a. 'a key -> ('a,'b) data -> unit }
let iter f t =
DInt.M.iter (fun i d ->
@@ -144,12 +161,20 @@ module Make1
let fold f acc t =
DInt.M.fold_left (fun acc i d ->
f.fold acc
- (Obj.magic (i : int) :> exi K.t) (* same thing than for iteri *)
+ (Obj.magic (i : int) :> exi K.t) (* same thing than for iter *)
d) acc t
- type 'b print = { print: 'a. ('a,'b) data Pp.printer }
- let print sep print fmt t =
- Pp.print_iter2 DInt.M.iter Pp.nothing sep Pp.nothing print.print fmt t
+
+ type 'b mapi = { mapi: 'a. 'a key -> ('a,'b) data -> ('a,'b) data }
+ let mapi f t =
+ DInt.M.mapi (fun i d ->
+ f.mapi
+ (Obj.magic (i : int) :> exi K.t) (* same thing than for iter *)
+ d) t
+
+ type 'b pp = { pp: 'a. ('a,'b) data Pp.pp }
+ let pp sep pp fmt t =
+ Pp.iter2 DInt.M.iter Pp.nothing sep Pp.nothing pp.pp fmt t
end
@@ -193,27 +218,30 @@ module type R1 = sig
type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> 'b -> 'c }
val fold : ('b,'c) fold -> 'c -> 'b t -> 'c
- type printk = { printk: 'a. 'a key Pp.printer }
- val print:
- (unit Pp.printer) ->
- (unit Pp.printer) ->
+ type 'b mapi = { mapi: 'a. 'a key -> 'b -> 'b }
+ val mapi : 'b mapi -> 'b t -> 'b t
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ val pp:
+ (unit Pp.pp) ->
+ (unit Pp.pp) ->
printk ->
- ('b Pp.printer) ->
- 'b t Pp.printer
+ ('b Pp.pp) ->
+ 'b t Pp.pp
end
module RMake1 (K:sig type 'a t = private int end) = struct
include Make1(K)(struct type ('a,'b) t = 'b end)
- type printk = { printk: 'a. 'a key Pp.printer }
+ type printk = { printk: 'a. 'a key Pp.pp }
- let print sep1 sep2 printkey print fmt (t : 'b t) =
+ let pp sep1 sep2 printkey pp fmt (t : 'b t) =
let printkey fmt i =
printkey.printk fmt
(Obj.magic (i : int) :> exi K.t) (* same thing than for iteri *)
in
- Pp.print_iter2 DInt.M.iter
- sep1 sep2 printkey print fmt t
+ Pp.iter2 DInt.M.iter
+ sep1 sep2 printkey pp fmt t
end
diff --git a/src/util/intmap_hetero.mli b/src/popop_lib/intmap_hetero.mli
similarity index 82%
rename from src/util/intmap_hetero.mli
rename to src/popop_lib/intmap_hetero.mli
index 6b2d46a74..de5f9ae76 100644
--- a/src/util/intmap_hetero.mli
+++ b/src/popop_lib/intmap_hetero.mli
@@ -1,24 +1,24 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(*************************************************************************)
module type S1 = sig
@@ -56,17 +56,24 @@ module type S1 = sig
{ union: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> ('a,'b) data option }
val union : 'b union -> 'b t -> 'b t -> 'b t
+ type ('b,'c) fold2_inter =
+ { fold2_inter: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> 'c -> 'c }
+ val fold2_inter: ('b,'c) fold2_inter -> 'b t -> 'b t -> 'c -> 'c
+
type 'b iter = { iter: 'a. 'a key -> ('a,'b) data -> unit }
val iter : 'b iter -> 'b t -> unit
type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> ('a,'b) data -> 'c }
val fold : ('b,'c) fold -> 'c -> 'b t -> 'c
- type 'b print = { print: 'a. ('a,'b) data Pp.printer }
- val print:
- (unit Pp.printer) ->
- 'b print ->
- 'b t Pp.printer
+ type 'b mapi = { mapi: 'a. 'a key -> ('a,'b) data -> ('a,'b) data }
+ val mapi : 'b mapi -> 'b t -> 'b t
+
+ type 'b pp = { pp: 'a. ('a,'b) data Pp.pp }
+ val pp:
+ (unit Pp.pp) ->
+ 'b pp ->
+ 'b t Pp.pp
end
@@ -125,13 +132,16 @@ module type R1 = sig
type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> 'b -> 'c }
val fold : ('b,'c) fold -> 'c -> 'b t -> 'c
- type printk = { printk: 'a. 'a key Pp.printer }
- val print:
- (unit Pp.printer) ->
- (unit Pp.printer) ->
+ type 'b mapi = { mapi: 'a. 'a key -> 'b -> 'b }
+ val mapi : 'b mapi -> 'b t -> 'b t
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ val pp:
+ (unit Pp.pp) ->
+ (unit Pp.pp) ->
printk ->
- ('b Pp.printer) ->
- 'b t Pp.printer
+ ('b Pp.pp) ->
+ 'b t Pp.pp
end
diff --git a/src/util/leftistheap.ml b/src/popop_lib/leftistheap.ml
similarity index 79%
rename from src/util/leftistheap.ml
rename to src/popop_lib/leftistheap.ml
index 7b494413e..fb9c5e5d7 100644
--- a/src/util/leftistheap.ml
+++ b/src/popop_lib/leftistheap.ml
@@ -1,17 +1,15 @@
-(**************************************************************************)
-(* *)
-(* Copyright (C) Jean-Christophe Filliatre *)
-(* *)
-(* This software is free software; you can redistribute it and/or *)
-(* modify it under the terms of the GNU Library General Public *)
-(* License version 2.1, with the special exception on linking *)
-(* described in file LICENSE. *)
-(* *)
-(* This software 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. *)
-(* *)
-(**************************************************************************)
+(**********************************************************************)
+(* Copyright (C) Jean-Christophe Filliatre *)
+(* *)
+(* This software is free software; you can redistribute it and/or *)
+(* modify it under the terms of the GNU Library General Public *)
+(* License version 2.1, with the special exception on linking *)
+(* described in file LICENSE. *)
+(* *)
+(* This software 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. *)
+(**********************************************************************)
(* Leftist heaps.
@@ -30,19 +28,7 @@ end
exception Empty
-module Make(X : Ordered) :
-sig
- type t
- val empty : t
- val is_empty : t -> bool
- val insert : X.db -> X.t -> t -> t
- val min : t -> X.t
- val extract_min : t -> X.t * t
- val merge : t -> t -> t
-
- val reprio : X.db -> t -> t
-end
-=
+module Make(X : Ordered) =
struct
type t = E | T of int * X.t * X.prio * t * t
@@ -66,7 +52,7 @@ struct
let insert x prio h = merge (T (1, x, prio, E, E)) h
- let min = function E -> raise Empty | T (_,x,_,_,_) -> x
+ let min = function E -> None | T (_,x,_,_,_) -> Some x
let extract_min = function
| E -> raise Empty
@@ -89,4 +75,8 @@ struct
let insert db x h = insert x (X.reprio db x) h
+ let rec fold f acc = function
+ | E -> acc
+ | T (_,x,p,t1,t2) ->
+ fold f (fold f (f acc x p) t1) t2
end
diff --git a/src/util/leftistheap.mli b/src/popop_lib/leftistheap.mli
similarity index 81%
rename from src/util/leftistheap.mli
rename to src/popop_lib/leftistheap.mli
index 673140355..870044972 100644
--- a/src/util/leftistheap.mli
+++ b/src/popop_lib/leftistheap.mli
@@ -1,17 +1,15 @@
-(**************************************************************************)
-(* *)
-(* Copyright (C) Jean-Christophe Filliatre *)
-(* *)
-(* This software is free software; you can redistribute it and/or *)
-(* modify it under the terms of the GNU Library General Public *)
-(* License version 2.1, with the special exception on linking *)
-(* described in file LICENSE. *)
-(* *)
-(* This software 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. *)
-(* *)
-(**************************************************************************)
+(**********************************************************************)
+(* Copyright (C) Jean-Christophe Filliatre *)
+(* *)
+(* This software is free software; you can redistribute it and/or *)
+(* modify it under the terms of the GNU Library General Public *)
+(* License version 2.1, with the special exception on linking *)
+(* described in file LICENSE. *)
+(* *)
+(* This software 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. *)
+(**********************************************************************)
(* Leftist heaps *)
@@ -39,7 +37,7 @@ sig
(* runs in O(log n),
the db is just used for the priority of the new element *)
- val min: t -> X.t
+ val min: t -> X.t option
(* runs in O(1) *)
val extract_min: t -> X.t * t
@@ -50,4 +48,6 @@ sig
val reprio : X.db -> t -> t
(* runs in O(n*n) said otherwise O(n*c) with c the number of change *)
+
+ val fold : ('a -> X.t -> X.prio -> 'a) -> 'a -> t -> 'a
end
diff --git a/src/util/lists.ml b/src/popop_lib/lists.ml
similarity index 98%
rename from src/util/lists.ml
rename to src/popop_lib/lists.ml
index 736e0c94c..a59b426d0 100644
--- a/src/util/lists.ml
+++ b/src/popop_lib/lists.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/lists.mli b/src/popop_lib/lists.mli
similarity index 98%
rename from src/util/lists.mli
rename to src/popop_lib/lists.mli
index 02adf093d..422744ae4 100644
--- a/src/util/lists.mli
+++ b/src/popop_lib/lists.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/loc.ml b/src/popop_lib/loc.ml
similarity index 95%
rename from src/util/loc.ml
rename to src/popop_lib/loc.ml
index dc4ac2f3f..9519c86af 100644
--- a/src/util/loc.ml
+++ b/src/popop_lib/loc.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -60,14 +60,14 @@ let extract (b,e) =
let lc = e.pos_cnum - b.pos_bol in
(f,l,fc,lc)
-let compare = Pervasives.compare
-let equal = Pervasives.(=)
+let compare = Stdlib.compare
+let equal = Stdlib.(=)
let hash = Hashtbl.hash
let gen_report_position fmt (f,l,b,e) =
fprintf fmt "File \"%s\", line %d, characters %d-%d" f l b e
-let report_position fmt = fprintf fmt "%a:@\n" gen_report_position
+let report_position fmt = fprintf fmt "%a:" gen_report_position
(* located exceptions *)
diff --git a/src/util/loc.mli b/src/popop_lib/loc.mli
similarity index 96%
rename from src/util/loc.mli
rename to src/popop_lib/loc.mli
index ab463344f..86a3c72bd 100644
--- a/src/util/loc.mli
+++ b/src/popop_lib/loc.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/map_intf.ml b/src/popop_lib/map_intf.ml
similarity index 96%
rename from src/util/map_intf.ml
rename to src/popop_lib/map_intf.ml
index d5caee6f3..10c12c710 100644
--- a/src/util/map_intf.ml
+++ b/src/popop_lib/map_intf.ml
@@ -1,14 +1,14 @@
(***********************************************************************)
-(* *)
-(* Objective Caml *)
+(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../LICENSE. *)
+(* en Automatique. *)
(* *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Lesser General Public License version 2.1, with the *)
+(* special exception on linking described in the file LICENSE. *)
(***********************************************************************)
(* This file originates from the OCaml v 3.12 Standard Library.
@@ -17,7 +17,11 @@
is provided in the file OCAML-LICENSE. *)
(** Input signature of the functor {!Extmap.Make} and {!Extset.Make}. *)
-module type OrderedType = Map.OrderedType
+module type OrderedType = sig
+ type t
+ val compare: t -> t -> int
+ val pp: t Pp.pp
+end
(** Input signature of the functor {!Intmap.Make}. *)
module type TaggedEqualType =
@@ -25,6 +29,7 @@ sig
type t
val tag : t -> int
val equal : t -> t -> bool
+ val pp: t Pp.pp
end
(** Input signature of the functor {!Intmap.Make.Make}. *)
@@ -33,6 +38,7 @@ sig
type t
val equal: t -> t -> bool
val hash: t -> int
+ val pp: t Pp.pp
end
(** Output signature of the functor {!Extmap.Make}. *)
@@ -87,6 +93,8 @@ module type Map =
equal data. [cmp] is the equality predicate used to compare
the data associated with the keys. *)
+ val pp: 'a data Pp.pp -> 'a data t Pp.pp
+
val iter: (key -> 'a data -> unit) -> 'a data t -> unit
(** [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value
@@ -302,6 +310,10 @@ module type Map =
'a data t -> 'b data t -> 'c -> 'c
(** fold the keys which appear in one of the two maps *)
+ val fold_decr:
+ ('b -> key -> 'a data -> 'b) -> 'b -> 'a data t -> 'b
+ (** same as {!fold_left} but in decreasing order *)
+
val translate :
(key -> key) -> 'a data t -> 'a data t
(** [translate f m] translates the keys in the map [m] by the
@@ -360,7 +372,8 @@ module type Map =
Only for debugging the datastructure*)
end
-module type PMap = Map with type 'a data = 'a
+type 'a pvar = 'a
+module type PMap = Map with type 'a data := 'a pvar
module type Map_hashcons = sig
include Map
@@ -402,7 +415,6 @@ end
type 'a punit = unit
module type MapUnit = sig
- type 'a data
include Map with type 'a data := 'a punit
end
@@ -418,6 +430,8 @@ module type Set =
type t = unit M.t
(** The type of sets of type [elt]. *)
+ val pp: t Pp.pp
+
val empty: t
(** The empty set. *)
diff --git a/src/util/number.ml b/src/popop_lib/number.ml
similarity index 97%
rename from src/util/number.ml
rename to src/popop_lib/number.ml
index 935156c9b..eeb02d9ee 100644
--- a/src/util/number.ml
+++ b/src/popop_lib/number.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -10,7 +10,7 @@
(********************************************************************)
open Format
-open Big_int
+open Big_int_Z
(** Construction *)
@@ -147,7 +147,7 @@ let simplify_max_int = big_int_of_string "2147483646"
let remove_minus e =
if e.[0] = '-' then
- (let e' = String.copy e in e'.[0] <- 'm'; e')
+ (let e' = Bytes.of_string e in Bytes.set e' 0 'm'; Bytes.to_string e')
else e
let print_dec_int support fmt i =
@@ -220,7 +220,7 @@ let print_hex_real support fmt =
(match e with None -> "0" | Some e -> remove_minus e)))
))
-let print support fmt = function
+let pp support fmt = function
| ConstInt (IConstDec i) -> print_dec_int support fmt i
| ConstInt (IConstHex i) -> print_hex_int support fmt i
| ConstInt (IConstOct i) -> print_oct_int support fmt i
diff --git a/src/util/number.mli b/src/popop_lib/number.mli
similarity index 95%
rename from src/util/number.mli
rename to src/popop_lib/number.mli
index b9ae76ea7..c07230f76 100644
--- a/src/util/number.mli
+++ b/src/popop_lib/number.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -78,4 +78,4 @@ type number_support = {
def_real_support : integer_support_kind;
}
-val print : number_support -> formatter -> constant -> unit
+val pp : number_support -> formatter -> constant -> unit
diff --git a/src/util/opt.ml b/src/popop_lib/opt.ml
similarity index 87%
rename from src/util/opt.ml
rename to src/popop_lib/opt.ml
index c53623480..dfd4da06d 100644
--- a/src/util/opt.ml
+++ b/src/popop_lib/opt.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -11,6 +11,10 @@
(* useful option combinators *)
+let pp pp fmt = function
+ | None -> Format.fprintf fmt "None"
+ | Some q -> Format.fprintf fmt "Some %a" pp q
+
let get = function None -> invalid_arg "Opt.get" | Some x -> x
let get_exn exn = function None -> raise exn | Some x -> x
@@ -29,12 +33,14 @@ let fold f d = function None -> d | Some x -> f d x
let fold_right f o d = match o with None -> d | Some x -> f x d
+let for_all f = function None -> true | Some x -> f x
+
let iter f = function None -> () | Some x -> f x
let map2 f x y = match x,y with
| None, None -> None
| Some x, Some y -> Some (f x y)
- | _ -> invalid_arg "Opt.map2"
+ | _ -> None
let equal eq a b = match a,b with
| None, None -> true
diff --git a/src/util/opt.mli b/src/popop_lib/opt.mli
similarity index 91%
rename from src/util/opt.mli
rename to src/popop_lib/opt.mli
index 601cf0d48..e83489d89 100644
--- a/src/util/opt.mli
+++ b/src/popop_lib/opt.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -21,6 +21,8 @@ val map : ('a -> 'b) -> 'a option -> 'b option
val iter : ('a -> unit) -> 'a option -> unit
+val for_all : ('a -> bool) -> 'a option -> bool
+
val apply : 'b -> ('a -> 'b) option -> 'a -> 'b
val apply2 : 'c -> ('a -> 'b -> 'c) option -> 'a -> 'b -> 'c
@@ -41,3 +43,5 @@ val compare : ('a -> 'b -> int) -> 'a option -> 'b option -> int
val map_fold :
('a -> 'b -> 'a * 'b) -> 'a -> 'b option -> 'a * 'b option
+
+val pp: 'a Pp.pp -> 'a option Pp.pp
diff --git a/src/util/plugin.ml b/src/popop_lib/plugin.ml
similarity index 92%
rename from src/util/plugin.ml
rename to src/popop_lib/plugin.ml
index 80ab79dda..334fac780 100644
--- a/src/util/plugin.ml
+++ b/src/popop_lib/plugin.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -17,7 +17,7 @@ let debug = Debug.register_info_flag "load_plugin"
exception Plugin_Not_Found of plugin * string list
let loadfile f =
- Debug.dprintf debug "Plugin loaded : %s@\n" f;
+ Debug.dprintf1 debug "Plugin loaded : %s" f;
Dynlink.loadfile_private f
@@ -62,7 +62,7 @@ let () =
match exn with
| Plugin_Not_Found (pl,sl) ->
Format.fprintf fmt "The plugin %s can't be found in the directories %a"
- pl (Pp.print_list Pp.space Pp.string) sl
+ pl (Pp.list Pp.space Pp.string) sl
| Dynlink.Error (error) ->
Format.fprintf fmt "Dynlink error : %s" (Dynlink.error_message error)
| _ -> raise exn)
diff --git a/src/util/plugin.mli b/src/popop_lib/plugin.mli
similarity index 95%
rename from src/util/plugin.mli
rename to src/popop_lib/plugin.mli
index bb06a012a..1cc7883ad 100644
--- a/src/util/plugin.mli
+++ b/src/popop_lib/plugin.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/stdlib.ml b/src/popop_lib/popop_stdlib.ml
similarity index 64%
rename from src/util/stdlib.ml
rename to src/popop_lib/popop_stdlib.ml
index ebb2455b0..fe7be2908 100644
--- a/src/util/stdlib.ml
+++ b/src/popop_lib/popop_stdlib.ml
@@ -1,13 +1,22 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
module Map = Extmap
module XHashtbl = Exthtbl.Hashtbl
@@ -18,7 +27,7 @@ module type TaggedType =
sig
type t
val tag : t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module type OrderedHashedType =
@@ -27,7 +36,7 @@ sig
val hash : t -> int
val equal : t -> t -> bool
val compare : t -> t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module OrderedHashed (X : TaggedType) =
@@ -35,8 +44,8 @@ struct
type t = X.t
let hash = X.tag
let equal ts1 ts2 = X.tag ts1 == X.tag ts2 (** Todo ts1 == ts2? *)
- let compare ts1 ts2 = Pervasives.compare (X.tag ts1) (X.tag ts2)
- let print = X.print
+ let compare ts1 ts2 = Stdlib.compare (X.tag ts1) (X.tag ts2)
+ let pp = X.pp
end
module OrderedHashedList (X : TaggedType) =
@@ -45,9 +54,9 @@ struct
let hash = Lists.hash X.tag 3
let equ_ts ts1 ts2 = X.tag ts1 == X.tag ts2
let equal = Lists.equal equ_ts
- let cmp_ts ts1 ts2 = Pervasives.compare (X.tag ts1) (X.tag ts2)
+ let cmp_ts ts1 ts2 = Stdlib.compare (X.tag ts1) (X.tag ts2)
let compare = Lists.compare cmp_ts
- let print = Pp.print_list Pp.comma X.print
+ let pp = Pp.list Pp.comma X.pp
end
module MakeMSH (X : TaggedType) =
@@ -67,7 +76,7 @@ module MakeTagged (X : Weakhtbl.Weakey) =
struct
type t = X.t
let tag t = Weakhtbl.tag_hash (X.tag t)
- let print = X.print
+ let pp = X.pp
end
module MakeMSHW (X : Weakhtbl.Weakey) =
@@ -84,17 +93,15 @@ module type Datatype = sig
module M : Map_intf.PMap with type key = t
module S : Map_intf.Set with type 'a M.t = 'a M.t
and type M.key = M.key
- and type 'a M.data = 'a M.data
module H : Exthtbl.Hashtbl.S with type key = t
end
module type Printable = sig
include OrderedHashedType
- val print: t Pp.printer
+ val pp: t Pp.pp
end
-module MkDatatype(T : OrderedHashedType) : Datatype with type t = T.t = struct
- include T
+module MkDatatype(T : OrderedHashedType) = struct
module M = Map.Make(T)
module S = Extset.MakeOfMap(M)
module H = XHashtbl.Make(T)
@@ -104,16 +111,17 @@ end
module Int = struct
type t = int
- let compare (x : int) (y : int) = Pervasives.compare x y
+ let compare (x : int) (y : int) = Stdlib.compare x y
let equal (x : int) y = x = y
let hash (x : int) = x
let tag x = x
+ let pp = Pp.int
end
module DInt = struct
include Int
- let print fmt x = Format.pp_print_int fmt x
+ let pp fmt x = Format.pp_print_int fmt x
module GM = Intmap.Make(Int)
module M = GM.NT
module S = Extset.MakeOfMap(M)
@@ -126,14 +134,14 @@ module DUnit = Unit
module Bool = struct
type t = bool
- let compare (x : bool) (y : bool) = Pervasives.compare x y
+ let compare (x : bool) (y : bool) = Stdlib.compare x y
let equal (x : bool) y = x = y
let hash (x : bool) = (Obj.magic x : int)
+ let pp = Format.pp_print_bool
end
module DBool = struct
include Bool
- let print fmt b = Format.pp_print_bool fmt b
module M = Map.Make(Bool)
module S = Extset.MakeOfMap(M)
module H = XHashtbl.Make(Bool)
@@ -145,7 +153,7 @@ module DStr = struct
let compare = String.compare
let hash = (Hashtbl.hash : string -> int)
let equal = ((=) : string -> string -> bool)
- let print = Format.pp_print_string
+ let pp = Format.pp_print_string
end
include Str
module M = Map.Make(Str)
@@ -157,10 +165,10 @@ end
module DFloat = struct
module Float = struct
type t = float
- let compare (x : float) y = Pervasives.compare x y
+ let compare (x : float) y = Stdlib.compare x y
let equal (x : float) y = x = y
let hash (x : float) = XHashtbl.hash x
- let print = Format.pp_print_float
+ let pp = Format.pp_print_float
end
include Float
diff --git a/src/util/stdlib.mli b/src/popop_lib/popop_stdlib.mli
similarity index 52%
rename from src/util/stdlib.mli
rename to src/popop_lib/popop_stdlib.mli
index 0c80fbbb8..5b8d425b5 100644
--- a/src/util/stdlib.mli
+++ b/src/popop_lib/popop_stdlib.mli
@@ -1,13 +1,22 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
module Map : module type of Extmap
module XHashtbl : Exthtbl.Hashtbl
@@ -18,7 +27,7 @@ module type TaggedType =
sig
type t
val tag : t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module type OrderedHashedType =
@@ -27,7 +36,7 @@ sig
val hash : t -> int
val equal : t -> t -> bool
val compare : t -> t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module type Datatype = sig
@@ -36,16 +45,20 @@ module type Datatype = sig
module M : Map_intf.PMap with type key = t
module S : Map_intf.Set with type 'a M.t = 'a M.t
and type M.key = M.key
- and type 'a M.data = 'a M.data
module H : Exthtbl.Hashtbl.S with type key = t
end
module type Printable = sig
include OrderedHashedType
- val print: t Pp.printer
+ val pp: t Pp.pp
end
-module MkDatatype(T : OrderedHashedType) : Datatype with type t = T.t
+module MkDatatype(T : OrderedHashedType) : sig
+ module M : Map_intf.PMap with type key = T.t
+ module S : Map_intf.Set with type 'a M.t = 'a M.t
+ and type M.key = M.key
+ module H : Exthtbl.Hashtbl.S with type key = T.t
+end
module OrderedHashed (X : TaggedType) :
OrderedHashedType with type t = X.t
@@ -58,7 +71,7 @@ module MakeMSH (X : TaggedType) : Datatype with type t = X.t
module MakeMSHW (X : Weakhtbl.Weakey) :
sig
module M : Map_intf.PMap with type key = X.t
- module S : module type of Extset.MakeOfMap(M)
+ module S : module type of struct include Extset.MakeOfMap(M) end
module H : Exthtbl.Hashtbl.S with type key = X.t
module W : Weakhtbl.S with type key = X.t
end
diff --git a/src/util/pp.ml b/src/popop_lib/pp.ml
similarity index 74%
rename from src/util/pp.ml
rename to src/popop_lib/pp.ml
index 86e74f5d1..9b2ba560f 100644
--- a/src/util/pp.ml
+++ b/src/popop_lib/pp.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -9,47 +9,47 @@
(* *)
(********************************************************************)
-(*s Pretty-print library *)
+(*s Pretty-pp library *)
open Format
-type 'a printer = formatter -> 'a -> unit
+type 'a pp = formatter -> 'a -> unit
type formatter = Format.formatter
-let print_option f fmt = function
+let option f fmt = function
| None -> ()
| Some x -> f fmt x
-let print_option_or_default default f fmt = function
+let option_or_default default f fmt = function
| None -> fprintf fmt "%s" default
| Some x -> f fmt x
-let rec print_list sep print fmt = function
+let rec list sep pp fmt = function
| [] -> ()
- | [x] -> print fmt x
- | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+ | [x] -> pp fmt x
+ | x :: r -> pp fmt x; sep fmt (); list sep pp fmt r
-let print_list_or_default default sep print fmt = function
+let list_or_default default sep pp fmt = function
| [] -> fprintf fmt "%s" default
- | l -> print_list sep print fmt l
+ | l -> list sep pp fmt l
-let print_list_par sep pr fmt l =
- print_list sep (fun fmt x -> fprintf fmt "(%a)" pr x) fmt l
+let list_par sep pr fmt l =
+ list sep (fun fmt x -> fprintf fmt "(%a)" pr x) fmt l
-let print_list_delim ~start ~stop ~sep pr fmt = function
+let list_delim ~start ~stop ~sep pr fmt = function
| [] -> ()
- | l -> fprintf fmt "%a%a%a" start () (print_list sep pr) l stop ()
+ | l -> fprintf fmt "%a%a%a" start () (list sep pr) l stop ()
-let print_iter1 iter sep print fmt l =
+let iter1 iter sep pp fmt l =
let first = ref true in
iter (fun x ->
if !first
then first := false
else sep fmt ();
- print fmt x ) l
+ pp fmt x ) l
-let print_iter2 iter sep1 sep2 print1 print2 fmt l =
+let iter2 iter sep1 sep2 print1 print2 fmt l =
let first = ref true in
iter (fun x y ->
if !first
@@ -58,7 +58,7 @@ let print_iter2 iter sep1 sep2 print1 print2 fmt l =
print1 fmt x;sep2 fmt (); print2 fmt y) l
-let print_iteri2 iter sep1 sep2 print1 print2 fmt l =
+let iteri2 iter sep1 sep2 print1 print2 fmt l =
let first = ref true in
iter (fun x y ->
if !first
@@ -67,16 +67,16 @@ let print_iteri2 iter sep1 sep2 print1 print2 fmt l =
print1 fmt x;sep2 fmt (); print2 x fmt y) l
-let print_iter22 iter sep print fmt l =
+let iter22 iter sep pp fmt l =
let first = ref true in
iter (fun x y ->
if !first
then first := false
else sep fmt ();
- print fmt x y) l
+ pp fmt x y) l
-let print_pair_delim start sep stop pr1 pr2 fmt (a,b) =
+let pair_delim start sep stop pr1 pr2 fmt (a,b) =
fprintf fmt "%a%a%a%a%a" start () pr1 a sep () pr2 b stop ()
@@ -109,6 +109,9 @@ let nothing _fmt _ = ()
let string = pp_print_string
let float = pp_print_float
let int = pp_print_int
+let bool = pp_print_bool
+let char = pp_print_char
+let unit fmt () = pp_print_string fmt "()"
let constant_string s fmt () = string fmt s
let formatted fmt x = Format.fprintf fmt "%( %)" x
let constant_formatted f fmt () = formatted fmt f
@@ -117,7 +120,7 @@ let add_flush sep fmt x = sep fmt x; pp_print_flush fmt ()
let asd f fmt x = fprintf fmt "\"%a\"" f x
-let print_pair pr1 = print_pair_delim lparen comma rparen pr1
+let pair pr1 = pair_delim lparen comma rparen pr1
let hov n f fmt x = pp_open_hovbox fmt n; f fmt x; pp_close_box fmt ()
let indent n f fmt x =
@@ -145,26 +148,26 @@ let close_file_and_formatter (cout,fmt) =
close_formatter fmt;
close_out cout
-let print_in_file_no_close ?(margin=78) p f =
+let in_file_no_close ?(margin=78) p f =
let cout,fmt = open_file_and_formatter ~margin f in
p fmt;
close_formatter fmt;
cout
-let print_in_file ?(margin=78) p f =
- let cout = print_in_file_no_close ~margin p f in
+let in_file ?(margin=78) p f =
+ let cout = in_file_no_close ~margin p f in
close_out cout
(* With optional separation *)
-let rec print_list_opt sep print fmt = function
+let rec list_opt sep pp fmt = function
| [] -> false
- | [x] -> print fmt x
+ | [x] -> pp fmt x
| x :: r ->
- let notempty1 = print fmt x in
+ let notempty1 = pp fmt x in
if notempty1 then sep fmt ();
- let notempty2 = print_list_opt sep print fmt r in
+ let notempty2 = list_opt sep pp fmt r in
notempty1 || notempty2
@@ -175,10 +178,10 @@ let string_of p x =
Buffer.contents b
let wnl fmt =
- let out,flush,_newline,spaces =
- pp_get_all_formatter_output_functions fmt () in
- pp_set_all_formatter_output_functions fmt
- ~out ~flush ~newline:(fun () -> spaces 1) ~spaces
+ let out =
+ Format.pp_get_formatter_out_functions fmt () in
+ pp_set_formatter_out_functions fmt
+ {out with Format.out_newline = (fun () -> out.out_spaces 1)}
let string_of_wnl p x =
diff --git a/src/popop_lib/pp.mli b/src/popop_lib/pp.mli
new file mode 100644
index 000000000..01461c275
--- /dev/null
+++ b/src/popop_lib/pp.mli
@@ -0,0 +1,161 @@
+(********************************************************************)
+(* *)
+(* The Why3 Verification Platform / The Why3 Development Team *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
+(* *)
+(* This software is distributed under the terms of the GNU Lesser *)
+(* General Public License version 2.1, with the special exception *)
+(* on linking described in file LICENSE. *)
+(* *)
+(********************************************************************)
+
+(*i $Id: pp.mli,v 1.22 2009-10-19 11:55:33 bobot Exp $ i*)
+
+type formatter = Format.formatter
+type 'a pp = formatter -> 'a -> unit
+
+val option : 'a pp -> 'a option pp
+val option_or_default :
+ string -> 'a pp -> 'a option pp
+val list :
+ unit pp ->
+ 'a pp -> 'a list pp
+val list_or_default :
+ string -> unit pp ->
+ 'a pp -> 'a list pp
+val list_par :
+ (formatter -> unit -> unit) ->
+ 'b pp -> 'b list pp
+val list_delim :
+ start:unit pp ->
+ stop:unit pp ->
+ sep:unit pp ->
+ 'b pp -> 'b list pp
+
+val pair_delim :
+ unit pp ->
+ unit pp ->
+ unit pp ->
+ 'a pp ->
+ 'b pp -> ('a * 'b) pp
+val pair :
+ 'a pp ->
+ 'b pp -> ('a * 'b) pp
+
+val iter1 :
+ (('a -> unit) -> 'b -> unit) ->
+ unit pp ->
+ 'a pp ->
+ 'b pp
+
+val iter2:
+ (('a -> 'b -> unit) -> 'c -> unit) ->
+ unit pp ->
+ unit pp ->
+ 'a pp ->
+ 'b pp ->
+ 'c pp
+(** [iter2 iter sep1 sep2 print1 print2 fmt t]
+ iter iterator on [t : 'c]
+ print1 k sep2 () print2 v sep1 () print1 sep2 () ...
+*)
+
+
+val iteri2:
+ (('a -> 'b -> unit) -> 'c -> unit) ->
+ unit pp ->
+ unit pp ->
+ 'a pp ->
+ ('a -> 'b pp) ->
+ 'c pp
+(** [iter2 iter sep1 sep2 print1 print2 fmt t]
+ iter iterator on [t : 'c]
+ print1 k sep2 () print2 v sep1 () print1 sep2 () ...
+*)
+
+val iter22:
+ (('a -> 'b -> unit) -> 'c -> unit) ->
+ unit pp ->
+ (formatter -> 'a -> 'b -> unit) ->
+ 'c pp
+(** [iter22 iter sep pp fmt t]
+ iter iterator on [t : 'c]
+ pp k v sep () pp k v sep () ...
+*)
+
+(** formatted: string which is formatted "@ " allow to cut the line if
+ too long *)
+type formatted = (unit, unit, unit, unit, unit, unit) format6
+val empty_formatted : formatted
+
+val space : unit pp
+val alt : unit pp
+val alt2 : unit pp
+val newline : unit pp
+val newline2 : unit pp
+val dot : unit pp
+val comma : unit pp
+val star : unit pp
+val simple_comma : unit pp
+val semi : unit pp
+val colon : unit pp
+val underscore : unit pp
+val equal : unit pp
+val arrow : unit pp
+val lbrace : unit pp
+val rbrace : unit pp
+val lsquare : unit pp
+val rsquare : unit pp
+val lparen : unit pp
+val rparen : unit pp
+val lchevron : unit pp
+val rchevron : unit pp
+val nothing : 'a pp
+val string : string pp
+val float : float pp
+val int : int pp
+val bool : bool pp
+val char : char pp
+val unit : unit pp
+val constant_string : string -> unit pp
+val formatted : formatted pp
+val constant_formatted : formatted -> unit pp
+val print0 : unit pp
+val hov : int -> 'a pp -> 'a pp
+val indent : int -> 'a pp -> 'a pp
+(** add the indentation at the first line *)
+val add_flush : 'a pp -> 'a pp
+
+val asd : 'a pp -> 'a pp
+(** add string delimiter " " *)
+
+val open_formatter : ?margin:int -> out_channel -> formatter
+val close_formatter : formatter -> unit
+val open_file_and_formatter : ?margin:int -> string -> out_channel * formatter
+val close_file_and_formatter : out_channel * formatter -> unit
+val in_file_no_close :
+ ?margin:int -> (formatter -> unit) -> string -> out_channel
+val in_file : ?margin:int -> (formatter -> unit) -> string -> unit
+
+
+val list_opt :
+ unit pp ->
+ (formatter -> 'a -> bool) -> formatter -> 'a list -> bool
+
+
+val string_of : 'a pp -> 'a -> string
+val string_of_wnl : 'a pp -> 'a -> string
+ (** same as {!string_of} but without newline *)
+
+val wnl : formatter -> unit
+
+val sprintf :
+ ('b, formatter, unit, string) Stdlib.format4 -> 'b
+
+val sprintf_wnl :
+ ('b, formatter, unit, string) Stdlib.format4 -> 'b
+
+module Ansi :
+sig
+ val set_column : int pp
+end
diff --git a/src/util/print_tree.ml b/src/popop_lib/print_tree.ml
similarity index 94%
rename from src/util/print_tree.ml
rename to src/popop_lib/print_tree.ml
index 84031fbbe..553655f6e 100644
--- a/src/util/print_tree.ml
+++ b/src/popop_lib/print_tree.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -16,7 +16,7 @@ module type Tree = sig
val decomp : t -> string * t list
end
-(*s Pretty-print functor. *)
+(*s Pretty-pp functor. *)
module Make(T : Tree) = struct
@@ -27,7 +27,7 @@ module Make(T : Tree) = struct
and [start] is the branching drawing (["+-"] the first time,
and then ["|-"]). *)
- let print fmt t =
+ let pp fmt t =
let rec print_node pref t =
let (s, sons) = T.decomp t in
pp_print_string fmt s;
@@ -61,7 +61,7 @@ module type PTree = sig
val decomp : 'a t -> string * 'a t list
end
-(*s Pretty-print functor. *)
+(*s Pretty-pp functor. *)
module PMake(T : PTree) = struct
@@ -72,7 +72,7 @@ module PMake(T : PTree) = struct
and [start] is the branching drawing (["+-"] the first time,
and then ["|-"]). *)
- let print fmt t =
+ let pp fmt t =
let rec print_node pref t =
let (s, sons) = T.decomp t in
pp_print_string fmt s;
diff --git a/src/util/print_tree.mli b/src/popop_lib/print_tree.mli
similarity index 85%
rename from src/util/print_tree.mli
rename to src/popop_lib/print_tree.mli
index 67ccf5177..adf34925f 100644
--- a/src/util/print_tree.mli
+++ b/src/popop_lib/print_tree.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -29,11 +29,11 @@ module type Tree = sig
end
(*s The functor [Make] takes a tree structure [T] as argument and provides a
- single function [print: formatter -> T.t -> unit] to print a tree on a
+ single function [pp: formatter -> T.t -> unit] to pp a tree on a
given formatter. *)
module Make (T : Tree) : sig
- val print : T.t Pp.printer
+ val pp : T.t Pp.pp
end
@@ -44,9 +44,9 @@ module type PTree = sig
end
(*s The functor [Make] takes a tree structure [T] as argument and provides a
- single function [print: formatter -> T.t -> unit] to print a tree on a
+ single function [pp: formatter -> T.t -> unit] to pp a tree on a
given formatter. *)
module PMake (T : PTree) : sig
- val print : 'a T.t Pp.printer
+ val pp : 'a T.t Pp.pp
end
diff --git a/src/util/refo.ml b/src/popop_lib/refo.ml
similarity index 67%
rename from src/util/refo.ml
rename to src/popop_lib/refo.ml
index d0770c3d7..7fe2a4629 100644
--- a/src/util/refo.ml
+++ b/src/popop_lib/refo.ml
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
type 'a t = 'a ref
diff --git a/src/util/refo.mli b/src/popop_lib/refo.mli
similarity index 66%
rename from src/util/refo.mli
rename to src/popop_lib/refo.mli
index 594080808..a8c8a7076 100644
--- a/src/util/refo.mli
+++ b/src/popop_lib/refo.mli
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
(** just reference not initialized at creation *)
diff --git a/src/util/simple_vector.ml b/src/popop_lib/simple_vector.ml
similarity index 78%
rename from src/util/simple_vector.ml
rename to src/popop_lib/simple_vector.ml
index c06fae3f2..eec41b667 100644
--- a/src/util/simple_vector.ml
+++ b/src/popop_lib/simple_vector.ml
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
type 'a t = {mutable data: 'a array;
mutable size: int}
@@ -42,6 +40,11 @@ let get t i =
assert (r != dumb);
r
+let get_def t i def =
+ assert (i < t.size);
+ let r = t.data.(i) in
+ if r == dumb then def else r
+
let set t i v =
assert (i < t.size);
t.data.(i) <- v
@@ -87,6 +90,19 @@ let push t v =
inc_size (i + 1) t;
set t i v
+let drop_last t =
+ assert (0 < t.size);
+ t.size <- t.size - 1;
+ uninitialize t t.size
+
+let decrease_size_to t i =
+ assert (i <= t.size);
+ assert (0 <= i);
+ t.size <- i;
+ for j=t.size downto i do
+ Array.unsafe_set t.data j dumb
+ done
+
let iter_initialized f t =
for i = 0 to t.size - 1 do
let e = t.data.(i) in
@@ -123,3 +139,6 @@ let fold_initializedi f acc t =
let copy t = { data = Array.copy t.data; size = t.size}
+let move ~from ~to_ =
+ to_.data <- from.data;
+ to_.size <- from.size
diff --git a/src/util/simple_vector.mli b/src/popop_lib/simple_vector.mli
similarity index 74%
rename from src/util/simple_vector.mli
rename to src/popop_lib/simple_vector.mli
index 0ccb0788e..bb41c8bb0 100644
--- a/src/util/simple_vector.mli
+++ b/src/popop_lib/simple_vector.mli
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
(** Plain and simple imperative and extensible Arrays *)
type 'a t
@@ -27,6 +25,7 @@ val create : int -> 'a t
val size : 'a t -> int
val get : 'a t -> int -> 'a
+val get_def : 'a t -> int -> 'a -> 'a
val set : 'a t -> int -> 'a -> unit
val is_uninitialized : 'a t -> int -> bool
@@ -52,8 +51,13 @@ val fold_initializedi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a
val copy : 'a t -> 'a t
(* shallow *)
+val move : from:'a t -> to_:'a t -> unit
+(* transfer the data *)
+
(** used as a stack, put the element at the end of the array *)
val push: 'a t -> 'a -> unit
+val drop_last: 'a t -> unit
+val decrease_size_to: 'a t -> int -> unit
(** If you know the implementation *)
val get_dumb : 'a t -> int -> 'a
diff --git a/src/util/strings.ml b/src/popop_lib/strings.ml
similarity index 87%
rename from src/util/strings.ml
rename to src/popop_lib/strings.ml
index 9be4e27f4..6adebd6b6 100644
--- a/src/util/strings.ml
+++ b/src/popop_lib/strings.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -31,16 +31,16 @@ let ends_with s suf =
let pad_right c s i =
let sl = String.length s in
if sl < i then
- let p = String.create i in
- String.blit s 0 p 0 sl;
- String.fill p sl (i-sl) c;
- p
+ let p = Bytes.create i in
+ Bytes.blit_string s 0 p 0 sl;
+ Bytes.fill p sl (i-sl) c;
+ Bytes.unsafe_to_string p
else if sl > i
then String.sub s 0 i
else s
module Make (X : sig end) = struct
- open Stdlib
+ open Popop_stdlib
include DInt
@@ -63,7 +63,7 @@ module Make (X : sig end) = struct
let view i = DInt.H.find hi i
- let print fmt i =
+ let pp fmt i =
try
Format.pp_print_string fmt (view i)
with Not_found -> Format.fprintf fmt "<unknown %i>" i
@@ -74,13 +74,14 @@ end
module Hashcons = Make (struct end)
-open Stdlib
+open Popop_stdlib
module type Fresh = sig
type t = private int
- include Stdlib.Datatype with type t := t
+ include Popop_stdlib.Datatype with type t := t
val create: string -> t
val iter: (t -> unit) -> unit
+ val fold: (t -> 'a -> 'a) -> 'a -> 'a
val hint_size: unit -> int
val rename: t -> string -> unit
end
@@ -108,7 +109,7 @@ module Fresh (X : sig end) = struct
let names = Simple_vector.create 100
let used_names : (* next id to use *) int DStr.H.t = DStr.H.create 100
- let print fmt (x:t) =
+ let pp fmt (x:t) =
Format.pp_print_char fmt '@';
Format.pp_print_string fmt (Simple_vector.get names (x:>int))
@@ -128,6 +129,13 @@ module Fresh (X : sig end) = struct
f i
done
+ let fold f acc =
+ let acc = ref acc in
+ for i = 0 to !c do
+ acc := f i !acc
+ done;
+ !acc
+
let hint_size () = !c + 1
let rename i s =
diff --git a/src/util/strings.mli b/src/popop_lib/strings.mli
similarity index 83%
rename from src/util/strings.mli
rename to src/popop_lib/strings.mli
index c111433ef..201d9d55f 100644
--- a/src/util/strings.mli
+++ b/src/popop_lib/strings.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -24,21 +24,22 @@ val pad_right : char -> string -> int -> string
module Hashcons :
sig
type t = private int
- include Stdlib.Datatype with type t := t
+ include Popop_stdlib.Datatype with type t := t
val make: string -> t (** hashcons *)
val fresh: string -> t (** always fresh *)
val view: t -> string
val tag: t -> int
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module Make (X : sig end): module type of Hashcons
module type Fresh = sig
type t = private int
- include Stdlib.Datatype with type t := t
+ include Popop_stdlib.Datatype with type t := t
val create: string -> t
val iter: (t -> unit) -> unit
+ val fold: (t -> 'a -> 'a) -> 'a -> 'a
val hint_size: unit -> int
val rename: t -> string -> unit
(** to use with care *)
@@ -46,4 +47,4 @@ end
module Fresh (X : sig end) : Fresh
-val find_new_name: int Stdlib.DStr.H.t -> string -> string
+val find_new_name: int Popop_stdlib.DStr.H.t -> string -> string
diff --git a/src/util/sysutil.ml b/src/popop_lib/sysutil.ml
similarity index 93%
rename from src/util/sysutil.ml
rename to src/popop_lib/sysutil.ml
index 894fba841..97cb1f90e 100644
--- a/src/util/sysutil.ml
+++ b/src/popop_lib/sysutil.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2013 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -17,22 +17,22 @@ let backup_file f =
end
let channel_contents_fmt cin fmt =
- let buff = String.make 1024 ' ' in
+ let buff = Bytes.make 1024 ' ' in
let n = ref 0 in
while n := input cin buff 0 1024; !n <> 0 do
Format.pp_print_string fmt
(if !n = 1024 then
- buff
+ Bytes.unsafe_to_string buff
else
- String.sub buff 0 !n)
+ Bytes.unsafe_to_string (Bytes.sub buff 0 !n))
done
let channel_contents_buf cin =
let buf = Buffer.create 1024
- and buff = String.make 1024 ' ' in
+ and buff = Bytes.make 1024 ' ' in
let n = ref 0 in
while n := input cin buff 0 1024; !n <> 0 do
- Buffer.add_substring buf buff 0 !n
+ Buffer.add_subbytes buf buff 0 !n
done;
buf
@@ -79,7 +79,7 @@ let open_temp_file ?(debug=false) filesuffix usefile =
let copy_file from to_ =
let cin = open_in from in
let cout = open_out to_ in
- let buff = String.make 1024 ' ' in
+ let buff = Bytes.make 1024 ' ' in
let n = ref 0 in
while n := input cin buff 0 1024; !n <> 0 do
output cout buff 0 !n
@@ -105,7 +105,7 @@ let rec copy_dir from to_ =
let path_of_file f =
let rec aux acc f =
(*
- Format.printf "aux %s@." f;
+ Format.printf "aux %s" f;
let _ = read_line () in
*)
let d = Filename.dirname f in
diff --git a/src/util/sysutil.mli b/src/popop_lib/sysutil.mli
similarity index 97%
rename from src/util/sysutil.mli
rename to src/popop_lib/sysutil.mli
index 3c0b9f698..bcaa9697f 100644
--- a/src/util/sysutil.mli
+++ b/src/popop_lib/sysutil.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/unit.ml b/src/popop_lib/unit.ml
similarity index 90%
rename from src/util/unit.ml
rename to src/popop_lib/unit.ml
index 84f6feeec..826c994f7 100644
--- a/src/util/unit.ml
+++ b/src/popop_lib/unit.ml
@@ -1,31 +1,29 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
type t = unit
let compare () () = 0
let equal () () = true
let hash _ = 0
-let print fmt () = Format.pp_print_string fmt "()"
+let pp fmt () = Format.pp_print_string fmt "()"
module M = struct
type key = unit
@@ -142,7 +140,6 @@ module M = struct
let keys = function | None -> [] | Some _ -> [()]
let values = function | None -> [] | Some v -> [v]
let union_merge _f = assert false
- let height = function None -> 0 | Some _ -> 1
let find_smaller_opt _ = function None -> None | Some d -> Some((),d)
type 'a enumeration
let val_enum _ = assert false
@@ -151,10 +148,14 @@ module M = struct
let start_ge_enum _ = assert false
let next_ge_enum _ = assert false
let fold_left _ = assert false
+ let fold_decr _ = assert false
let of_list = function
| [] -> None
| ((),v)::_ -> Some v
let check_invariant _ = true
+ let pp pp fmt = function
+ | None -> Format.pp_print_string fmt "{}"
+ | Some v -> Format.fprintf fmt "{%a}" pp v
end
@@ -200,7 +201,6 @@ struct
let union = union (fun _ _ _ -> Some ())
let inter = inter (fun _ _ _ -> Some ())
let diff = diff (fun _ _ _ -> None)
- let fold2 f = fold2_union (fun k _ _ acc -> f k acc)
let translate = translate
let add_new e x s = add_new e x () s
let is_num_elt n m = is_num_elt n m
@@ -209,6 +209,9 @@ struct
let fold2_union f n m acc = if is_some n || is_some m then f () acc else acc
let of_list l =
List.fold_left (fun acc a -> add a acc) empty l
+ let pp fmt = function
+ | Some () -> Format.fprintf fmt "true"
+ | None -> Format.fprintf fmt "false"
end
diff --git a/src/util/unit.mli b/src/popop_lib/unit.mli
similarity index 66%
rename from src/util/unit.mli
rename to src/popop_lib/unit.mli
index 549b5e891..233a4dadd 100644
--- a/src/util/unit.mli
+++ b/src/popop_lib/unit.mli
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
(** Map, Set, and hash for Unit type. Mainly for fun *)
@@ -26,7 +24,7 @@ type t = unit
val hash : t -> int
val equal : t -> t -> bool
val compare : t -> t -> int
-val print: t Pp.printer
+val pp: t Pp.pp
module M: Map_intf.Map with type key = unit
and type +'a t = 'a option
diff --git a/src/util/util.ml b/src/popop_lib/util.ml
similarity index 95%
rename from src/util/util.ml
rename to src/popop_lib/util.ml
index 513f3b6c5..80a6bd22d 100644
--- a/src/util/util.ml
+++ b/src/popop_lib/util.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/util.mli b/src/popop_lib/util.mli
similarity index 96%
rename from src/util/util.mli
rename to src/popop_lib/util.mli
index 141b4581c..b5caa9dc2 100644
--- a/src/util/util.mli
+++ b/src/popop_lib/util.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/vector_hetero.ml b/src/popop_lib/vector_hetero.ml
similarity index 83%
rename from src/util/vector_hetero.ml
rename to src/popop_lib/vector_hetero.ml
index a57686b26..e003f2b72 100644
--- a/src/util/vector_hetero.ml
+++ b/src/popop_lib/vector_hetero.ml
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
module type S1 = sig
type 'a key
@@ -29,6 +27,7 @@ module type S1 = sig
val size : 'b t -> int
val get : 'b t -> 'a key -> ('a,'b) data
+ val get_def : 'b t -> 'a key -> ('a,'b) data -> ('a,'b) data
val set : 'b t -> 'a key -> ('a,'b) data -> unit
val is_uninitialized : 'b t -> 'a key -> bool
@@ -57,14 +56,16 @@ module type S1 = sig
val copy : 'b t -> 'b t
(* shallow *)
- type printk = { printk: 'a. 'a key Pp.printer }
- type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Pp.printer }
- val print:
- unit Pp.printer ->
- unit Pp.printer ->
+ val move: from:'b t -> to_:'b t -> unit
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Pp.pp }
+ val pp:
+ unit Pp.pp ->
+ unit Pp.pp ->
printk ->
'b printd ->
- 'b t Pp.printer
+ 'b t Pp.pp
end
@@ -93,6 +94,10 @@ module Make1
let t = open_t t k in
Simple_vector.get t (k :> int)
+ let get_def (type a) t (k : a K.t) def =
+ let t = open_t t k in
+ Simple_vector.get_def t (k :> int) def
+
let is_uninitialized (type a) t (k : a K.t) =
let t = open_t t k in
Simple_vector.size t <= (k :> int) ||
@@ -135,9 +140,12 @@ module Make1
let copy = Simple_vector.copy
(* shallow *)
- type printk = { printk: 'a. 'a key Pp.printer }
- type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Pp.printer }
- let print sep1 sep2 printkey printdata fmt t =
+ let move = Simple_vector.move
+ (* shallow *)
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Pp.pp }
+ let pp sep1 sep2 printkey printdata fmt t =
let printkey fmt i =
printkey.printk fmt
(Obj.magic (i : int) : exi K.t) (* same thing than for iteri *)
@@ -147,7 +155,7 @@ module Make1
(Obj.magic (i : int) : exi K.t) (* same thing than for iteri *)
fmt d
in
- Pp.print_iteri2 Simple_vector.iter_initializedi
+ Pp.iteri2 Simple_vector.iter_initializedi
sep1 sep2 printkey printdata fmt t
end
@@ -162,6 +170,7 @@ module type S2 = sig
val size : 'b t -> int
val get : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data
+ val get_def : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data -> ('a1,'a2,'b) data
val set : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data -> unit
val is_uninitialized : 'b t -> ('a1,'a2) key -> bool
@@ -192,6 +201,8 @@ module type S2 = sig
val copy : 'b t -> 'b t
(* shallow *)
+
+ val move: from:'b t -> to_:'b t -> unit
end
module Make2
@@ -220,6 +231,10 @@ module Make2
let t = open_t t k in
Simple_vector.get t (k :> int)
+ let get_def (type a1) (type a2) t (k : (a1,a2) K.t) def =
+ let t = open_t t k in
+ Simple_vector.get_def t (k :> int) def
+
let is_uninitialized (type a1) (type a2) t (k : (a1,a2) K.t) =
let t = open_t t k in
Simple_vector.size t <= (k :> int) ||
@@ -262,6 +277,8 @@ module Make2
let copy = Simple_vector.copy
(* shallow *)
+ let move = Simple_vector.move
+
end
(** Same as S1 but for ('a,'b) data = 'b *)
@@ -273,6 +290,7 @@ module type R1 = sig
val size : 'b t -> int
val get : 'b t -> 'a key -> 'b
+ val get_def : 'b t -> 'a key -> 'b -> 'b
val set : 'b t -> 'a key -> 'b -> unit
val is_uninitialized : 'b t -> 'a key -> bool
@@ -298,14 +316,16 @@ module type R1 = sig
val copy : 'b t -> 'b t
(* shallow *)
+ val move : from:'b t -> to_:'b t -> unit
- type printk = { printk: 'a. 'a key Pp.printer }
- val print:
- unit Pp.printer ->
- unit Pp.printer ->
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ val pp:
+ unit Pp.pp ->
+ unit Pp.pp ->
printk ->
- 'b Pp.printer ->
- 'b t Pp.printer
+ 'b Pp.pp ->
+ 'b t Pp.pp
end
@@ -318,13 +338,13 @@ module RMake1 (K:sig type 'a t = private int end) = struct
let apply_initialized f v = Simple_vector.apply_initialized f v
- let print sep1 sep2 printkey print fmt t =
+ let pp sep1 sep2 printkey pp fmt t =
let printkey fmt i =
printkey.printk fmt
(Obj.magic (i : int) :> exi K.t) (* same thing than for iteri *)
in
- Pp.print_iter2 Simple_vector.iter_initializedi
- sep1 sep2 printkey print fmt t
+ Pp.iter2 Simple_vector.iter_initializedi
+ sep1 sep2 printkey pp fmt t
end
@@ -339,6 +359,7 @@ module type T1 = sig
val size : unit t -> int
val get : unit t -> 'a key -> 'a
+ val get_def : unit t -> 'a key -> 'a -> 'a
val set : unit t -> 'a key -> 'a -> unit
val is_uninitialized : unit t -> 'a key -> bool
@@ -358,21 +379,23 @@ module type T1 = sig
val copy : unit t -> unit t
(* shallow *)
- type printk = { printk: 'a. 'a key Pp.printer }
- type 'b printd = { printd: 'a. 'a key -> 'a Pp.printer }
- val print:
- unit Pp.printer ->
- unit Pp.printer ->
+ val move : from:unit t -> to_:unit t -> unit
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ type 'b printd = { printd: 'a. 'a key -> 'a Pp.pp }
+ val pp:
+ unit Pp.pp ->
+ unit Pp.pp ->
printk ->
unit printd ->
- unit t Pp.printer
+ unit t Pp.pp
end
module TMake1 (K:sig type 'a t = private int end) = struct
include Make1 (K) (struct type ('a,'b) t = 'a end)
- let print sep1 sep2 printkey printdata fmt t =
+ let pp sep1 sep2 printkey printdata fmt t =
let printkey fmt i =
printkey.printk fmt
(Obj.magic (i : int) : exi K.t) (* same thing than for iteri *)
@@ -382,7 +405,7 @@ module TMake1 (K:sig type 'a t = private int end) = struct
(Obj.magic (i : int) : exi K.t) (* same thing than for iteri *)
fmt d
in
- Pp.print_iteri2 Simple_vector.iter_initializedi
+ Pp.iteri2 Simple_vector.iter_initializedi
sep1 sep2 printkey printdata fmt t
diff --git a/src/util/vector_hetero.mli b/src/popop_lib/vector_hetero.mli
similarity index 80%
rename from src/util/vector_hetero.mli
rename to src/popop_lib/vector_hetero.mli
index 2dc56ebb8..b5d610f42 100644
--- a/src/util/vector_hetero.mli
+++ b/src/popop_lib/vector_hetero.mli
@@ -1,24 +1,22 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
(** imperative, extensible and heterogene Arrays *)
module type S1 = sig
@@ -30,6 +28,7 @@ module type S1 = sig
val size : 'b t -> int
val get : 'b t -> 'a key -> ('a,'b) data
+ val get_def : 'b t -> 'a key -> ('a,'b) data -> ('a,'b) data
val set : 'b t -> 'a key -> ('a,'b) data -> unit
val is_uninitialized : 'b t -> 'a key -> bool
@@ -59,14 +58,16 @@ module type S1 = sig
val copy : 'b t -> 'b t
(* shallow *)
- type printk = { printk: 'a. 'a key Pp.printer }
- type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Pp.printer }
- val print:
- unit Pp.printer ->
- unit Pp.printer ->
+ val move: from:'b t -> to_:'b t -> unit
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Pp.pp }
+ val pp:
+ unit Pp.pp ->
+ unit Pp.pp ->
printk ->
'b printd ->
- 'b t Pp.printer
+ 'b t Pp.pp
end
@@ -84,6 +85,7 @@ module type S2 = sig
val size : 'b t -> int
val get : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data
+ val get_def : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data -> ('a1,'a2,'b) data
val set : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data -> unit
val is_uninitialized : 'b t -> ('a1,'a2) key -> bool
@@ -114,6 +116,9 @@ module type S2 = sig
val copy : 'b t -> 'b t
(* shallow *)
+
+ val move: from:'b t -> to_:'b t -> unit
+
end
module Make2
@@ -139,6 +144,7 @@ module type R1 = sig
val size : 'b t -> int
val get : 'b t -> 'a key -> 'b
+ val get_def : 'b t -> 'a key -> 'b -> 'b
val set : 'b t -> 'a key -> 'b -> unit
val is_uninitialized : 'b t -> 'a key -> bool
@@ -164,13 +170,15 @@ module type R1 = sig
val copy : 'b t -> 'b t
(* shallow *)
- type printk = { printk: 'a. 'a key Pp.printer }
- val print:
- unit Pp.printer ->
- unit Pp.printer ->
+ val move: from:'b t -> to_:'b t -> unit
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ val pp:
+ unit Pp.pp ->
+ unit Pp.pp ->
printk ->
- 'b Pp.printer ->
- 'b t Pp.printer
+ 'b Pp.pp ->
+ 'b t Pp.pp
end
@@ -178,7 +186,7 @@ module RMake1
(K:sig type 'a t = private int end)
: R1 with type 'a key = 'a K.t
-(** Same as S1 but for ('a,'b) data = 'b *)
+(** Same as S1 but for ('a,'b) data = 'a *)
module type T1 = sig
type 'a key
type 'b t (* used only with 'b = unit *)
@@ -187,6 +195,7 @@ module type T1 = sig
val size : unit t -> int
val get : unit t -> 'a key -> 'a
+ val get_def : unit t -> 'a key -> 'a -> 'a
val set : unit t -> 'a key -> 'a -> unit
val is_uninitialized : unit t -> 'a key -> bool
@@ -206,14 +215,16 @@ module type T1 = sig
val copy : unit t -> unit t
(* shallow *)
- type printk = { printk: 'a. 'a key Pp.printer }
- type 'b printd = { printd: 'a. 'a key -> 'a Pp.printer }
- val print:
- unit Pp.printer ->
- unit Pp.printer ->
+ val move: from:unit t -> to_:unit t -> unit
+
+ type printk = { printk: 'a. 'a key Pp.pp }
+ type 'b printd = { printd: 'a. 'a key -> 'a Pp.pp }
+ val pp:
+ unit Pp.pp ->
+ unit Pp.pp ->
printk ->
unit printd ->
- unit t Pp.printer
+ unit t Pp.pp
end
diff --git a/src/util/warning.ml b/src/popop_lib/warning.ml
similarity index 91%
rename from src/util/warning.ml
rename to src/popop_lib/warning.ml
index 6f370f759..712109521 100644
--- a/src/util/warning.ml
+++ b/src/popop_lib/warning.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -13,7 +13,7 @@ open Format
let default_hook ?loc s =
Opt.iter (Loc.report_position err_formatter) loc;
- eprintf "warning: %s@." s
+ eprintf "warning: %s" s
let hook = ref default_hook
let set_hook = (:=) hook
diff --git a/src/util/warning.mli b/src/popop_lib/warning.mli
similarity index 93%
rename from src/util/warning.mli
rename to src/popop_lib/warning.mli
index f10660276..96e9129f9 100644
--- a/src/util/warning.mli
+++ b/src/popop_lib/warning.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
diff --git a/src/util/weakhtbl.ml b/src/popop_lib/weakhtbl.ml
similarity index 98%
rename from src/util/weakhtbl.ml
rename to src/popop_lib/weakhtbl.ml
index 447dc52c8..691864b56 100644
--- a/src/util/weakhtbl.ml
+++ b/src/popop_lib/weakhtbl.ml
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -115,7 +115,7 @@ module type Weakey =
sig
type t
val tag : t -> tag
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module Make (S : Weakey) = struct
diff --git a/src/util/weakhtbl.mli b/src/popop_lib/weakhtbl.mli
similarity index 95%
rename from src/util/weakhtbl.mli
rename to src/popop_lib/weakhtbl.mli
index 01dd6abb9..6101f49a1 100644
--- a/src/util/weakhtbl.mli
+++ b/src/popop_lib/weakhtbl.mli
@@ -1,7 +1,7 @@
(********************************************************************)
(* *)
(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
+(* Copyright 2010-2017 -- INRIA - CNRS - Paris-Sud University *)
(* *)
(* This software is distributed under the terms of the GNU Lesser *)
(* General Public License version 2.1, with the special exception *)
@@ -72,7 +72,7 @@ module type Weakey =
sig
type t
val tag : t -> tag
- val print: t Pp.printer
+ val pp: t Pp.pp
end
module Make (S : Weakey) : S with type key = S.t
diff --git a/src/popop_types.ml b/src/popop_types.ml
deleted file mode 100644
index eec76f6be..000000000
--- a/src/popop_types.ml
+++ /dev/null
@@ -1,515 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Stdlib
-
-exception BrokenInvariant of string
-exception Impossible (* Absurd *)
-exception SolveSameRepr
-exception UnregisteredKey
-exception AlreadyRegisteredKey
-exception UnwaitedEvent
-exception AlreadyDead
-exception AlreadyRedirected
-exception TODO
-
-
-let debug_create = Debug.register_info_flag
- ~desc:"for the core solver class creation information"
- "index"
-
-module Ty = struct
- module Constr= Strings.Fresh(struct end)
-
- type ty = { ctr: Constr.t; args: ty IArray.t; tag: int}
-
- module Ty = Hashcons.Make(struct
- type t = ty
-
- let equal ty1 ty2 =
- Constr.equal ty1.ctr ty2.ctr &&
- IArray.equal (fun x1 x2 -> DInt.equal x1.tag x2.tag) ty1.args ty2.args
-
- let hash {ctr;args} =
- Hashcons.combine (Constr.hash ctr)
- (IArray.hash (fun x1 -> x1.tag) args)
-
- let set_tag i t = {t with tag = i}
- let tag t = t.tag
-
- let rec print fmt = function
- | {ctr;args} when IArray.length args = 0 -> Constr.print fmt ctr
- | {ctr;args} -> Format.fprintf fmt "%a(%a)"
- Constr.print ctr (IArray.print Pp.comma print) args
- end)
-
- let app ctr args = Ty.hashcons {ctr;args; tag = -1}
- let args0 = IArray.of_array [||]
- let ctr ctr = app ctr args0
-
- include Ty
-
-end
-
-exception BadCoercion
-
-type (_,_) eq = Eq : ('a,'a) eq
-
-module type Key = sig
-
- module K: Datatype
- type 'a k = private K.t
- val print: 'a k Pp.printer
- val compare: 'a k -> 'b k -> int
- val equal: 'a k -> 'b k -> bool
- val hash : 'a k -> int
- val tag: 'a k -> int
-
- type iter = {iter : 'a. 'a k -> unit}
- val iter : iter -> unit
- val hint_size : unit -> int
-
- module Eq: sig
- val eq_type : 'a k -> 'b k -> ('a,'b) eq option
- (** If the two arguments are physically identical then an equality witness
- between the types is returned *)
-
- val coerce_type : 'a k -> 'b k -> ('a,'b) eq
- (** If the two arguments are physically identical then an equality witness
- between the types is returned otherwise
- the exception BadCoercion is raised *)
- end
- val create_key: string -> 'a k
-
- module MkVector(D:sig type ('a,'b) t end)
- : Vector_hetero.S1 with
- type 'a key = 'a k and type ('a,'b) data = ('a,'b) D.t
-
- module MkMap(D:sig type ('a,'b) t end)
- : Intmap_hetero.S1 with
- type 'a key = 'a k and type ('a,'b) data = ('a,'b) D.t
-
- module Vector : Vector_hetero.R1 with type 'a key = 'a k
- module VectorH : Vector_hetero.T1 with type 'a key = 'a k
- module M : Intmap_hetero.R1 with type 'a key = 'a k
-end
-
-module Make_key(X:sig end): Key = struct
- module K = Strings.Fresh(struct end)
-
- type 'a k = K.t (* >= 0 *)
- let print fmt x = K.print fmt x
- let compare x y = K.compare x y
- let equal x y = K.equal x y
- let hash x = K.hash x
- let tag (x:K.t) = (x:>int)
-
- type iter = {iter : 'a. 'a k -> unit}
- let iter f = K.iter f.iter
- let hint_size = K.hint_size
-
- let create_key s = K.create s
-
- (** the 'a k can be used as equality witness because K gives fresh values *)
- module Eq = struct
- let eq_type :
- type a b. a k -> b k -> (a,b) eq option =
- fun a b ->
- if equal a b
- then Some ((Obj.magic (Eq : (a,a) eq)) : (a,b) eq)
- else None
-
- let coerce_type :
- type a b. a k -> b k -> (a,b) eq =
- fun a b ->
- if equal a b
- then ((Obj.magic (Eq : (a,a) eq)) : (a,b) eq)
- else raise BadCoercion
- end
- module MkVector(D:sig type ('a,'b) t end) =
- Vector_hetero.Make1(struct type 'a t = 'a k end)(D)
- module MkMap(D:sig type ('a,'b) t end) =
- Intmap_hetero.Make1(struct type 'a t = 'a k end)(D)
- module Vector =
- Vector_hetero.RMake1(struct type 'a t = 'a k end)
- module VectorH =
- Vector_hetero.TMake1(struct type 'a t = 'a k end)
- module M =
- Intmap_hetero.RMake1(struct type 'a t = 'a k end)
-
-end
-
-module Make_key2(X:sig end) = struct
- module K = Strings.Fresh(struct end)
-
- type ('k,'d) k = K.t (* >= 0 *)
- let print fmt x = K.print fmt x
- let equal = K.equal
- let hash x = K.hash x
-
- type iter = {iter : 'k 'd. ('k,'d) k -> unit}
- let iter f = K.iter f.iter
-
- let create_key s = K.create s
-
- (** the ('k,'d) k can be used as equality witness because K gives
- fresh values *)
- module Eq = struct
-
- let eq_type :
- type a1 b1 a2 b2. (a1,b1) k -> (a2,b2) k
- -> ((a1,a2) eq * (b1,b2) eq) option =
- fun a b ->
- if equal a b
- then let eq1 = (Obj.magic (Eq : (a1,a1) eq) : (a1,a2) eq) in
- let eq2 = (Obj.magic (Eq : (b1,b1) eq) : (b1,b2) eq) in
- Some (eq1,eq2)
- else None
-
- let coerce_type :
- type a1 b1 a2 b2. (a1,b1) k -> (a2,b2) k
- -> ((a1,a2) eq * (b1,b2) eq) =
- fun a b ->
- if equal a b
- then let eq1 = (Obj.magic (Eq : (a1,a1) eq) : (a1,a2) eq) in
- let eq2 = (Obj.magic (Eq : (b1,b1) eq) : (b1,b2) eq) in
- (eq1,eq2)
- else raise BadCoercion
-
- end
- module MkVector(D:sig type ('k,'d,'b) t end) =
- Vector_hetero.Make2(struct type ('k,'d) t = ('k,'d) k end)(D)
-end
-
-module Dom = Make_key(struct end)
-module Sem = Make_key(struct end)
-
-type 'a dom = 'a Dom.k
-type 'a sem = 'a Sem.k
-
-module type Sem = sig
- include Stdlib.Datatype
- val key: t sem
-end
-
-
-module VSem = Sem.MkVector
- (struct type ('a,'unedeed) t =
- (module Sem with type t = 'a)
- end)
-
-let defined_sem : unit VSem.t = VSem.create 8
-let sem_uninitialized sem = VSem.is_uninitialized defined_sem sem
-let get_sem k =
- assert (if sem_uninitialized k then raise UnregisteredKey else true);
- VSem.get defined_sem k
-
-let print_sem (type a) (k : a sem) fmt s =
- let sem = get_sem k in
- let module S = (val sem : Sem with type t = a) in
- S.print fmt s
-
-module Dem = Make_key2(struct end)
-
-type ('k,'d) dem = ('k,'d) Dem.k
-
-
-module Cl = struct
- type 'a r =
- | Fresh: int * Ty.t -> [>`Fresh] r
- | Fresh_to_reg: int * Ty.t * ('event,'r) dem * 'event -> [>`Fresh] r
- | Sem : int * Ty.t * 'a sem * 'a -> [>`Sem] r
-
- type t' = [ `Fresh | `Sem] r
- type clsem = [`Sem] r
-
- let tag: t' -> int = function
- | Fresh(tag,_) -> tag
- | Fresh_to_reg(tag,_,_,_) -> tag
- | Sem(tag,_,_,_) -> tag
-
- let names = Simple_vector.create 100
- let used_names : (* next id to use *) int DStr.H.t = DStr.H.create 100
-
- (** remove the empty string *)
- let () = DStr.H.add used_names "" 0
-
- let print fmt x =
- Format.pp_print_char fmt '@';
- Format.pp_print_string fmt (Simple_vector.get names (tag x))
-
- module T = Stdlib.MakeMSH(struct
- type t = t' let tag = tag
- let print = print
- end)
-
- include T
-
- let next_tag, incr_tag = Util.get_counter ()
-
- let fresh ?to_reg s ty : t =
- let i = next_tag () in
- incr_tag ();
- let s = Strings.find_new_name used_names s in
- Debug.dprintf1 debug_create "[Solver] @[fresh @@%s@]@\n" s;
- Simple_vector.inc_size (i+1) names;
- Simple_vector.set names i s;
- match to_reg with
- | None -> Fresh(i,ty)
- | Some (dem,event) -> Fresh_to_reg(i,ty,dem,event)
-
- let rename cl s =
- let s = Strings.find_new_name used_names s in
- Simple_vector.set names (tag cl) s
-
- let ty = function | Fresh (_,ty)
- | Fresh_to_reg (_,ty,_,_)
- | Sem(_,ty,_,_) -> ty
-
- module SemIndex = Sem.MkVector
- (struct type ('a,'unedeed) t = 'a -> Ty.t -> clsem end)
-
- let semindex : unit SemIndex.t = SemIndex.create 8
-
- let clsem sem v ty : clsem =
- assert (if sem_uninitialized sem then raise UnregisteredKey else true);
- (SemIndex.get semindex sem) v ty
-
- (** Just used for checking the typability *)
- let _cl : clsem -> t = function
- | Sem(tag,ty,sem,v) -> Sem(tag,ty,sem,v)
-
- (** IF the previous function is typable this one is correct:
- I'm not able to defined is without obj.magic
- *)
- let of_clsem : clsem -> t = Obj.magic
-
- let index sem v ty = of_clsem (clsem sem v ty)
-
-end
-
-module ClSem = struct
- include Stdlib.MakeMSH(struct
- type t = Cl.clsem
- let tag: t -> int = function
- | Cl.Sem(tag,_,_,_) -> tag
- let print fmt : t -> unit = function
- | Cl.Sem(_,_,sem,v) -> print_sem sem fmt v
- end)
-
- let index = Cl.clsem
- let cl = Cl.of_clsem
- let ty : t -> Ty.t = function
- | Cl.Sem(_,ty,_,_) -> ty
-
-
-end
-
-
-module RegisterSem (D:Sem) = struct
-
- module HC = Hashcons.MakeTag(struct
- open Cl
- type t = clsem
-
- let next_tag = Cl.next_tag
- let incr_tag = Cl.incr_tag
-
- let equal: t -> t -> bool = fun a b ->
- match a, b with
- | Sem(_,tya,sema,va), Sem(_,tyb,semb,vb) ->
- match Sem.Eq.coerce_type sema D.key,
- Sem.Eq.coerce_type semb D.key with
- | Eq, Eq ->
- Ty.equal tya tyb && D.equal va vb
-
- let hash: t -> int = fun a ->
- match a with
- | Sem(_,tya,sema,va) ->
- match Sem.Eq.coerce_type sema D.key with
- | Eq ->
- Hashcons.combine (Ty.hash tya) (D.hash va)
-
- let set_tag: int -> t -> t = fun tag x ->
- match x with
- | Sem(_,ty,sem,v) -> Sem(tag,ty,sem,v)
-
- let tag: t -> int = function
- | Sem(tag,_,_,_) -> tag
-
- let print fmt x =
- Format.pp_print_char fmt '@';
- Format.pp_print_string fmt (Simple_vector.get names (tag x))
- end)
-
- include HC
-
- let tag: t -> int = function
- | Cl.Sem(tag,_,_,_) -> tag
-
- let index v ty =
- let cl =
- HC.hashcons3
- (fun tag sem v ty -> Cl.Sem(tag,ty,sem,v))
- D.key v ty in
- let i = tag cl in
- Simple_vector.inc_size (i+1) Cl.names;
- begin
- if Simple_vector.is_uninitialized Cl.names i then
- let s = Strings.find_new_name Cl.used_names ""
- (** TODO use Sem.print or Sem.print_debug *) in
- Debug.dprintf3 debug_create "[Solver] @[index %a into @@%s@]@\n"
- D.print v s;
- Simple_vector.set Cl.names i s
- end;
- cl
-
- let cl = Cl.of_clsem
-
- let sem : t -> D.t = function
- | Cl.Sem(_,_,sem,v) ->
- match Sem.Eq.coerce_type sem D.key with
- | Eq -> v
-
- let ty = ClSem.ty
-
- let clsem: t -> ClSem.t = fun x -> x
-
- let of_clsem: ClSem.t -> t option = function
- | Cl.Sem(_,_,sem',_) as v when Sem.equal sem' D.key -> Some v
- | _ -> None
-
- let coerce_clsem: ClSem.t -> t = function
- | Cl.Sem(_,_,sem',_) as v -> assert (Sem.equal sem' D.key); v
-
- let () =
- VSem.inc_size D.key defined_sem;
- assert (if not (VSem.is_uninitialized defined_sem D.key)
- then raise AlreadyRegisteredKey else true);
- let sem = (module D: Sem with type t = D.t) in
- VSem.set defined_sem D.key sem;
- Cl.SemIndex.set Cl.semindex D.key (fun v ty -> index v ty)
-
-end
-
-module Env = Make_key(struct end)
-type 'a env = 'a Env.k
-
-module type Key2 = sig
- module K: Datatype
- type ('k,'d) k = private K.t
- (** kind of daemon for semantic value of type 'a *)
- val print: ('k,'d) k Pp.printer
- val equal: ('k1,'d1) k -> ('k2,'d2) k -> bool
- val hash : ('k,'d) k -> int
-
- type iter = {iter : 'k 'd. ('k,'d) k -> unit}
- val iter : iter -> unit
-
- val create_key: string -> ('k,'d) k
-
- module Eq: sig
- val eq_type : ('a1,'b1) k -> ('a2,'b2) k
- -> (('a1,'a2) eq * ('b1,'b2) eq) option
- (** If the two arguments are physically identical then an equality witness
- between the types is returned *)
-
- val coerce_type : ('a1,'b1) k -> ('a2,'b2) k
- -> ('a1,'a2) eq * ('b1,'b2) eq
- (** If the two arguments are physically identical then an equality witness
- between the types is returned otherwise
- the exception BadCoercion is raised *)
- end
- module MkVector(D:sig type ('k,'d,'b) t end)
- : Vector_hetero.S2 with type ('k,'d) key = ('k,'d) k
- and type ('k,'d,'b) data = ('k,'d,'b) D.t
-end
-
-
-module Print = struct (** Cutting the knot for printer *)
- (* type psem = { mutable psem : 'a. ('a sem -> 'a Pp.printer)} *)
-
- (* let psem : psem = *)
- (* {psem = fun _ _ _ -> assert false} (\** called too early *\) *)
- (* let sem sem fmt s = psem.psem sem fmt s *)
-
- type pdem_event = { mutable
- pdem_event : 'k 'd. ('k,'d) dem -> 'k Pp.printer}
-
- let pdem_event : pdem_event =
- {pdem_event = fun _ _ _ -> assert false} (** called too early *)
- let dem_event dem fmt s = pdem_event.pdem_event dem fmt s
-
- type pdem_runable = { mutable
- pdem_runable : 'k 'd. ('k,'d) dem -> 'd Pp.printer}
-
- let pdem_runable : pdem_runable =
- {pdem_runable = fun _ _ _ -> assert false} (** called too early *)
- let dem_runable dem fmt s = pdem_runable.pdem_runable dem fmt s
-
-
-end
-
-module Only_for_solver = struct
- type sem_of_cl =
- | Sem: 'a sem * 'a -> sem_of_cl
-
- let clsem: Cl.t -> ClSem.t option = function
- | Cl.Fresh _ | Cl.Fresh_to_reg _ -> None
- | Cl.Sem _ as x -> Some (Obj.magic x: ClSem.t)
-
- let sem_of_cl: ClSem.t -> sem_of_cl = function
- | Cl.Sem (_,_,sem,v) -> Sem(sem,v)
-
- (** Just used for checking the typability *)
- let _cl_of_clsem : ClSem.t -> Cl.t = function
- | Cl.Sem(tag,ty,sem,v) -> Cl.Sem(tag,ty,sem,v)
-
- (** IF the previous function is typable this one is correct:
- I'm not able to defined is without obj.magic
- *)
- let cl_of_clsem : ClSem.t -> Cl.t = Obj.magic
-
- type opened_cl =
- | Fresh: opened_cl
- | Fresh_to_reg: ('event,'r) dem * 'event -> opened_cl
- | Sem : ClSem.t -> opened_cl
-
- let open_cl = function
- | Cl.Fresh _ -> Fresh
- | Cl.Fresh_to_reg(_,_,dem,event) -> Fresh_to_reg(dem,event)
- | Cl.Sem _ as x -> Sem (Obj.magic x: ClSem.t)
-end
-
-
-let check_initialization () =
- let well_initialized = ref true in
-
- Sem.iter {Sem.iter = fun sem ->
- if VSem.is_uninitialized defined_sem sem then begin
- Format.eprintf
- "[Warning] The set of values %a is not registered@." Sem.print sem;
- well_initialized := false;
- end};
-
- !well_initialized
-
diff --git a/src/popop_types.mli b/src/popop_types.mli
deleted file mode 100644
index ba57df4e4..000000000
--- a/src/popop_types.mli
+++ /dev/null
@@ -1,256 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Stdlib
-
-(** {2 General caml types } *)
-
-exception BrokenInvariant of string
-exception SolveSameRepr
-exception UnwaitedEvent
-exception Impossible (* Absurd *)
-exception AlreadyDead
-exception AlreadyRedirected
-exception TODO
-
-(** {2 Types} *)
-
-module Ty : sig
- module Constr: Strings.Fresh
- (** type constructors *)
-
- type ty = private { ctr: Constr.t; args: ty IArray.t; tag: int}
-
- include Datatype with type t = ty
- (** types *)
-
- val app: Constr.t -> ty IArray.t -> ty
- val ctr: Constr.t -> ty
-
-end
-
-
-(** the key shouldn't be used before its registration and shouldn't be
- registered again *)
-exception UnregisteredKey
-exception AlreadyRegisteredKey
-
-
-exception BadCoercion
-type (_,_) eq = Eq : ('a,'a) eq
-
-module type Key = sig
-
- module K: Datatype
- type 'a k = private K.t
-
- val print: 'a k Pp.printer
- val compare: 'a k -> 'b k -> int
- val equal: 'a k -> 'b k -> bool
- val hash : 'a k -> int
- val tag: 'a k -> int
-
- type iter = {iter : 'a. 'a k -> unit}
- val iter : iter -> unit
- val hint_size : unit -> int
-
- module Eq: sig
- val eq_type : 'a k -> 'b k -> ('a,'b) eq option
- (** If the two arguments are physically identical then an equality witness
- between the types is returned *)
-
- val coerce_type : 'a k -> 'b k -> ('a,'b) eq
- (** If the two arguments are physically identical then an equality witness
- between the types is returned otherwise
- the exception BadCoercion is raised *)
- end
- val create_key: string -> 'a k
-
- module MkVector(D:sig type ('a,'b) t end)
- : Vector_hetero.S1 with
- type 'a key = 'a k and type ('a,'b) data = ('a,'b) D.t
-
- module MkMap(D:sig type ('a,'b) t end)
- : Intmap_hetero.S1 with
- type 'a key = 'a k and type ('a,'b) data = ('a,'b) D.t
-
- module Vector : Vector_hetero.R1 with type 'a key = 'a k
- module VectorH : Vector_hetero.T1 with type 'a key = 'a k
- module M : Intmap_hetero.R1 with type 'a key = 'a k
-
-end
-
-module Make_key(X:sig end) : Key
-
-
-module type Key2 = sig
- module K: Datatype
- type ('k,'d) k = private K.t
- (** kind of daemon for semantic value of type 'a *)
- val print: ('k,'d) k Pp.printer
- val equal: ('k1,'d1) k -> ('k2,'d2) k -> bool
- val hash : ('k,'d) k -> int
-
- type iter = {iter : 'k 'd. ('k,'d) k -> unit}
- val iter : iter -> unit
-
- val create_key: string -> ('k,'d) k
-
- module Eq: sig
- val eq_type : ('a1,'b1) k -> ('a2,'b2) k
- -> (('a1,'a2) eq * ('b1,'b2) eq) option
- (** If the two arguments are physically identical then an equality witness
- between the types is returned *)
-
- val coerce_type : ('a1,'b1) k -> ('a2,'b2) k
- -> ('a1,'a2) eq * ('b1,'b2) eq
- (** If the two arguments are physically identical then an equality witness
- between the types is returned otherwise
- the exception BadCoercion is raised *)
- end
- module MkVector(D:sig type ('k,'d,'b) t end)
- : Vector_hetero.S2 with type ('k,'d) key = ('k,'d) k
- and type ('k,'d,'b) data = ('k,'d,'b) D.t
-end
-
-module Make_key2(X:sig end): Key2
-
-
-module Sem: Key
-module Dom: Key
-
-type 'a dom = 'a Dom.k
-type 'a sem = 'a Sem.k
-
-module type Sem = sig
- include Datatype
-
- val key: t sem
-end
-
-val get_sem: 'a sem -> (module Sem with type t = 'a)
-val sem_uninitialized: 'a sem -> bool
-val print_sem : 'a sem -> 'a Pp.printer
-
-module Env: Key
-type 'a env = 'a Env.k
-
-module Dem: Key2
-type ('k,'d) dem = ('k,'d) Dem.k
-
-(** Classes *)
-module Cl : sig
- include Datatype
-
- val fresh: ?to_reg:(('event,'r) dem * 'event) -> string -> Ty.t -> t
- (** the string is used as the prefix for the debug output *)
-
- val rename: t -> string -> unit
- (** to use with care *)
-
- val ty: t -> Ty.t
-
- val index: 'a sem -> 'a -> Ty.t -> t
- (** Return the corresponding cl from a semantical value *)
-end
-
-module ClSem: sig
- include Datatype
-
-
- val index: 'a sem -> 'a -> Ty.t -> t
- (** Return the corresponding cl from a semantical value *)
-
- val cl: t -> Cl.t
-
- val ty: t -> Ty.t
-
-end
-
-module RegisterSem (D:Sem) : sig
- (** clsem *)
- include Datatype
-
- val index: D.t -> Ty.t -> t
- (** Return a clsem from a semantical value *)
-
- val cl: t -> Cl.t
- (** Return a class from a clsem *)
-
- val ty: t -> Ty.t
- (** Return the type from a clsem *)
-
- val sem: t -> D.t
- (** Return the sem from a clsem *)
-
- val clsem: t -> ClSem.t
- val of_clsem: ClSem.t -> t option
-
- val coerce_clsem: ClSem.t -> t
-
-end
-
-
-module Print : sig (** Cutting the knot for printer *)
- type pdem_event = { mutable
- pdem_event : 'k 'd. ('k,'d) dem -> 'k Pp.printer}
-
- val pdem_event : pdem_event
- val dem_event : ('k,'d) dem -> 'k Pp.printer
-
- type pdem_runable =
- { mutable pdem_runable : 'k 'd. ('k,'d) dem -> 'd Pp.printer}
-
- val pdem_runable : pdem_runable
- val dem_runable : ('k,'d) dem -> 'd Pp.printer
-
-
-end
-
-val check_initialization: unit -> bool
-(** Check if the initialization of all the dom, sem and dem have been done *)
-
-(** Only for Solver *)
-module Only_for_solver: sig
- type sem_of_cl =
- | Sem: 'a sem * 'a -> sem_of_cl
-
- val clsem:
- Cl.t -> ClSem.t option
- (** give the sem associated with a cl, make sense only for not merged
- class. So only the module solver can use it *)
-
- val sem_of_cl:
- ClSem.t -> sem_of_cl
- (** give the sem associated with a cl, make sense only for not merged
- class. So only the module solver can use it *)
-
- val cl_of_clsem: ClSem.t -> Cl.t
-
- type opened_cl =
- | Fresh: opened_cl
- | Fresh_to_reg: ('event,'r) dem * 'event -> opened_cl
- | Sem : ClSem.t -> opened_cl
-
- val open_cl: Cl.t -> opened_cl
-
-end
diff --git a/src/scheduler.ml b/src/scheduler.ml
deleted file mode 100644
index c0385a8e6..000000000
--- a/src/scheduler.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-module Scheduler = Scheduler_queue
-
-let new_env propagatel () =
- let sched = Scheduler.new_solver () in
- let d = Scheduler.get_delayed sched in
- List.iter (fun f -> f d) propagatel;
- Scheduler.flush_delayed sched;
- sched
-
-
-let get_t = Scheduler.get_delayed
-
-let run_exn = Scheduler.run_exn
diff --git a/src/scheduler_queue.ml b/src/scheduler_queue.ml
deleted file mode 100644
index a4fff0ca4..000000000
--- a/src/scheduler_queue.ml
+++ /dev/null
@@ -1,431 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-
-module S = Solver
-
-let debug = Debug.register_info_flag
- ~desc:"for the scheduler in the simple version"
- "sched_queue"
-
-let debug_pushpop = Debug.register_info_flag
- ~desc:"for the scheduler push/pop"
- "sched_pushpop"
-
-let var_decay = 1. /. 0.95
-
-let stats_propa = Debug.register_stats_int ~name:"Scheduler.daemon" ~init:0
-let stats_dec = Debug.register_stats_int ~name:"Scheduler.decision" ~init:0
-let stats_con = Debug.register_stats_int ~name:"Scheduler.conflict" ~init:0
-
-exception NeedStopDelayed
-
-module Att = struct
- type t =
- | Daemon of int * S.daemon_key
- | Decision of int * Explanation.chogen
- type prio = float
- type db = float Conflict.ChoGenH.t
-
- let get_prio db chogen =
- Conflict.ChoGenH.find_def db 0. chogen
-
- let le (x:t) (xp:float) (y:t) (yp:float) =
- match x, y with
- | Daemon (x,_) , Daemon (y,_) -> x <= y
- | Decision (x,_), Decision (y,_) ->
- if xp = yp then x <= y else xp >= yp (** min *)
- | Daemon _ , Decision _ -> true
- | Decision _, Daemon _ -> false
- let reprio db = function
- | Daemon _ -> 0.
- | Decision (_,chogen) -> get_prio db chogen
-end
-exception Contradiction
-
-module Prio = Leftistheap.Make(Att)
-let is_dec = function
- | Att.Daemon _ -> false
- | Att.Decision _ -> true
-
-type pre =
- { pre_wakeup_daemons : Prio.t;
- pre_prev_scheduler_state : pre option;
- pre_solver_state : S.t;
- pre_learnt : Conflict.finalized list; (* bags *)
- pre_lastdec : Explanation.chogen;
- }
-
-type t =
- { mutable wakeup_daemons : Prio.t;
- mutable prev_scheduler_state : pre option;
- mutable solver_state : S.t;
- mutable delayed : S.Delayed.t option;
- mutable learnt : Conflict.finalized list; (* bags *)
- (* global *)
- decprio : Att.db;
- var_inc : float ref;
- }
-(** To treat in the reverse order *)
-
-let get_t t = t.solver_state
-
-let print_level fmt t =
- Format.fprintf fmt "%a (%i)"
- Explanation.Age.print (S.current_age t.solver_state)
- (S.current_nbdec t.solver_state)
-
-let new_handler t =
- if t.delayed <> None then raise NeedStopDelayed;
- {wakeup_daemons = t.wakeup_daemons;
- prev_scheduler_state = t.prev_scheduler_state;
- solver_state = S.new_handler t.solver_state;
- learnt = t.learnt;
- delayed = None;
- decprio = t.decprio;
- var_inc = t.var_inc
- }
-
-let new_t t =
- { wakeup_daemons = Prio.empty;
- prev_scheduler_state = None;
- solver_state = S.new_handler t;
- learnt = [];
- delayed = None;
- decprio = Conflict.ChoGenH.create 100;
- var_inc = ref 1.;
- }
-
-let new_solver () = new_t (S.new_t ())
-
-let push t chogen =
- Debug.dprintf0 debug_pushpop "[Scheduler] push@\n";
- let prev =
- { pre_wakeup_daemons = t.wakeup_daemons;
- pre_prev_scheduler_state = t.prev_scheduler_state;
- pre_solver_state = S.new_handler t.solver_state;
- pre_learnt = t.learnt;
- pre_lastdec = chogen;
- } in
- t.prev_scheduler_state <- Some prev;
- t.learnt <- []
-
-let update_prio t chogen =
- Conflict.ChoGenH.change (function
- | None -> Some (!(t.var_inc))
- | Some i -> Some (i +. (!(t.var_inc)))) t.decprio chogen
-
-let new_delayed =
- let daemon_count = ref (-1) in
- let dec_count = ref (-1) in
- fun t ->
- let sched_daemon att =
- incr daemon_count;
- Debug.dprintf1 debug "[Scheduler] New possible daemon:%i@\n"
- !daemon_count;
- t.wakeup_daemons <-
- Prio.insert t.decprio (Att.Daemon (!daemon_count,att))
- t.wakeup_daemons in
- let sched_decision dec =
- incr dec_count;
- Debug.dprintf1 debug "[Scheduler] New possible decisions prio:%i@\n"
- !dec_count;
- t.wakeup_daemons <- Prio.insert t.decprio (Att.Decision (!dec_count,dec))
- t.wakeup_daemons in
- S.new_delayed ~sched_daemon ~sched_decision t.solver_state
-
-(*
- let rec apply_learnt llearnt t d =
- match llearnt with
- | [] -> d
- | a::l ->
- (** the first one should be the last conflict found so decide on it *)
- try
- let {Conflict.fin_dec = Explanation.GCho(cho,k)} = a d in
- S.flush d;
- List.iter (fun f -> ignore (f d); S.flush d) l;
- run_until_dec t d;
- run_dec t d t.wakeup_daemons
- (fun d dec -> Conflict.make_decision d dec cho k)
- with S.Contradiction pexp ->
- Debug.dprintf0 debug "[Scheduler] Contradiction during apply learnt@\n";
- conflict_analysis t pexp
-*)
-
-type choice =
- | Choice: ('k,'d) Explanation.cho * 'k * 'd * float -> choice
- | NoChoice
-
-let rec apply_learnt (learntdec: Conflict.finalized) tags llearnt t d =
- try
- Debug.dprintf0 debug "[Scheduler] Apply previously learnt@\n";
- let iter_learnt f =
- Debug.dprintf2 debug "[Scheduler] @[Apply %a@]@\n"
- Conflict.print_finalized f;
- let clauses = f#conflict_add d in
- let cl = Bool.mk_clause clauses in
- (** What is learnt is a general consequence *)
- let pexp = Solver.Delayed.mk_pexp ~age:Explanation.Age.min
- d Conflict.explearnt (Conflict.ExpLearnt tags) in
- Solver.Delayed.register d cl;
- Bool.set_true d pexp cl;
- S.flush d in
- List.iter iter_learnt llearnt;
- iter_learnt learntdec;
- run_until_dec t d;
- Debug.dprintf0 debug "[Scheduler] Apply learntdec@\n";
- (** Do directly a decision on the last conflict learnt *)
- let fold_decisions acc cho' k' d' =
- match acc with
- | NoChoice ->
- let f' = Att.get_prio t.decprio (Explanation.GCho(cho',k')) in
- Choice(cho',k',d',f')
- | Choice(_,_,_,f) ->
- let f' = Att.get_prio t.decprio (Explanation.GCho(cho',k')) in
- if f >= f' then acc else Choice(cho',k',d',f')
- in
- match learntdec#decide {Conflict.fold_decisions} d NoChoice with
- | NoChoice ->
- d
- | Choice(cho,k,v,_) ->
- run_dec t d cho k v
- with S.Contradiction pexp ->
- Debug.dprintf0 debug "[Scheduler] Contradiction during apply learnt@\n";
- conflict_analysis t pexp
-
-and pop_to t prev =
- Debug.dprintf2 debug_pushpop "[Scheduler] pop %a@\n"
- print_level t;
- t.wakeup_daemons <- prev.pre_wakeup_daemons;
- t.prev_scheduler_state <- prev.pre_prev_scheduler_state;
- t.solver_state <- prev.pre_solver_state;
- t.learnt <- prev.pre_learnt;
- new_delayed t
-
-(*
- and conflict_analysis t pexp =
- Debug.incr stats_con;
- let learnt,_tags, _decs = Conflict.analyse t.solver_state pexp in
- let learnt,maxage = match learnt with
- | None -> raise Contradiction
- | Some learntmaxage -> learntmaxage in
- let rec rewind llearnt maxage prevo =
- match prevo with
- | None -> raise Contradiction
- | Some prev when
- Explanation.current_age
- (S.get_trail prev.pre_solver_state) <= maxage ->
- llearnt,prev
- | Some prev ->
- let llearnt = List.rev_append llearnt prev.pre_learnt in
- rewind llearnt maxage prev.pre_prev_scheduler_state
- in
- let llearnt,prev =
- rewind (learnt::t.learnt) maxage t.prev_scheduler_state in
- Debug.dprintf2 debug_pushpop "[Scheduler] Pop to level %a@\n"
- Explanation.Age.print maxage;
- pop_to llearnt t prev
-*)
-
-and conflict_analysis t pexp =
- Debug.incr stats_con;
- if Solver.current_nbdec t.solver_state = 0 then raise Contradiction
- else
- let pre_solver_state = match t.prev_scheduler_state with
- | None -> (* level 0 *) raise Contradiction
- | Some prev -> prev.pre_solver_state in
- let learnt,tags, decs =
- Conflict.analyse pre_solver_state t.solver_state
- (Solver.get_trail t.solver_state) pexp in
- t.var_inc := !(t.var_inc) *. var_decay;
- Bag.iter (update_prio t) decs;
- let learnt = match learnt with
- | None -> raise Contradiction
- | Some learnt -> learnt in
- (** We look for the level where lastlearnt is not false *)
- let rec rewind t learnt llearnt prevo =
- match prevo with
- | None -> raise Contradiction
- | Some prev ->
- let prevage = Explanation.current_age (** for printing *)
- (S.get_trail prev.pre_solver_state) in
- let d = pop_to t prev in
- let llearnt_all = List.rev_append llearnt prev.pre_learnt in
- let open Conflict in
- match learnt#test d with
- | True -> raise Types.Impossible (** understand why that happend *)
- | False -> rewind t learnt llearnt_all prev.pre_prev_scheduler_state
- | ToDecide ->
- (** we found the level *)
- Debug.dprintf4 debug_pushpop "[Scheduler] Pop to level %a %a@\n"
- Explanation.Age.print prevage print_level t;
- t.learnt <- learnt::llearnt_all;
- d,learnt,llearnt
- in
- let d,learntdec,llearnt =
- rewind t learnt t.learnt t.prev_scheduler_state in
- t.wakeup_daemons <- Prio.reprio t.decprio t.wakeup_daemons;
- apply_learnt learntdec tags llearnt t d
-
-and try_run_dec:
- type k d. t -> S.Delayed.t -> Prio.t -> ((k,d) Explanation.cho) -> k ->
- S.Delayed.t = fun t d prio cho k ->
- (** First we verify its the decision is at this point needed *)
- try
- match Conflict.choose_decision d cho k with
- | Conflict.DecNo ->
- t.wakeup_daemons <- prio;
- d (** d can be precised by choose_decision *)
- | Conflict.DecTodo todo ->
- Debug.incr stats_dec;
- S.delayed_stop d;
- Debug.dprintf2 debug_pushpop
- "[Scheduler] Make decision: level %a@\n"
- print_level t;
- (** The registered state keep the old prio *)
- push t (Explanation.GCho(cho,k));
- (** We use the priority list without the decision only in the
- branch where the decision is made *)
- t.wakeup_daemons <- prio;
- let declevel = Explanation.new_dec (S.get_trail t.solver_state) in
- let d = new_delayed t in
- todo d declevel;
- d
- with S.Contradiction pexp ->
- Debug.dprintf0 debug "[Scheduler] Contradiction@\n";
- conflict_analysis t pexp
-
-and run_dec:
- type k d. t -> S.Delayed.t -> ((k,d) Explanation.cho) -> k -> d ->
- S.Delayed.t = fun t d cho k v ->
- (** First we verify its the decision is at this point needed *)
- try
- Debug.incr stats_dec;
- S.delayed_stop d;
- Debug.dprintf2 debug_pushpop
- "[Scheduler] Make decision: level %a@\n"
- print_level t;
- (** The registered state keep the old prio *)
- push t (Explanation.GCho(cho,k));
- let declevel = Explanation.new_dec (S.get_trail t.solver_state) in
- let d = new_delayed t in
- Conflict.make_decision d cho k v declevel;
- d
- with S.Contradiction pexp ->
- Debug.dprintf0 debug "[Scheduler] Contradiction@\n";
- conflict_analysis t pexp
-
-and run_until_dec t d =
- let act = Prio.min t.wakeup_daemons in
- match act with
- | Att.Daemon (_,att) -> begin
- let _, prio = Prio.extract_min t.wakeup_daemons in
- Debug.incr stats_propa;
- t.wakeup_daemons <- prio;
- S.run_daemon d att;
- S.flush d;
- run_until_dec t d
- end
- | Att.Decision (_,_) -> ()
-
-
-let run_one_step t d =
- let act, prio = Prio.extract_min t.wakeup_daemons in
- match act with
- | Att.Daemon (_,att) -> begin
- Debug.incr stats_propa;
- t.wakeup_daemons <- prio;
- try
- S.run_daemon d att; d
- with S.Contradiction pexp ->
- Debug.dprintf0 debug "[Scheduler] Contradiction@\n";
- conflict_analysis t pexp
- end
- | Att.Decision (_,Explanation.GCho(cho,k)) -> try_run_dec t d prio cho k
-
-let rec flush t d =
- try
- S.flush d; d
- with S.Contradiction pexp ->
- Debug.dprintf0 debug "[Scheduler] Contradiction@\n";
- let d = conflict_analysis t pexp in
- flush t d
-
-let rec run_inf_step ~nodec t d =
- let d = flush t d in
- if not (Prio.is_empty t.wakeup_daemons)
- && not (nodec && is_dec (Prio.min t.wakeup_daemons))
- then
- let d = run_one_step t d in
- run_inf_step ~nodec t d
- else
- S.delayed_stop d
-
-let run_inf_step ?(nodec=false) t =
- if t.delayed <> None then raise NeedStopDelayed;
- let d = new_delayed t in
- run_inf_step ~nodec t d
-
-let get_delayed t =
- match t.delayed with
- | Some d -> d
- | None ->
- let d = new_delayed t in
- t.delayed <- Some d;
- d
-
-let flush_delayed t =
- match t.delayed with
- | None -> ()
- | Some d ->
- t.delayed <- Some (flush t d)
-
-let stop_delayed t =
- match t.delayed with
- | None -> ()
- | Some d ->
- let d = flush t d in
- S.delayed_stop d;
- t.delayed <- None
-
-let run_exn ?nodec ~theories f =
- let t = new_solver () in
- begin try
- let d = get_delayed t in
- List.iter (fun f -> f d) theories;
- Solver.flush d;
- f d
- with S.Contradiction _ ->
- Debug.dprintf0 debug
- "[Scheduler] Contradiction during initial assertion@\n";
- raise Contradiction
- end;
- stop_delayed t;
- run_inf_step ~nodec:(nodec=Some ()) t;
- get_delayed t
-
-let run ?nodec ~theories f =
- try
- `Done (run_exn ?nodec ~theories f)
- with Contradiction ->
- `Contradiction
diff --git a/src/scheduler_queue.mli b/src/scheduler_queue.mli
deleted file mode 100644
index f62d3fda8..000000000
--- a/src/scheduler_queue.mli
+++ /dev/null
@@ -1,68 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-type t
-
-val run:
- ?nodec:unit ->
- theories:(Solver.d -> unit) list ->
- (Solver.d -> unit) ->
- [`Contradiction | `Done of Solver.d]
-
-exception Contradiction
-
-val run_exn:
- ?nodec:unit ->
- theories:(Solver.d -> unit) list ->
- (Solver.d -> unit) ->
- Solver.d
-
-
-(** {2 Expert interface} *)
-val new_solver: unit -> t
-(** Create a scheduler *)
-
-val get_t: t -> Solver.t
-(** Get the solver. *)
-
-val get_delayed : t -> Solver.Delayed.t
-(** Get the delayed solver. *)
-
-val flush_delayed : t -> unit
-(** Flush the delayed solver. Apply all the delayed actions.
- Previous {!get_delayed} results shouldn't be used anymore.
-*)
-
-val stop_delayed : t -> unit
-
-exception NeedStopDelayed
-
-val run_inf_step: ?nodec:bool -> t -> unit
-(** Raise NeedStopDelayed if {!stop_delayed} have not been called since the last
- {!get_delayed}.
-*)
-
-val new_handler : t -> t
-(** Raise NeedStopDelayed if {!stop_delayed} have not been called since the last
- {!get_delayed}.
-*)
-
diff --git a/src/solver.ml b/src/solver.ml
deleted file mode 100644
index 3cb3fab24..000000000
--- a/src/solver.ml
+++ /dev/null
@@ -1,1173 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Stdlib
-open Types
-open Explanation
-
-exception Contradiction of Explanation.pexp
-
-let debug = Debug.register_info_flag
- ~desc:"for the core solver"
- "Solver.all"
-let debug_few = Debug.register_info_flag
- ~desc:"for the core solver"
- "Solver.few"
-
-let stats_set_dom =
- Debug.register_stats_int ~name:"Solver.set_dom/merge" ~init:0
-
-type exp_same_sem =
-| ExpSameSem : pexp * Cl.t * ClSem.t -> exp_same_sem
-
-let exp_same_sem : exp_same_sem Explanation.exp =
- Explanation.Exp.create_key "Solver.same_sem_exp"
-
-module VEnv = Env.MkVector(struct type ('a,'b) t = 'a Pp.printer end)
-let defined_env = VEnv.create 8
-let print_env k =
- assert (if VEnv.is_uninitialized defined_env k
- then raise UnregisteredKey else true);
- VEnv.get defined_env k
-
-let register_env printer env =
- VEnv.inc_size env defined_env;
- assert (if not (VEnv.is_uninitialized defined_env env)
- then raise AlreadyRegisteredKey else true);
- VEnv.set defined_env env printer
-
-
-module Events = struct
-
- module Wait = struct
- type t =
- | Event: ('k,'d) dem * 'k -> t
-
- let print fmt = function
- | Event (dem, event) ->
- let f (type k) (type d) (dem:(k,d) dem) (event : k) =
- Format.fprintf fmt "Demon %a event %a"
- Dem.print dem (Print.dem_event dem) event
- in
- f dem event
- end
-
-
- module Fired = struct
- type 'b event =
- (** the domain dom of the class change *)
- | EventDom : Cl.t * 'a dom * 'b -> 'b event
- (** a new semantical value 'a point to this class (not complete) *)
- | EventSem : Cl.t * 'a sem * 'a * 'b -> 'b event
- (** we want to register a class *)
- | EventReg : Cl.t * 'b -> 'b event
- (** we want to register this class *)
- | EventRegCl : Cl.t * 'b -> 'b event
- (** This class is not the representant of its eq-class anymore *)
- | EventChange : Cl.t * 'b -> 'b event
- (** a new semantical value 'a appear *)
- | EventRegSem : ClSem.t * 'b -> 'b event
-
- type 'a translate = { translate : 'd. 'a -> 'd -> 'd event}
-
- let translate_dom =
- {translate = fun (cl,dom) data -> EventDom(cl,dom,data)}
- (* let translate_sem = *)
- (* {translate = fun (cl,sem,s) data -> EventSem(cl,sem,s,data)} *)
- let translate_reg =
- {translate = fun cl data -> EventReg(cl,data)}
- let translate_regcl =
- {translate = fun cl data -> EventRegCl(cl,data)}
- let translate_change =
- {translate = fun cl data -> EventChange(cl,data)}
- let translate_regsem =
- {translate = fun clsem data -> EventRegSem(clsem,data)}
-
- let print fmt = function
- | EventDom (cl, dom, _) ->
- Format.fprintf fmt "dom:%a of %a" Dom.print dom Cl.print cl
- | EventSem (cl, sem, v, _) ->
- Format.fprintf fmt "sem:%a of %a with %a"
- Sem.print sem Cl.print cl (print_sem sem) v
- | EventReg (cl, _) ->
- Format.fprintf fmt "any registration of %a" Cl.print cl
- | EventRegCl (cl, _) ->
- Format.fprintf fmt "registration of %a" Cl.print cl
- | EventChange (cl, _) ->
- Format.fprintf fmt "changecl of %a" Cl.print cl
- | EventRegSem (clsem, _) ->
- let cl = Only_for_solver.cl_of_clsem clsem in
- match Only_for_solver.sem_of_cl clsem with
- | Only_for_solver.Sem(sem,v) ->
- Format.fprintf fmt "registration of sem:%a of %a with %a"
- Sem.print sem Cl.print cl (print_sem sem) v
-
- let get_data = function
- | EventDom (_, _ , d) -> d
- | EventSem (_, _, _, d) -> d
- | EventReg (_, d) -> d
- | EventRegCl (_, d) -> d
- | EventChange (_, d) -> d
- | EventRegSem (_, d) -> d
-
-
- type 'b t = 'b event list
- end
-
-end
-
-module type Dom' = sig
- type delayed
- type t
-
- val merged: t option -> t option -> bool
- val merge: delayed ->
- Explanation.pexp -> t option * Cl.t -> t option * Cl.t ->
- bool ->
- unit
- val print: Format.formatter -> t -> unit
- val key: t dom
-end
-
-
-type _ enqueue =
-| EnqRun: 'r -> 'r enqueue
-| EnqAlready: _ enqueue
-| EnqRedirected: ('e,'r) dem * 'e -> _ enqueue
-| EnqStopped: _ enqueue
-
-module type Dem' = sig
- type delayed
-
- type runable
- val print_runable: runable Pp.printer
- val run: delayed -> runable -> runable option
-
- type event
- val print_event: event Pp.printer
- val enqueue: delayed -> event Events.Fired.event -> runable enqueue
-
- val key: (event,runable) dem
- val immediate: bool
-
-end
-
-module DecTag = DInt
-
-module type DomTable' = sig
- type delayed
- module D : Dom' with type delayed := delayed
- val table : D.t Cl.M.t
- val events : Events.Wait.t Bag.t Cl.M.t
-end
-
-type semtable = Events.Wait.t list
-
-module VDomTable = Dom.MkVector
- (struct type ('a,'delayed) t =
- (module DomTable' with type D.t = 'a and type delayed = 'delayed)
- end)
-module VSemTable = Sem.Vector
-
-(** Environnement *)
-
-(** mutable but only contain persistent structure *)
-(** Just for easy qualification *)
-module Def = struct
-type t = {
- mutable repr : Cl.t Cl.M.t;
- mutable event : Events.Wait.t Bag.t Cl.M.t;
- mutable event_reg : Events.Wait.t list Cl.M.t;
- mutable event_any_reg : Events.Wait.t list;
- (** extensible "number of fields" *)
- dom : delayed_t VDomTable.t;
- sem : semtable VSemTable.t;
- envs : unit Env.VectorH.t;
- trail : Explanation.t;
- mutable current_delayed : delayed_t; (** For assert-check *)
-}
-
-and daemon_key =
-| DaemonKey: ('k,'runable) dem * 'runable -> daemon_key
-
-(** delayed_t is used *)
-and delayed_t = {
- env : t;
- todo_immediate_dem : action_immediate_dem Queue.t;
- todo_merge_dom : action_merge_dom Queue.t;
- mutable todo_delayed_merge : (pexp * Cl.t * Cl.t * bool) option;
- todo_merge : action_merge Queue.t;
- todo_ext_action : action_ext Queue.t;
- sched_daemon : daemon_key -> unit;
- sched_decision : chogen -> unit;
-}
-
-and action_immediate_dem =
-| RunDem : daemon_key -> action_immediate_dem
-
-and action_merge_dom =
-| SetMergeDomCl :
- pexp * 'a dom * Cl.t * Cl.t * bool -> action_merge_dom
-
-and action_merge =
-| Merge of pexp * Cl.t * Cl.t
-
-and action_ext =
-(* | ExtSetDom : pexp * 'a dom * Cl.t * 'a -> action_ext *)
-(* | ExtSetMergeDom : pexp * 'a dom * Cl.t * 'a option -> action_ext *)
-(* | ExtSetSem : pexp * 'a sem * Cl.t * 'a -> action_ext *)
-(* | ExtMerge : pexp * Cl.t * Cl.t -> action_ext *)
-| ExtDem : daemon_key -> action_ext
-
-end
-
-include Def
-
-let mk_dumb_delayed () = { env = Obj.magic 0;
- todo_immediate_dem = Queue.create ();
- todo_merge_dom = Queue.create ();
- todo_delayed_merge = None;
- todo_merge = Queue.create ();
- todo_ext_action = Queue.create ();
- sched_daemon = (fun _ -> (assert false : unit));
- (* should never be called *)
- sched_decision = (fun _ -> (assert false : unit));
- }
-
-let dumb_delayed = mk_dumb_delayed ()
-let unsat_delayed = mk_dumb_delayed ()
-
-
-let new_t () = {
- repr = Cl.M.empty;
- event = Cl.M.empty;
- event_reg = Cl.M.empty;
- event_any_reg = [];
- dom = VDomTable.create 5;
- sem = VSemTable.create 5;
- envs = Env.VectorH.create 5;
- trail = Explanation.create ();
- current_delayed = dumb_delayed;
- }
-
-let new_handler t =
- assert (t.current_delayed == dumb_delayed);
- {
- repr = t.repr;
- event = t.event;
- event_reg = t.event_reg;
- event_any_reg = t.event_any_reg;
- dom = VDomTable.copy t.dom;
- sem = VSemTable.copy t.sem;
- envs = Env.VectorH.copy t.envs;
- trail = Explanation.new_handler t.trail;
- current_delayed = t.current_delayed;
-}
-
-(** {2 Dom and Sem} *)
-module type Dom = Dom' with type delayed := delayed_t
-module type Dem = Dem' with type delayed := delayed_t
-
-module VDom = Dom.MkVector
- (struct type ('a,'unedeed) t =
- (module Dom with type t = 'a)
- end)
-
-module VDem = Dem.MkVector
- (struct type ('k,'d,'unedeed) t =
- (module Dem with type event = 'k and type runable = 'd) end)
-
-let defined_dom : unit VDom.t = VDom.create 8
-let defined_dem : unit VDem.t = VDem.create 8
-
-module RegisterDom (D:Dom) = struct
-
- let () =
- VDom.inc_size D.key defined_dom;
- assert (if not (VDom.is_uninitialized defined_dom D.key)
- then raise AlreadyRegisteredKey else true);
- let dom = (module D: Dom with type t = D.t) in
- VDom.set defined_dom D.key dom
-
-end
-
-
-module RegisterDem (D:Dem) = struct
-
- let () =
- VDem.inc_size D.key defined_dem;
- assert (if not (VDem.is_uninitialized defined_dem D.key)
- then raise AlreadyRegisteredKey else true);
- let dem =
- (module D: Dem with type event = D.event and type runable = D.runable) in
- VDem.set defined_dem D.key dem
-
-end
-
-let get_dom k =
- assert (if VDom.is_uninitialized defined_dom k
- then raise UnregisteredKey else true);
- VDom.get defined_dom k
-
-let get_dem k =
- assert (if VDem.is_uninitialized defined_dem k
- then raise UnregisteredKey else true);
- VDem.get defined_dem k
-
-let print_dom (type a) (k : a dom) fmt s =
- let dom = get_dom k in
- let module D = (val dom : Dom with type t = a) in
- D.print fmt s
-
-let print_dom_opt k fmt = function
- | None -> Format.pp_print_string fmt "N"
- | Some s -> print_dom k fmt s
-
-let print_dem_event (type k) (type d) (k : (k,d) dem) fmt s =
- let module S = (val get_dem k) in
- S.print_event fmt s
-
-let () = Print.pdem_event.Print.pdem_event <- print_dem_event
-
-let print_dem_runable (type k) (type d) (k : (k,d) dem) fmt s =
- let module S = (val get_dem k) in
- S.print_runable fmt s
-
-let () = Print.pdem_runable.Print.pdem_runable <- print_dem_runable
-
-(** {2 Dom Sem continued} *)
-
-module type DomTable = DomTable' with type delayed = delayed_t
-
-let get_table_dom : t -> 'a dom -> (module DomTable with type D.t = 'a)
- = fun (type a) t k ->
- assert (if VDom.is_uninitialized defined_dom k
- then raise UnregisteredKey else true);
- VDomTable.inc_size k t.dom;
- if VDomTable.is_uninitialized t.dom k then
- let dom = get_dom k in
- let module DomTable = struct
- type delayed = delayed_t
- module D = (val dom : Dom with type t = a)
- let table = Cl.M.empty
- let events = Cl.M.empty
- end in
- (module DomTable : DomTable with type D.t = a)
- else
- (module (val VDomTable.get t.dom k
- : DomTable' with type D.t = a and type delayed = delayed_t)
- : DomTable with type D.t = a)
-
-let get_table_sem : t -> 'a sem -> semtable = fun t k ->
- assert (if sem_uninitialized k then raise UnregisteredKey else true);
- VSemTable.inc_size k t.sem;
- if VSemTable.is_uninitialized t.sem k
- then begin Sem.Vector.set t.sem k []; [] end
- else Sem.Vector.get t.sem k
-
-exception UninitializedEnv of Env.K.t
-
-exception NotNormalized
-
-(** Just used for being able to qualify these function on t *)
-module T = struct
- let rec find t cl =
- let cl' = Cl.M.find_exn NotNormalized cl t.repr in
- if Cl.equal cl cl' then cl else
- let r = find t cl' in
- t.repr <- Cl.M.add cl r t.repr;
- r
-
- let find_def t cl =
- let cl' = Cl.M.find_def cl cl t.repr in
- if Cl.equal cl cl' then cl else
- let r = find t cl' in
- t.repr <- Cl.M.add cl r t.repr;
- r
-
- let is_repr t cl =
- try Cl.equal (Cl.M.find cl t.repr) cl
- with Not_found -> true
-
- let is_equal t cl1 cl2 =
- let cl1 = find_def t cl1 in
- let cl2 = find_def t cl2 in
- Cl.equal cl1 cl2
-end
-open T
-
-let get_direct_dom (type a) t (dom : a dom) cl =
- let module DomTable =
- (val (get_table_dom t dom) : DomTable with type D.t = a) in
- Cl.M.find_opt cl DomTable.table
-
-let get_dom t dom cl =
- let cl = find_def t cl in
- get_direct_dom t dom cl
-
-(** {2 For debugging and display} *)
-let _print_env fmt t =
- let printd (type a) _ fmt domtable =
- let module DomTable =
- (val domtable : DomTable' with type delayed = delayed_t
- and type D.t = a) in
- Format.fprintf fmt "%a:@[%a@]" Dom.print DomTable.D.key
- (Pp.print_iter2 Cl.M.iter Pp.newline Pp.colon
- Cl.print (Bag.print Pp.comma Events.Wait.print))
- DomTable.events
- in
- VDomTable.print Pp.newline Pp.nothing
- {VDomTable.printk = Pp.nothing}
- {VDomTable.printd} fmt t.dom
-
-
-let output_graph filename t =
- let open Graph in
- let module G = struct
- include Imperative.Digraph.Concrete(Cl)
- let graph_attributes _ = []
- let default_vertex_attributes _ = [`Shape `Record]
- let vertex_name cl = string_of_int (Cl.hash cl)
-
- let print fmt cl =
- let iter_dom (type a) _ fmt dom =
- let module Dom =
- (val dom : DomTable' with type delayed = delayed_t
- and type D.t = a) in
- try
- let s = Cl.M.find cl Dom.table in
- Format.fprintf fmt "| {%a | %a}"
- Types.Dom.print Dom.D.key Dom.D.print s;
- with Not_found -> ()
- in
- let print_ty fmt cl =
- if is_repr t cl
- then Format.fprintf fmt ": %a" Ty.print (Cl.ty cl)
- in
- let print_sem fmt cl =
- match Only_for_solver.clsem cl with
- | None -> ()
- | Some clsem ->
- match Only_for_solver.sem_of_cl clsem with
- | Only_for_solver.Sem(sem,v) ->
- let module S = (val get_sem sem) in
- Format.fprintf fmt "| {%a | %a}"
- Sem.print sem S.print v
- in
- Format.fprintf fmt "{%a %a %a %a}" (* "{%a | %a | %a}" *)
- Cl.print cl
- print_ty cl
- print_sem cl
- (if is_repr t cl
- then VDomTable.print Pp.nothing Pp.nothing
- {VDomTable.printk=Pp.nothing}
- {VDomTable.printd=iter_dom}
- else Pp.nothing)
- t.dom
-
- let vertex_attributes cl =
- let label = Pp.string_of_wnl print cl in
- [`Label label]
- let default_edge_attributes _ = []
- let edge_attributes _ = []
- let get_subgraph _ = None
- end in
- let g = G.create () in
- Cl.M.iter (fun cl1 cl2 ->
- if Cl.equal cl1 cl2
- then G.add_vertex g cl1
- else G.add_edge g cl1 (find_def t cl2)) t.repr;
- let cout = open_out filename in
- let module Dot = Graphviz.Dot(G) in
- Dot.output_graph cout g;
- close_out cout
-
-let show_graph = Debug.register_flag
- ~desc:"Show each step in a gui"
- "dotgui"
-
-let draw_graph =
- let c = ref 0 in
- fun ?(force=false) t ->
- if force || Debug.test_flag show_graph then
- let filename = Format.sprintf "debug_graph.tmp/debug_graph%i.dot" !c in
- incr c;
- Debug.dprintf1 Debug._true "[DotGui] output dot file: %s@\n" filename;
- output_graph filename t
-
-
-(** {2 Delayed} *)
-
-module Delayed = struct
- open T
- type t = delayed_t
-
- let is_current_env t = t.env.current_delayed == t
-
- let find t cl =
- assert (is_current_env t);
- find t.env cl
-
- let find_def t cl =
- assert (is_current_env t);
- find_def t.env cl
-
- let is_repr t cl =
- assert (is_current_env t);
- is_repr t.env cl
-
- (* let is_repr_of t cl1 cl2 = *)
- (* try Cl.equal (find t cl2) cl1 *)
- (* with NotNormalized -> Cl.equal cl2 cl1 *)
-
- let is_equal t cl1 cl2 =
- assert (is_current_env t);
- is_equal t.env cl1 cl2
-
-
- let is_registered t cl = Cl.M.mem cl t.env.repr
-
- let add_pending_merge (t : t) pexp cl cl' =
- Debug.dprintf4 debug "[Solver] @[add_pending_merge for %a and %a@]@\n"
- Cl.print cl Cl.print cl';
- assert (is_registered t cl);
- assert (is_registered t cl');
- assert (not (Cl.equal (find t cl) (find t cl')));
- assert (Ty.equal (Cl.ty cl) (Cl.ty cl'));
- Queue.add (Merge (pexp,cl,cl')) t.todo_merge
-
- let new_pending_daemon (type k) (type d) t (dem:(k,d) dem) runable =
- let module Dem = (val get_dem dem) in
- let daemonkey = DaemonKey(dem, runable) in
- if Dem.immediate
- then Queue.push (RunDem daemonkey) t.todo_immediate_dem
- else t.sched_daemon daemonkey
-
-
- let get_dom t dom cl =
- assert (is_current_env t);
- get_dom t.env dom cl
-
- let wakeup_event translate t info wevent =
- match wevent with
- | Events.Wait.Event (dem,event) ->
- let rec f : type event r. t -> (event,r) dem -> event -> unit =
- fun t dem event ->
- let module Dem = (val get_dem dem) in
- let event = translate.Events.Fired.translate info event in
- match Dem.enqueue t event with
- | EnqStopped -> () (** todo remove from the list of event *)
- | EnqAlready -> ()
- | EnqRedirected(dem,event) -> f t dem event
- | EnqRun runable -> new_pending_daemon t dem runable
- in
- f t dem event
-
-
- let wakeup_events_list translate t events info =
- match events with
- | None | Some [] ->
- Debug.dprintf0 debug "[Solver] @[No scheduling@]@\n"
- | Some events ->
- List.iter (wakeup_event translate t info) events
-
- let wakeup_events_bag translate t events info =
- let is_empty = match events with
- | None -> true
- | Some events -> Bag.is_empty events in
- if is_empty then Debug.dprintf0 debug "[Solver] @[No scheduling@]@\n"
- else Bag.iter (wakeup_event translate t info) (Opt.get events)
-
-
- let attach_dom (type a) t cl (dom : a dom) dem event =
- let cl = find_def t cl in
- let event = Events.Wait.Event (dem,event) in
- let module DomTable = (val (get_table_dom t.env dom)) in
- let module DomTable' = struct
- (** remove the old domantical value
- replace it by the new one *)
- include DomTable
- let events = Cl.M.add_change Bag.elt Bag.add cl event events
- end in
- VDomTable.set t.env.dom dom (module DomTable')
-
- let attach_cl t cl dem event =
- let cl = find_def t cl in
- let event = Events.Wait.Event (dem,event) in
- t.env.event <- Cl.M.add_change Bag.elt Bag.add cl event t.env.event
-
- let attach_reg_cl t cl dem event =
- let event = Events.Wait.Event (dem,event) in
- begin try
- let cl = find t cl in
- (** already registered *)
- wakeup_events_list Events.Fired.translate_regcl t (Some [event]) cl
- with NotNormalized ->
- t.env.event_reg <-
- Cl.M.add_change Lists.singleton Lists.add cl event t.env.event_reg
- end
-
- let attach_reg_sem (type a) t (sem : a sem) dem event =
- let event = Events.Wait.Event (dem,event) in
- let reg_events = get_table_sem t.env sem in
- let reg_events = event::reg_events in
- Sem.Vector.set t.env.sem sem reg_events
-
- let attached_reg_cl
- (type k) (type d) d cl (dem:(k,d) dem) : k Enum.t =
- Enum.from_list
- ~filter:(function
- | Events.Wait.Event(dem',_) ->
- Dem.equal dem dem'
- )
- ~map:(function
- | Events.Wait.Event(dem',event) ->
- match Dem.Eq.coerce_type dem dem' with
- | Types.Eq, Types.Eq -> (event:k)
- )
- (Cl.M.find_def [] cl d.env.event_reg)
-
- let attached_cl
- (type k) (type d) d cl (dem:(k,d) dem) : k Enum.t =
- Enum.from_bag
- ~filter:(function
- | Events.Wait.Event(dem',_) ->
- Dem.equal dem dem'
- )
- ~map:(function
- | Events.Wait.Event(dem',event) ->
- match Dem.Eq.coerce_type dem dem' with
- | Types.Eq, Types.Eq -> (event:k)
- )
- (Cl.M.find_def Bag.empty cl d.env.event)
-
-
-(** *)
-
-
- let check_no_dom t cl =
- let foldi (type a) acc _dom domtable =
- acc &&
- let module DomTable =
- (val domtable : DomTable' with type D.t = a
- and type delayed = delayed_t) in
- not (Cl.M.mem cl DomTable.table)
- in
- VDomTable.fold_initializedi {VDomTable.foldi} true t.env.dom
-
- let register t cl =
- assert (is_current_env t);
- if not (is_registered t cl) then begin
- if Debug.test_flag debug_few then begin
- match Only_for_solver.clsem cl with
- | None ->
- Debug.dprintf2 debug_few "[Solver] @[register %a@]@\n" Cl.print cl
- | Some clsem ->
- Debug.dprintf4 debug_few "[Solver] @[register %a: %a@]@\n"
- Cl.print cl ClSem.print clsem
- end;
- assert ( check_no_dom t cl );
- t.env.repr <- Cl.M.add cl cl t.env.repr;
- (** reg_cl *)
- let new_events, cl_events = Cl.M.find_remove cl t.env.event_reg in
- t.env.event_reg <- new_events;
- wakeup_events_list Events.Fired.translate_regcl t cl_events cl;
- (** reg *)
- wakeup_events_list Events.Fired.translate_reg
- t (Some t.env.event_any_reg) cl;
- (** reg_sem *)
- match Only_for_solver.open_cl cl with
- | Only_for_solver.Fresh -> ()
- | Only_for_solver.Fresh_to_reg(dem,event) ->
- wakeup_events_list Events.Fired.translate_regcl t
- (Some [Events.Wait.Event(dem,event)])
- cl;
- | Only_for_solver.Sem clsem ->
- match Only_for_solver.sem_of_cl clsem with
- | Only_for_solver.Sem(sem,_) ->
- let reg_events = get_table_sem t.env sem in
- wakeup_events_list Events.Fired.translate_regsem
- t (Some reg_events) (clsem)
- end
-
- let set_sem_pending t pexp cl0 clsem =
- let cl = find t cl0 in
- let cl0' = ClSem.cl clsem in
- assert (Ty.equal (Cl.ty cl) (Cl.ty cl0'));
- begin
- if not (is_registered t cl0') then begin
- register t cl0';
- t.env.repr <- Cl.M.add cl0' cl t.env.repr;
- let pexp = mk_pexp t.env.trail exp_same_sem
- (ExpSameSem(pexp,cl0,clsem)) in
- add_pexp_cl t.env.trail pexp ~inv:true
- ~other_cl:cl0' ~other_cl0:cl0'
- ~repr_cl:cl ~repr_cl0:cl0;
- add_merge_dom_no
- t.env.trail ~inv:true
- ~other_cl:cl0' ~other_cl0:cl0'
- ~repr_cl:cl ~repr_cl0:cl0;
- (** wakeup the daemons register_cl *)
- let event, other_event = Cl.M.find_remove cl0' t.env.event in
- wakeup_events_bag Events.Fired.translate_change t other_event cl0';
- t.env.event <- event
- end
- (** cl' is already registered *)
- else if Cl.equal cl (find t cl0') then
- (** if cl is the representant of cl' then we have nothing to do *)
- ()
- else
- (** merge cl and cl0' *)
- let pexp = mk_pexp t.env.trail exp_same_sem
- (ExpSameSem(pexp,cl0,clsem)) in
- add_pending_merge t pexp cl0 cl0'
- end
-
- let set_dom_pending (type a) t pexp (dom : a dom) cl0 new_v =
- Debug.incr stats_set_dom;
- let cl = find t cl0 in
- let module DomTable = (val (get_table_dom t.env dom)) in
- let events = Cl.M.find_opt cl DomTable.events in
- let new_table = Cl.M.add_opt cl new_v DomTable.table in
- let module DomTable' = struct
- include DomTable
- let table = new_table
- end in
- VDomTable.set t.env.dom dom (module DomTable');
- Explanation.add_pexp_dom t.env.trail pexp dom ~cl ~cl0;
- wakeup_events_bag Events.Fired.translate_dom t events (cl,dom)
-
- let set_dom_premerge_pending (type a) t (dom : a dom)
- ~from:cl0' cl0 (new_v:a) =
- Debug.incr stats_set_dom;
- let cl' = find t cl0' in
- let cl = find t cl0 in
- let module DomTable = (val (get_table_dom t.env dom)) in
- let events = Cl.M.find_opt cl DomTable.events in
- let new_table = Cl.M.add cl new_v DomTable.table in
- let module DomTable' = struct
- include DomTable
- let table = new_table
- end in
- VDomTable.set t.env.dom dom (module DomTable');
- Explanation.add_pexp_dom_premerge t.env.trail dom
- ~clfrom:cl' ~clfrom0:cl0' ~clto:cl;
- wakeup_events_bag Events.Fired.translate_dom t events (cl0,dom)
-
-
-(*
- merge:
- 1) choose the representative between cl1 and cl2
- 2) "Merge" the semantical value and create new pending merge if the resulting
- sematical value already exists. Add pending event for the modification of
- the representative
- 3) Merge the dom and add the pending event
-*)
-
- let choose_repr a b = Shuffle.shuffle2 (a,b)
-
- (** TODO rename other_cl repr_cl *)
- let merge_dom_pending (type a) t pexp (dom : a dom) other_cl0 repr_cl0 inv =
- let other_cl = find t other_cl0 in
- let repr_cl = find t repr_cl0 in
- let module DomTable = (val (get_table_dom t.env dom)) in
- let old_other_s = Cl.M.find_opt other_cl DomTable.table in
- let old_repr_s = Cl.M.find_opt repr_cl DomTable.table in
- Debug.dprintf12 debug_few
- "[Solver] @[merge dom (%a(%a),%a)@ and (%a(%a),%a)@]@\n"
- Cl.print other_cl Cl.print other_cl0
- (Pp.print_option DomTable.D.print) old_other_s
- Cl.print repr_cl Cl.print repr_cl0
- (Pp.print_option DomTable.D.print) old_repr_s;
- match old_other_s, old_repr_s with
- | None, None -> ()
- | _ ->
- DomTable.D.merge t pexp
- (old_other_s,other_cl0)
- (old_repr_s,repr_cl0)
- inv
-
-
- let merge_dom ?(dry_run=false) t pexp other_cl0 repr_cl0 inv =
- let other_cl = find t other_cl0 in
- let repr_cl = find t repr_cl0 in
- let dom_not_done = ref false in
- let iteri (type a) dom domtable =
- let module DomTable =
- (val domtable : DomTable' with type delayed = delayed_t
- and type D.t = a) in
- let other_s = Cl.M.find_opt other_cl DomTable.table in
- let repr_s = Cl.M.find_opt repr_cl DomTable.table in
- if not (DomTable.D.merged other_s repr_s)
- then begin
- dom_not_done := true;
- if not dry_run then
- Queue.push
- (SetMergeDomCl(pexp,dom,other_cl0,repr_cl0,inv)) t.todo_merge_dom
- end
- in
- VDomTable.iter_initializedi {VDomTable.iteri} t.env.dom;
- !dom_not_done
-
- let finalize_merge t _pexp other_cl0 repr_cl0 inv =
- let other_cl0,repr_cl0 =
- if inv
- then repr_cl0, other_cl0
- else other_cl0, repr_cl0 in
- let other_cl = find t other_cl0 in
- let repr_cl = find t repr_cl0 in
- Debug.dprintf8 debug_few "[Solver.few] merge %a(%a) -> %a(%a)@\n"
- Cl.print other_cl Cl.print other_cl0
- Cl.print repr_cl Cl.print repr_cl0;
- t.env.repr <- Cl.M.add other_cl repr_cl t.env.repr;
- add_merge_dom_all t.env.trail ~inv ~other_cl ~other_cl0 ~repr_cl ~repr_cl0;
- let event, other_event = Cl.M.find_remove other_cl t.env.event in
-
- (** move cl events *)
- begin match other_event with
- | None -> ()
- | Some other_event ->
- t.env.event <-
- Cl.M.add_change (fun x -> x) Bag.concat repr_cl other_event
- event
- end;
-
- (** move dom events *)
- let iter (type a) domtable =
- let module DomTable =
- (val domtable : DomTable' with type delayed = delayed_t
- and type D.t = a) in
- match Cl.M.find_opt other_cl DomTable.events with
- | None -> ()
- | Some other_events ->
- let new_events =
- Cl.M.add_change (fun x -> x) Bag.concat repr_cl other_events
- DomTable.events in
- let module DomTable' = struct
- include DomTable
- let events = new_events
- end in
- VDomTable.set t.env.dom DomTable.D.key (module DomTable')
- in
- VDomTable.iter_initialized {VDomTable.iter} t.env.dom;
-
- (** wakeup the daemons *)
- wakeup_events_bag
- Events.Fired.translate_change t other_event other_cl
-
- let finalize_merge_pending t pexp other_cl0 repr_cl0 inv =
- let dom_not_done = merge_dom t pexp other_cl0 repr_cl0 inv in
- if dom_not_done
- then begin
- Debug.dprintf4 debug "[Solver] @[merge %a %a dom not done@]@\n"
- Cl.print other_cl0 Cl.print repr_cl0;
- t.todo_delayed_merge <- Some (pexp,other_cl0,repr_cl0,inv)
- end
- else
- finalize_merge t pexp other_cl0 repr_cl0 inv
-
- (** merge two pending actions *)
- let merge_pending t pexp cl1_0 cl2_0 =
- let cl1 = find t cl1_0 in
- let cl2 = find t cl2_0 in
- if not (Cl.equal cl1 cl2) then begin
- let ((other_cl0,other_cl),(repr_cl0,repr_cl)) =
- choose_repr (cl1_0,cl1) (cl2_0,cl2) in
- let inv = not (Cl.equal cl1_0 other_cl0) in
- add_pexp_cl t.env.trail pexp
- ~inv ~other_cl ~other_cl0 ~repr_cl ~repr_cl0;
- finalize_merge_pending t pexp cl1_0 cl2_0 inv
- end
-
- let merge t pexp cl1_0 cl2_0 =
- assert (is_current_env t);
- if not (Cl.equal
- (find t cl1_0)
- (find t cl2_0)) then
- add_pending_merge t pexp cl1_0 cl2_0
-
- let set_sem d pexp cl clsem =
- Debug.dprintf4 debug "[Solver] @[add_pending_set_sem for %a and %a@]@\n"
- Cl.print cl ClSem.print clsem;
- assert (d.env.current_delayed == d);
- assert (is_registered d cl);
- set_sem_pending d pexp cl clsem
- let set_dom d pexp dom cl v =
- Debug.dprintf4 debug_few
- "[Solver] @[set_dom for %a with %a@]@\n"
- Cl.print cl (print_dom dom) v;
- assert (d.env.current_delayed == d);
- assert (is_registered d cl);
- set_dom_pending d pexp dom cl (Some v)
- let set_dom_premerge d dom cl v =
- Debug.dprintf4 debug
- "[Solver] @[set_dom_premerge for %a with %a@]@\n"
- Cl.print cl (print_dom dom) v;
- assert (d.env.current_delayed == d);
- assert (is_registered d cl);
- let cl' = match d.todo_delayed_merge with
- | Some(_,cl1,cl2,_) when Cl.equal cl1 cl -> cl2
- | Some(_,cl1,cl2,_) when Cl.equal cl2 cl -> cl1
- | _ -> raise (BrokenInvariant(
- "set_dom_premerge should be unsed on the classe currently merged")) in
- set_dom_premerge_pending d dom ~from:cl' cl v
- let unset_dom d pexp dom cl =
- Debug.dprintf2 debug
- "[Solver] @[unset_dom for %a@]@\n"
- Cl.print cl;
- assert (d.env.current_delayed == d);
- assert (is_registered d cl);
- set_dom_pending d pexp dom cl None
-
-
- let rec do_pending_daemon delayed (DaemonKey (dem,runable)) =
- let module Dem = (val get_dem dem) in
- match Dem.run delayed runable with
- | None -> ()
- | Some runable -> new_pending_daemon delayed dem runable
-
- and nothing_todo t =
- Queue.is_empty t.todo_immediate_dem
- && Queue.is_empty t.todo_merge_dom
- && t.todo_delayed_merge == None
- && Queue.is_empty t.todo_merge
- && Queue.is_empty t.todo_ext_action
-
- and do_pending t =
- draw_graph t.env;
- if not (Queue.is_empty t.todo_immediate_dem) then
- match Queue.pop t.todo_immediate_dem with
- | RunDem att ->
- Debug.dprintf0 debug "[Solver] @[do_pending RunDem immediate@]@\n";
- do_pending_daemon t att;
- do_pending t
- else if not (Queue.is_empty t.todo_merge_dom) then
- match Queue.pop t.todo_merge_dom with
- | SetMergeDomCl(pexp,dom,cl1,cl2,inv) ->
- Debug.dprintf6 debug "[Solver] @[do_pending SetDomCl %a %a %a@]@\n"
- Dom.print dom Cl.print cl1 Cl.print cl2;
- merge_dom_pending t pexp dom cl1 cl2 inv;
- do_pending t
- else match t.todo_delayed_merge with
- | Some(pexp,other_cl,repr_cl,inv) ->
- t.todo_delayed_merge <- None;
- assert (not (merge_dom ~dry_run:true t pexp other_cl repr_cl inv));
- (** understand why that happend.
- Is it really needed to do a fixpoint? *)
- finalize_merge_pending t pexp other_cl repr_cl inv;
- do_pending t
- | None ->
- if not (Queue.is_empty t.todo_merge) then
- match Queue.pop t.todo_merge with
- | Merge (pexp,cl1,cl2) ->
- Debug.dprintf4 debug "[Solver] @[do_pending Merge %a %a@]@\n"
- Cl.print cl1 Cl.print cl2;
- merge_pending t pexp cl1 cl2;
- do_pending t
- else if not (Queue.is_empty t.todo_ext_action) then
- (begin match Queue.pop t.todo_ext_action with
- (* | ExtSetDom (pexp,dom,cl,v) -> *)
- (* Queue.push (SetDom(pexp,dom,cl,v)) t.todo_dom *)
- (* | ExtSetMergeDom (pexp,dom,cl,v) -> *)
- (* Queue.push (SetMergeDomVal(pexp,dom,cl,v)) t.todo_merge_dom *)
- (* | ExtSetSem (pexp,sem,cl,v) -> *)
- (* Queue.push (SetSem(pexp,sem,cl,v)) t.todo_sem *)
- (* | ExtMerge (pexp,cl1,cl2) -> *)
- (* Queue.push (Merge(pexp,cl1,cl2)) t.todo_merge *)
- | ExtDem att ->
- Debug.dprintf0 debug "[Solver] @[do_pending RunDem@]@\n";
- let store_ext_action = Queue.create () in
- Queue.transfer t.todo_ext_action store_ext_action;
- do_pending_daemon t att;
- Queue.transfer store_ext_action t.todo_ext_action;
- end;
- do_pending t)
- else
- Debug.dprintf0 debug "[Solver] Nothing to do@\n"
-
- and flush d =
- assert (d.env.current_delayed == d);
- Debug.dprintf0 debug "[Solver] @[flush delayed@]@\n @[";
- try
- if not (Queue.is_empty d.todo_ext_action) then
- let saved_ext_action = Queue.create () in
- Queue.transfer d.todo_ext_action saved_ext_action;
- do_pending d;
- Queue.transfer saved_ext_action d.todo_ext_action;
- else
- do_pending d;
- assert (nothing_todo d);
- Debug.dprintf0 debug "@][Solver] @[flush delayed end@]@\n"
- with e when Debug.test_flag debug ->
- Debug.dprintf0 debug "@]";
- raise e
-
- let register_decision t chogen =
- t.sched_decision chogen
-
- let mk_pexp t ?age ?tags kexp exp = mk_pexp ?age ?tags t.env.trail kexp exp
- let current_age t = Explanation.current_age t.env.trail
-
- let contradiction d pexp =
- d.env.current_delayed <- unsat_delayed;
- raise (Contradiction pexp)
-
- let get_env : type a. t -> a env -> a
- = fun t k ->
- assert (if VEnv.is_uninitialized defined_env k
- then raise UnregisteredKey else true);
- Env.VectorH.inc_size k t.env.envs;
- if Env.VectorH.is_uninitialized t.env.envs k then
- raise (UninitializedEnv (k :> Env.K.t))
- else
- Env.VectorH.get t.env.envs k
-
- let set_env : type a. t -> a env -> a -> unit
- = fun t k ->
- assert (if VEnv.is_uninitialized defined_env k
- then raise UnregisteredKey else true);
- Env.VectorH.inc_size k t.env.envs;
- Env.VectorH.set t.env.envs k
-
-end
-
-let new_delayed ~sched_daemon ~sched_decision t =
- assert (t.current_delayed == dumb_delayed);
- let d = { env = t;
- todo_immediate_dem = Queue.create ();
- todo_merge_dom = Queue.create ();
- todo_delayed_merge = None;
- todo_merge = Queue.create ();
- todo_ext_action = Queue.create ();
- sched_daemon; sched_decision;
- } in
- t.current_delayed <- d;
- d
-
-let delayed_stop d =
- assert (d.env.current_delayed == d);
- assert (Delayed.nothing_todo d);
- d.env.current_delayed <- dumb_delayed
-
-let flush d =
- assert (d.env.current_delayed == d);
- Delayed.do_pending d;
- assert (Delayed.nothing_todo d)
-
-let run_daemon d dem =
- Queue.push (ExtDem dem) d.todo_ext_action
-
-let is_equal t cl1 cl2 =
- assert (t.current_delayed == dumb_delayed);
- let cl1,cl2 = Shuffle.shuffle2 (cl1,cl2) in
- Debug.dprintf4 debug "[Solver] @[is_equal %a %a@]@\n"
- Cl.print cl1 Cl.print cl2;
- draw_graph t;
- is_equal t cl1 cl2
-
-let find t cl =
- assert (t.current_delayed == dumb_delayed);
- find t cl
-
-let get_dom t dom cl =
- assert (t.current_delayed == dumb_delayed);
- get_dom t dom cl
-
-let get_trail t =
- assert (t.current_delayed == dumb_delayed ||
- t.current_delayed == unsat_delayed);
- t.trail
-
-let current_age t = Explanation.current_age t.trail
-let current_nbdec t = Explanation.nbdec t.trail
-
-let get_direct_dom t dom cl =
- assert (t.current_delayed == dumb_delayed ||
- t.current_delayed == unsat_delayed);
- get_direct_dom t dom cl
-
-module type Ro = sig
- type t
- (** {3 Immediate information} *)
- val register : t -> Cl.t -> unit
- (** Add a new class to register *)
-
- val is_equal : t -> Cl.t -> Cl.t -> bool
- val find_def : t -> Cl.t -> Cl.t
-
- (** {4 The classes must have been marked has registered} *)
- val get_dom : t -> 'a dom -> Cl.t -> 'a option
- (** dom of the representative class *)
-
- val find : t -> Cl.t -> Cl.t
- val is_repr : t -> Cl.t -> bool
-
- val is_registered : t -> Cl.t -> bool
-
- val get_env : t -> 'a env -> 'a
- val set_env: t -> 'a env -> 'a -> unit
-
-
- (** Registered for events *)
- val attached_reg_cl:
- t -> Cl.t -> ('event,'d) dem -> 'event Enum.t
- val attached_cl:
- t -> Cl.t -> ('event,'d) dem -> 'event Enum.t
-
- val is_current_env: t -> bool
-
-end
-
-type d = Delayed.t
-
-module Ro : Ro with type t = Delayed.t = Delayed
-
-let check_initialization () =
- let well_initialized = ref true in
-
- Dom.iter {Dom.iter = fun dom ->
- if VDom.is_uninitialized defined_dom dom then begin
- Format.eprintf
- "[Warning] The domain %a is not registered@." Dom.print dom;
- well_initialized := false;
- end else begin
- Debug.dprintf2 debug "[Solver] @[domain %a initialized@]@\n"
- Dom.print dom;
- end};
-
- Dem.iter {Dem.iter = fun dem ->
- if VDem.is_uninitialized defined_dem dem then begin
- Format.eprintf
- "[Warning] The daemon %a is not registered@." Dem.print dem;
- well_initialized := false;
- end};
-
- !well_initialized
-
-let () = Exn_printer.register (fun fmt exn ->
- match exn with
- | UninitializedEnv env ->
- Format.fprintf fmt "The environnement of %a is not initialized."
- Env.K.print env
- | exn -> raise exn
- )
diff --git a/src/solver.mli b/src/solver.mli
deleted file mode 100644
index 64e9682de..000000000
--- a/src/solver.mli
+++ /dev/null
@@ -1,264 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Explanation
-open Types
-
-exception NotNormalized
-
-type exp_same_sem =
-| ExpSameSem : pexp * Cl.t * ClSem.t -> exp_same_sem
-
-val exp_same_sem : exp_same_sem Explanation.exp
-
-module Events : sig
-
- module Fired : sig
- type 'b event =
- (** the domain dom of the class change *)
- | EventDom : Cl.t * 'a dom * 'b -> 'b event
- (** a new semantical value 'a point to this class (not complete) *)
- | EventSem : Cl.t * 'a sem * 'a * 'b -> 'b event
- (** we want to register a class *)
- | EventReg : Cl.t * 'b -> 'b event
- (** we want to register this class *)
- | EventRegCl: Cl.t * 'b -> 'b event
- (** This class is not the representant of its eq-class anymore *)
- | EventChange : Cl.t * 'b -> 'b event
- (** a new semantical value 'a appear *)
- | EventRegSem : ClSem.t * 'b -> 'b event
-
- val print: 'b event Pp.printer
- val get_data: 'b event -> 'b
-
- type 'b t = 'b event list
-
- end
-
-end
-
-exception UninitializedEnv of Env.K.t
-
-module type Ro = sig
- type t
- (** {3 Immediate information} *)
- val register : t -> Cl.t -> unit
- (** Add a new class to register *)
-
- val is_equal : t -> Cl.t -> Cl.t -> bool
- val find_def : t -> Cl.t -> Cl.t
- val get_dom : t -> 'a dom -> Cl.t -> 'a option
- (** dom of the representative class *)
-
- (** {4 The classes must have been marked has registered} *)
-
- val find : t -> Cl.t -> Cl.t
- val is_repr : t -> Cl.t -> bool
-
- val is_registered : t -> Cl.t -> bool
-
- val get_env : t -> 'a env -> 'a
- val set_env: t -> 'a env -> 'a -> unit
-
- (** Registered for events *)
- val attached_reg_cl:
- t -> Cl.t -> ('event,'d) dem -> 'event Enum.t
- val attached_cl:
- t -> Cl.t -> ('event,'d) dem -> 'event Enum.t
-
- val is_current_env: t -> bool
-
-end
-
-module Ro : Ro
-
-module Delayed : sig
- type t = private Ro.t
- include Ro with type t := t
-
- (** {3 Immediate modifications} *)
- val set_dom : t -> pexp -> 'a dom -> Cl.t -> 'a -> unit
- (** change the dom of the equivalence class *)
-
- val set_sem : t -> Explanation.pexp -> Cl.t -> ClSem.t -> unit
- (** attach a sem to an equivalence class *)
-
- val set_dom_premerge : t -> 'a dom -> Cl.t -> 'a -> unit
- (** [set_dom_premerge d cl] must be used only during the merge of two class
- [cl1] and [cl2], with one of them being [cl].
- The explication is the explication given for the merge
- *)
-
- val unset_dom : t -> pexp -> 'a dom -> Cl.t -> unit
- (** remove the dom of the equivalence class *)
-
- (** {3 Delayed modifications} *)
- val merge : t -> Explanation.pexp -> Cl.t -> Cl.t -> unit
-
- (** {3 Attach Event} *)
- val attach_dom: t -> Cl.t -> 'a dom -> ('event,'r) dem -> 'event -> unit
- (** wakeup when the dom change *)
- val attach_reg_cl: t -> Cl.t -> ('event,'r) dem -> 'event -> unit
- (** wakeup when this dom is registered *)
- val attach_reg_sem: t -> 'a sem -> ('event,'r) dem -> 'event -> unit
- (** wakeup when a new semantical class is registered *)
- val attach_cl: t -> Cl.t -> ('event,'r) dem -> 'event -> unit
- (** wakeup when it is not anymore the representative class *)
-
- (** other event can be added *)
-
- val register_decision: t -> Explanation.chogen -> unit
- (** register a decision that would be scheduled later. The
- [make_decision] of the [Cho] will be called at that time to know
- if the decision is still needed. *)
- val mk_pexp: t -> ?age:age -> ?tags:tags -> 'a exp -> 'a -> Explanation.pexp
- val current_age: t -> age
- val contradiction: t -> Explanation.pexp -> 'b
-
- val flush: t -> unit
-(** Apply all the modifications and direct consequences.
- Should be used only during wakeup of not immediate daemon
-*)
-end
-
-type d = Delayed.t
-
-(** {2 Domains and Semantic Values key creation} *)
-
-module type Dom = sig
- type t
-
- val merged: t option -> t option -> bool
- (** Check if two values of the domain are merged (equal),
- Never called with None, None because always considered merged
- *)
-
- val merge:
- Delayed.t -> pexp ->
- t option * Cl.t (* cl1 *) ->
- t option * Cl.t (* cl2 *) ->
- (** Never with both None *)
- bool (** true: cl1 will be repr otherwise it is cl2 *) ->
- unit
-
- val print: Format.formatter -> t -> unit
- val key: t dom
-
-
-end
-
-module RegisterDom (D:Dom) : sig end
-
-
-val register_env: 'a Pp.printer -> 'a env -> unit
-val print_env: 'a env -> 'a Pp.printer
-
-
-type _ enqueue =
-| EnqRun: 'r -> 'r enqueue
-| EnqAlready: _ enqueue
-| EnqRedirected: ('e,'r) dem * 'e -> _ enqueue
-| EnqStopped: _ enqueue
-
-module type Dem = sig
-
- type runable
- val print_runable: runable Pp.printer
- val run: Delayed.t -> runable -> runable option
- (** can return something to scheduled *)
-
- type event
- val print_event: event Pp.printer
- val enqueue: Ro.t -> event Events.Fired.event -> runable enqueue
-
- val key: (event,runable) dem
- val immediate: bool
-
-end
-
-module RegisterDem (D:Dem) : sig end
-
-(** {2 External use of the solver} *)
-type t
-
-val new_t : unit -> t
-
-type daemon_key =
-| DaemonKey: ('k,'d) dem * 'd -> daemon_key
-
-
-val new_delayed :
- sched_daemon:(daemon_key -> unit) ->
- sched_decision:(chogen -> unit) ->
- t -> Delayed.t
-(** The solver shouldn't be used anymore before
- calling flush. (flushd doesn't count)
-*)
-
-exception Contradiction of Explanation.pexp
-
-val run_daemon: Delayed.t -> daemon_key -> unit
-(** schedule the run of a deamon *)
-
-val delayed_stop: Delayed.t -> unit
-(** Apply all the modifications and direct consequences.
- The argument shouldn't be used anymore *)
-
-val flush: Delayed.t -> unit
-(** Apply all the modifications and direct consequences.
- The argument can be used after that *)
-
-
-(*
-val make_decisions : Delayed.t -> attached_daemons -> unit
-*)
-
-val get_dom : t -> 'a dom -> Cl.t -> 'a option
- (** dom of the representative class *)
-
-val find : t -> Cl.t -> Cl.t
-val is_equal : t -> Cl.t -> Cl.t -> bool
-
-val get_trail : t -> Explanation.t
-val current_age : t -> Explanation.Age.t
-val current_nbdec : t -> int
-
-(** for conflict *)
-val get_direct_dom : t -> 'a dom -> Cl.t -> 'a option
- (** dom of the class directly (the last time modified) *)
-
-(** {2 Implementation Specifics } *)
-(** Because this module is implemented with persistent datastructure *)
-
-val new_handler: t -> t
-(** Modification in one of the environnement doesn't modify the other *)
-
-(** Debug *)
-val draw_graph: ?force:bool -> t -> unit
-val output_graph : string -> t -> unit
-
-val check_initialization: unit -> bool
-(** Check if the initialization of all the dom, sem and dem have been done *)
-
-val print_dom: 'a dom -> 'a Pp.printer
-val print_dom_opt: 'a dom -> 'a option Pp.printer
diff --git a/src/solver/dune b/src/solver/dune
new file mode 100644
index 000000000..ac2167626
--- /dev/null
+++ b/src/solver/dune
@@ -0,0 +1,12 @@
+(library
+ (name witan_solver)
+ (public_name witan.solver)
+ (synopsis "witan's solver")
+ (libraries containers zarith ocamlgraph gen dolmen spelll witan.stdlib
+ witan.popop_lib str witan.core witan.core.structures)
+ (preprocess
+ (pps ppx_deriving.std))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always -open
+ Witan_stdlib -open Witan_core)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/solver/input.ml b/src/solver/input.ml
new file mode 100644
index 000000000..a6bd478b4
--- /dev/null
+++ b/src/solver/input.ml
@@ -0,0 +1,86 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(* The Dolmen library is used to parse input languages *)
+(* ************************************************************************ *)
+
+exception File_not_found of string
+(** Raised when file is not found. *)
+
+(** See documentation at
+ {{:http://gbury.github.io/dolmen/dev/Logic.Make.html} Logic.Make} *)
+module P = Dolmen.Logic.Make
+ (Dolmen.ParseLocation)
+ (Dolmen.Id)
+ (Dolmen.Term)
+ (Dolmen.Statement)
+
+(* Some re-export of definitions *)
+type language = P.language =
+ | Dimacs
+ | ICNF
+ | Smtlib
+ | Tptp
+ | Zf
+
+let enum = P.enum
+
+(** Convenience function to expand includes *)
+let read_aux ~language ~dir input =
+ let acc = ref [input] in
+ let rec aux () =
+ match !acc with
+ | [] -> None
+ | g :: r ->
+ begin match g () with
+ | None -> acc := r; aux ()
+ | Some { Dolmen.Statement.descr = Dolmen.Statement.Include f; _ } ->
+ let file = match P.find ~language ~dir f with
+ | None -> raise (File_not_found f)
+ | Some f -> f
+ in
+ let _, g', _ = P.parse_input ~language (`File file) in
+ acc := g' :: !acc;
+ aux ()
+ | (Some _) as res -> res
+ end
+ in
+ aux
+
+let read ?language ~dir f =
+ (** Formats Dimacs and Tptp are descriptive and lack the emission
+ of formal solve/prove instructions, so we need to add them. *)
+ let s = Dolmen.Statement.include_ f [] in
+ (* Auto-detect input format *)
+ let language =
+ match language with
+ | Some l -> l
+ | None -> let res, _, _ = P.of_filename f in res
+ in
+ let g =
+ match language with
+ | P.Zf
+ | P.ICNF
+ | P.Smtlib -> Gen.singleton s
+ | P.Dimacs
+ | P.Tptp -> Gen.of_list [s; Dolmen.Statement.prove ()]
+ in
+ read_aux ~language ~dir g
+
diff --git a/src/solver/input.mli b/src/solver/input.mli
new file mode 100644
index 000000000..ce5bce6a8
--- /dev/null
+++ b/src/solver/input.mli
@@ -0,0 +1,38 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Problem input for Witan *)
+
+(** {2 Parsing some input} *)
+
+type language =
+ | Dimacs (** The dimacs language *)
+ | ICNF (** iCNF is ane xtension of dimacs *)
+ | Smtlib (** smtlib language *)
+ | Tptp (** TPTP problems language *)
+ | Zf (** Zipperposition format *)
+(** The type of input language supported. *)
+
+val enum : (string * language) list
+(** Enumeration of pairs of a language and its name, mainly for use by cmdliner. *)
+
+val read : ?language:language -> dir:string -> string -> Dolmen.Statement.t Gen.t
+(** Read a file in a directory. Automatically expands all include statements.
+ @language: if set, overrides input language auto-detection performed by dolmen. *)
diff --git a/src/solver/notypecheck.ml b/src/solver/notypecheck.ml
new file mode 100644
index 000000000..1a4c2ee6f
--- /dev/null
+++ b/src/solver/notypecheck.ml
@@ -0,0 +1,361 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+
+(* Exception for typing errors *)
+module R = Exthtbl.Hashtbl.Make(Dolmen.Id)
+module MId = CCMap.Make(struct include Dolmen.Id let pp = print end)
+type env = Term.Id.t R.t
+
+let create_env () =
+ R.create 10
+
+exception Typing_error of string * Dolmen.Term.t
+
+let _bad_op_arity _ s n t =
+ let msg = Format.asprintf "Bad arity for operator '%s' (expected %d arguments)" s n in
+ raise (Typing_error (msg, t))
+
+let regexp_decimal = Str.regexp "^[0-9]+\\(\\.[0-9]*\\)?$"
+
+(** no typing *)
+let rec parse_formula' (env:env) (lets:Term.t MId.t) (t:Dolmen.Term.t) =
+ let module Ast = Dolmen.Term in
+ let open Term in
+ match t with
+
+ (* Ttype & builtin types *)
+ | { Ast.term = Ast.Builtin Ast.Ttype } ->
+ _Type
+ | { Ast.term = Ast.Builtin Ast.Prop } ->
+ _Prop
+
+ | { Ast.term = Ast.Symbol {Dolmen.Id.name = "Real"} } ->
+ _Real
+
+ (* Basic formulas *)
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Builtin Ast.True }, []) }
+ | { Ast.term = Ast.Builtin Ast.True } ->
+ true_term
+
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Builtin Ast.False }, []) }
+ | { Ast.term = Ast.Builtin Ast.False } ->
+ false_term
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.And}, l) } ->
+ let f = (and_term (List.length l)) in
+ let l = (List.map (parse_formula env lets) l) in
+ apply f l
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Or}, l) } ->
+ apply (or_term (List.length l)) (List.map (parse_formula env lets) l)
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Xor}, l) } as t ->
+ begin match l with
+ | [p; q] ->
+ let f = parse_formula env lets p in
+ let g = parse_formula env lets q in
+ apply not_term [apply equal_term [f.Term.ty;f;g]]
+ | _ -> _bad_op_arity env "xor" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Imply}, l) } as t ->
+ begin match l with
+ | [p; q] ->
+ let f = parse_formula env lets p in
+ let g = parse_formula env lets q in
+ apply imply_term [f;g]
+ | _ -> _bad_op_arity env "=>" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Equiv}, l) } as t ->
+ begin match l with
+ | [p; q] ->
+ let f = parse_formula env lets p in
+ let g = parse_formula env lets q in
+ apply equiv_term [f;g]
+ | _ -> _bad_op_arity env "<=>" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Not}, l) } as t ->
+ begin match l with
+ | [p] ->
+ apply not_term [parse_formula env lets p]
+ | _ -> _bad_op_arity env "not" 1 t
+ end
+
+ (* (\* Binders *\)
+ * | { Ast.term = Ast.Binder (Ast.All, vars, f) } ->
+ * let ttype_vars, ty_vars, env' =
+ * parse_quant_vars (expect env (Typed Expr.Ty.base)) vars in
+ * Formula (
+ * mk_quant_ty env' Expr.Formula.allty ttype_vars
+ * (mk_quant_term env' Expr.Formula.all ty_vars
+ * (parse_formula env' f)))
+ *
+ * | { Ast.term = Ast.Binder (Ast.Ex, vars, f) } ->
+ * let ttype_vars, ty_vars, env' =
+ * parse_quant_vars (expect env (Typed Expr.Ty.base)) vars in
+ * Formula (
+ * mk_quant_ty env' Expr.Formula.exty ttype_vars
+ * (mk_quant_term env' Expr.Formula.ex ty_vars
+ * (parse_formula env' f))) *)
+
+ (* (Dis)Equality *)
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Eq}, l) } as t ->
+ begin match l with
+ | [a; b] ->
+ let a = parse_formula env lets a in
+ let b = parse_formula env lets b in
+ apply equal_term [a.Term.ty;a;b]
+ (* begin match promote env t @@ parse_expr env a,
+ * promote env t @@ parse_expr env b with
+ * | Term t1, Term t2 ->
+ * Formula (make_eq env t t1 t2)
+ * | Formula f1, Formula f2 ->
+ * Formula (Expr.Formula.equiv f1 f2)
+ * | _ ->
+ * _expected env "either two terms or two formulas" t None
+ * end *)
+ | _ -> _bad_op_arity env "=" 2 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Distinct}, a::args) } ->
+ let a = parse_formula env lets a in
+ apply (distinct_term (List.length args + 1)) (a.Term.ty::a::(List.map (parse_formula env lets) args))
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Ite}, l) }
+ | { Ast.term = Ast.App ({Ast.term = Ast.Symbol {Dolmen.Id.name = "ite"}}, l) } ->
+ begin match l with
+ | [cond;then_; else_] ->
+ let cond = parse_formula env lets cond in
+ let then_ = parse_formula env lets then_ in
+ let else_ = parse_formula env lets else_ in
+ apply ite_term [then_.Term.ty;cond;then_;else_]
+ | _ -> _bad_op_arity env "ite" 3 t
+ end
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Add}, l) }
+ | { Ast.term = Ast.App ({Ast.term = Ast.Symbol {Dolmen.Id.name = "+"}}, l) } ->
+ let f = (add_real_term (List.length l)) in
+ let l = (List.map (parse_formula env lets) l) in
+ apply f l
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Sub}, ([_;_] as l)) }
+ | { Ast.term = Ast.App ({Ast.term = Ast.Symbol {Dolmen.Id.name = "-"}}, ([_;_] as l)) } ->
+ let f = sub_real_term in
+ let l = (List.map (parse_formula env lets) l) in
+ apply f l
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Sub}, ([_] as l)) }
+ | { Ast.term = Ast.App ({Ast.term = Ast.Symbol {Dolmen.Id.name = "-"}}, ([_] as l)) } ->
+ let f = neg_real_term in
+ let l = (List.map (parse_formula env lets) l) in
+ apply f l
+
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Mult}, ([_;_] as l)) }
+ | { Ast.term = Ast.App ({Ast.term = Ast.Symbol {Dolmen.Id.name = "*"}}, ([_;_] as l)) } ->
+ let f = mul_real_term in
+ let l = (List.map (parse_formula env lets) l) in
+ apply f l
+
+ | {Ast.term = Ast.Symbol {Dolmen.Id.name = cst}}
+ | { Ast.term = Ast.App ({Ast.term = Ast.Symbol {Dolmen.Id.name = cst}}, []) } when Str.string_match regexp_decimal cst 0 ->
+ const_real_term cst
+
+ (* General case: application *)
+ | { Ast.term = Ast.Symbol s } as ast ->
+ begin match MId.find_opt s lets with
+ | Some t -> t
+ | None ->
+ begin match R.find_opt env s with
+ | Some id -> (const id)
+ | None -> raise (Typing_error("unbound variable",ast))
+ end
+ end
+
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Symbol s }, l) } as ast ->
+ begin match MId.find_opt s lets with
+ | Some t -> apply t (List.map (parse_formula env lets) l)
+ | None ->
+ begin match R.find_opt env s with
+ | Some id -> apply (const id) (List.map (parse_formula env lets) l)
+ | None -> raise (Typing_error("unbound variable",ast))
+ end
+ end
+
+ | { term = Ast.Binder (_,[],t); _; } ->
+ parse_formula env lets t
+
+ (* Local bindings *)
+ | { Ast.term = Ast.Binder (Ast.Let, vars, f) } ->
+ let rec aux lets = function
+ | [] -> parse_formula env lets f
+ | {Ast.term = Ast.Colon({Ast.term = Ast.Symbol s},t)}::l ->
+ let t = parse_formula env lets t in
+ if false then
+ let s' = Format.asprintf "%a" Dolmen.Id.print s in
+ let id = Witan_core.Id.mk s' t.Term.ty in
+ R.add env s id;
+ let l = aux lets l in
+ R.remove env s;
+ Term.letin id t l
+ else
+ let lets = MId.add s t lets in
+ aux lets l
+ | t::_ ->
+ raise (Typing_error ("Unexpected let binding", t))
+ in
+ aux lets vars
+
+ (* Functionnal arrows *)
+ | { Ast.term = Ast.Binder (Ast.Arrow, vars, f) } ->
+ Term.arrows (List.map (parse_formula env lets) vars) (parse_formula env lets f)
+
+ (* Other cases *)
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin _}, _) } ->
+ raise (Typing_error ("Unexpected builtin", t))
+ | { term = Ast.Builtin _; _; } ->
+ raise (Typing_error ("Unexpected builtin", t))
+ | { term = Ast.Colon (_,_); _; } ->
+ raise (Typing_error ("Unexpected colon", t))
+ | { term = Ast.App (_,_); _; }->
+ raise (Typing_error ("Unexpected app", t))
+ | { term = Ast.Binder (_,_,_); _; } ->
+ raise (Typing_error ("Unexpected binder", t))
+ | { term = Ast.Match (_,_); _; } ->
+ raise (Typing_error ("Unexpected construction", t))
+
+and parse_formula (env:env) lets (t:Dolmen.Term.t) =
+ try
+ parse_formula' env lets t
+ with
+ | (Typing_error _) as exn -> raise exn
+ | exn ->
+ raise (Typing_error (Printexc.to_string exn, t))
+
+let rec parse_clause_lit (env:env) t =
+ let module Ast = Dolmen.Term in
+ let open Term in
+ match t with
+ | { Ast.term = Ast.Symbol s }
+ | { Ast.term = Ast.App ({ Ast.term = Ast.Symbol s }, []) } ->
+ let id = R.memo (fun id ->
+ let s = Format.asprintf "%a" Dolmen.Id.print id in
+ (** only in dimacs they are not declared *)
+ Witan_core.Id.mk s _Prop) env s in
+ const id
+ | { Ast.term = Ast.App ({Ast.term = Ast.Builtin Ast.Not}, l) } as t ->
+ begin match l with
+ | [p] ->
+ apply not_term [parse_clause_lit env p]
+ | _ -> _bad_op_arity env "not" 1 t
+ end
+ | _ ->
+ raise (Typing_error ("Unexpected construction in dimacs", t))
+
+
+let get_loc =
+ let default_loc = Dolmen.ParseLocation.mk "<?>" 0 0 0 0 in
+ (fun t -> CCOpt.get_or ~default:default_loc t.Dolmen.Term.loc)
+
+(** used to complete partial model *)
+let get_model env d =
+ let model : Value.t Term.H.t = Term.H.create 16 in
+ R.iter (fun _ id ->
+ let t = Term.const id in
+ let n = SynTerm.node_of_term t in
+ let v = Interp.model d n in
+ Term.H.add_new Std.Impossible model t v)
+ env;
+ model
+
+let interp_model model n =
+ let leaf t = Term.H.find_opt model t in
+ (Interp.node ~leaf n)
+
+let check_model model expected n =
+ Value.equal (interp_model model n) expected
+
+let run ?limit ~theories statements =
+ let env = create_env () in
+ let clauses = ref [] in
+ let open Witan_core in
+ let res =
+ Scheduler.run
+ ~theories
+ ?limit
+ (fun d ->
+ Gen.iter (fun stmt ->
+ let open Dolmen.Statement in
+ match stmt.descr with
+ | Set_logic _ -> ()
+ | Set_info _ -> ()
+ | Prove -> ()
+ | Dolmen.Statement.Exit -> ()
+ | Decl (id,t) ->
+ let t = Dolmen.Normalize.smtlib t in
+ let ty = parse_formula env MId.empty t in
+ let t' =
+ let s = Format.asprintf "%a" Dolmen.Id.print id in
+ Witan_core.Id.mk s ty
+ in
+ R.add_new Witan_stdlib.Std.Impossible env id t';
+ | Clause l ->
+ let map t = SynTerm.node_of_term (parse_clause_lit env t), Witan_core.Conflict.Pos in
+ let l = Witan_stdlib.Shuffle.shufflel l in
+ let l = List.map map l in
+ let l = Witan_stdlib.Shuffle.shufflel l in
+ let cl = !Witan_core.Conflict._or l in
+ clauses := cl::!clauses;
+ Egraph.register d cl;
+ !Witan_core.Conflict._set_true d Trail.pexp_fact cl
+ | Antecedent t ->
+ let map t = SynTerm.node_of_term (parse_formula env MId.empty t) in
+ let t = Dolmen.Normalize.smtlib t in
+ let cl = map t in
+ clauses := cl::!clauses;
+ Egraph.register d cl;
+ !Witan_core.Conflict._set_true d Trail.pexp_fact cl
+ | _ -> invalid_arg (Format.asprintf "Unimplemented command: %a" Dolmen.Statement.print stmt))
+ statements) in
+ match res with
+ | `Contradiction -> `Unsat
+ | `Done _d ->
+ (* let model = get_model env d in
+ * Format.printf "(%a)@."
+ * Witan_popop_lib.Pp.(iter22 Witan_core.Term.H.iter space
+ * (fun fmt t v -> Format.fprintf fmt "(%a %a)"
+ * Witan_core.Term.pp t Witan_core.Values.pp v))
+ * model *)
+ `Sat
+
+
+
+let () = Exn_printer.register (fun fmt exn ->
+ match exn with
+ | Typing_error (msg, t) ->
+ Format.fprintf fmt
+ "%a:@\n%s:@ %a"
+ Dolmen.ParseLocation.fmt (get_loc t) msg
+ Dolmen.Term.print t;
+ | exn -> raise exn
+ )
diff --git a/src/solver/notypecheck.mli b/src/solver/notypecheck.mli
new file mode 100644
index 000000000..627657741
--- /dev/null
+++ b/src/solver/notypecheck.mli
@@ -0,0 +1,29 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+exception Typing_error of string * Dolmen.Term.t
+
+val get_loc: Dolmen.Term.t -> Dolmen.ParseLocation.t
+
+val run:
+ ?limit:int ->
+ theories:(Egraph.t -> unit) list ->
+ (unit -> Dolmen.Statement.t option) ->
+ [> `Sat | `Unsat ]
diff --git a/src/solver/scheduler.ml b/src/solver/scheduler.ml
new file mode 100644
index 000000000..f0e90ab70
--- /dev/null
+++ b/src/solver/scheduler.ml
@@ -0,0 +1,418 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Witan_core
+
+module S = Egraph
+
+let debug = Debug.register_info_flag
+ ~desc:"for the scheduler in the simple version"
+ "sched_queue"
+
+let debug_pushpop = Debug.register_info_flag
+ ~desc:"for the scheduler push/pop"
+ "sched_pushpop"
+
+let debug_dotgui = Debug.register_flag
+ ~desc:"print graph at interesting time (push/pop)"
+ "sched_dotgui"
+
+
+let var_decay = 1. /. 0.95
+
+let stats_propa = Debug.register_stats_int ~name:"Scheduler.daemon" ~init:0
+let stats_dec = Debug.register_stats_int ~name:"Scheduler.decision" ~init:0
+let stats_con = Debug.register_stats_int ~name:"Scheduler.conflict" ~init:0
+
+exception NeedStopDelayed
+
+module Att = struct
+ type t =
+ | Daemon of int * Events.Wait.daemon_key
+ | Decision of int * Trail.chogen
+ type prio = float
+ type db = float Node.H.t
+
+ let get_prio db n =
+ Node.H.find_def db 0. n
+
+ let le (x:t) (xp:float) (y:t) (yp:float) =
+ match x, y with
+ | Daemon (x,_) , Daemon (y,_) -> x <= y
+ | Decision (x,_), Decision (y,_) ->
+ if xp = yp then x <= y else xp >= yp (** min *)
+ | Daemon _ , Decision _ -> true
+ | Decision _, Daemon _ -> false
+ let reprio db = function
+ | Daemon _ -> 0.
+ | Decision (_,Trail.GCho(n,_,_)) -> get_prio db n
+end
+exception Contradiction
+
+module Prio = Leftistheap.Make(Att)
+
+type pre =
+ { pre_wakeup_daemons : Prio.t;
+ pre_prev_scheduler_state : pre option;
+ pre_backtrack_point : Context.bp;
+ pre_age_dec : Trail.Age.t;
+ pre_learnt : Conflict.Learnt.t Bag.t;
+ pre_last_dec : Trail.chogen;
+ }
+
+type t =
+ { mutable wakeup_daemons : Prio.t;
+ mutable prev_scheduler_state : pre option;
+ solver_state : S.Backtrackable.t;
+ mutable delayed : S.t option;
+ mutable learnt : Conflict.Learnt.t Bag.t;
+ (* global *)
+ decprio : Att.db;
+ var_inc : float ref;
+ context : Context.context;
+ }
+(** To treat in the reverse order *)
+
+let get_t t = t.solver_state
+
+let print_level fmt t =
+ let nb_dec =
+ Prio.fold (fun acc x _ -> match x with Att.Decision _ -> acc + 1 | _ -> acc)
+ 0 t.wakeup_daemons in
+ Format.fprintf fmt "%a (level:%i, dec waiting:%i)"
+ Trail.Age.pp (S.Backtrackable.current_age t.solver_state)
+ (S.Backtrackable.current_nbdec t.solver_state) nb_dec
+
+(* let new_handler t =
+ * if t.delayed <> None then raise NeedStopDelayed;
+ * {wakeup_daemons = t.wakeup_daemons;
+ * prev_scheduler_state = t.prev_scheduler_state;
+ * solver_state = S.Backtrackable.new_handle t.solver_state;
+ * learnt = t.learnt;
+ * delayed = None;
+ * decprio = t.decprio;
+ * var_inc = t.var_inc
+ * } *)
+
+let new_solver () =
+ let context = Context.create () in
+ { wakeup_daemons = Prio.empty;
+ prev_scheduler_state = None;
+ solver_state = S.Backtrackable.new_t (Context.creator context);
+ context;
+ learnt = Bag.empty;
+ delayed = None;
+ decprio = Node.H.create 100;
+ var_inc = ref 1.;
+ }
+
+let push t chogen =
+ if Debug.test_flag debug_dotgui then
+ S.Backtrackable.draw_graph ~force:true t.solver_state;
+ Debug.dprintf0 debug_pushpop "[Scheduler] push";
+ let age_dec = Trail.last_dec (S.Backtrackable.get_trail t.solver_state) in
+ let prev =
+ { pre_wakeup_daemons = t.wakeup_daemons;
+ pre_prev_scheduler_state = t.prev_scheduler_state;
+ pre_backtrack_point = Context.bp t.context;
+ pre_learnt = t.learnt;
+ pre_last_dec = chogen;
+ pre_age_dec = age_dec;
+ } in
+ t.prev_scheduler_state <- Some prev;
+ t.learnt <- Bag.empty;
+ ignore (Context.push t.context)
+
+let update_prio t chogen =
+ Node.H.change (function
+ | None -> Some (!(t.var_inc))
+ | Some i -> Some (i +. (!(t.var_inc)))) t.decprio chogen
+
+let new_delayed =
+ let daemon_count = ref (-1) in
+ let dec_count = ref (-1) in
+ fun t ->
+ let sched_daemon att =
+ incr daemon_count;
+ Debug.dprintf1 debug "[Scheduler] New possible daemon:%i"
+ !daemon_count;
+ t.wakeup_daemons <-
+ Prio.insert t.decprio (Att.Daemon (!daemon_count,att))
+ t.wakeup_daemons in
+ let sched_decision dec =
+ incr dec_count;
+ Debug.dprintf1 debug "[Scheduler] New possible decisions prio:%i"
+ !dec_count;
+ t.wakeup_daemons <- Prio.insert t.decprio (Att.Decision (!dec_count,dec))
+ t.wakeup_daemons in
+ S.Backtrackable.new_delayed ~sched_daemon ~sched_decision t.solver_state
+
+(*
+ let rec apply_learnt llearnt t d =
+ match llearnt with
+ | [] -> d
+ | a::l ->
+ (** the first one should be the last conflict found so decide on it *)
+ try
+ let {Conflict.fin_dec = Trail.GCho(cho,k)} = a d in
+ S.flush d;
+ List.iter (fun f -> ignore (f d); S.flush d) l;
+ run_until_dec t d;
+ run_dec t d t.wakeup_daemons
+ (fun d dec -> Conflict.make_decision d dec cho k)
+ with S.Contradiction pexp ->
+ Debug.dprintf0 debug "[Scheduler] Contradiction during apply learnt";
+ conflict_analysis t pexp
+*)
+
+let rec apply_learnt learntdec llearnt t d =
+ try
+ Debug.dprintf0 debug "[Scheduler] Apply previously learnt";
+ let iter_learnt n =
+ Debug.dprintf2 debug "[Scheduler] @[Apply %a@]"
+ Conflict.Learnt.pp n;
+ Conflict.apply_learnt d n;
+ S.Backtrackable.flush d in
+ Bag.iter iter_learnt llearnt;
+ if Conflict.learnt_is_already_true d learntdec
+ then assert false; (** absurd: If it is already true it should not be this conflict *)
+ iter_learnt learntdec;
+ run_until_dec t d;
+ Debug.dprintf0 debug_pushpop "[Scheduler] Learnt applied";
+ (** TODO: decision on the last decision if it is multiple theory *)
+ d
+ with S.Contradiction pexp ->
+ Debug.dprintf0 debug "[Scheduler] Contradiction during apply learnt";
+ conflict_analysis t pexp
+
+and pop_to t prev =
+ Debug.dprintf2 debug_pushpop "[Scheduler] pop from %a"
+ print_level t;
+ t.wakeup_daemons <- prev.pre_wakeup_daemons;
+ t.prev_scheduler_state <- prev.pre_prev_scheduler_state;
+ Context.pop prev.pre_backtrack_point;
+ t.learnt <- prev.pre_learnt;
+ let d = new_delayed t in
+ Egraph.Backtrackable.draw_graph t.solver_state;
+ Debug.dprintf2 debug_pushpop "[Scheduler] pop to %a"
+ print_level t;
+ d
+
+(*
+ and conflict_analysis t pexp =
+ Debug.incr stats_con;
+ let learnt,_tags, _decs = Conflict.analyse t.solver_state pexp in
+ let learnt,maxage = match learnt with
+ | None -> raise Contradiction
+ | Some learntmaxage -> learntmaxage in
+ let rec rewind llearnt maxage prevo =
+ match prevo with
+ | None -> raise Contradiction
+ | Some prev when
+ Trail.current_age
+ (S.get_trail prev.pre_solver_state) <= maxage ->
+ llearnt,prev
+ | Some prev ->
+ let llearnt = List.rev_append llearnt prev.pre_learnt in
+ rewind llearnt maxage prev.pre_prev_scheduler_state
+ in
+ let llearnt,prev =
+ rewind (learnt::t.learnt) maxage t.prev_scheduler_state in
+ Debug.dprintf2 debug_pushpop "[Scheduler] Pop to level %a"
+ Trail.Age.pp maxage;
+ pop_to llearnt t prev
+*)
+
+and conflict_analysis t pexp =
+ if Debug.test_flag debug_dotgui then
+ S.Backtrackable.draw_graph ~force:true t.solver_state;
+ Debug.incr stats_con;
+ if Egraph.Backtrackable.current_nbdec t.solver_state = 0 then begin
+ Debug.dprintf0 debug "[Scheduler] contradiction at level 0";
+ raise Contradiction
+ end
+ else
+ let backlevel, learnt, useful =
+ Conflict.learn
+ (Egraph.Backtrackable.get_getter t.solver_state)
+ (Egraph.Backtrackable.get_trail t.solver_state)
+ pexp
+ in
+ t.var_inc := !(t.var_inc) *. var_decay;
+ Bag.iter (update_prio t) useful;
+ (** We look for the level just below the backtrack level *)
+ let rec rewind t learnt llearnt prevo =
+ match prevo with
+ | None ->
+ Debug.dprintf0 debug "[Scheduler] learnt clause false at level 0";
+ raise Contradiction
+ | Some prev ->
+ let llearnt_all = Bag.concat llearnt prev.pre_learnt in
+ let age_dec = prev.pre_age_dec in
+ if Trail.Age.(backlevel < age_dec) then
+ rewind t learnt llearnt_all prev.pre_prev_scheduler_state
+ else
+ let d = pop_to t prev in
+ t.learnt <- Bag.append llearnt_all learnt;
+ d,learnt,llearnt
+ in
+ let d,learntdec,llearnt =
+ rewind t learnt t.learnt t.prev_scheduler_state in
+ t.wakeup_daemons <- Prio.reprio t.decprio t.wakeup_daemons;
+ apply_learnt learntdec llearnt t d
+
+and try_run_dec:
+ t -> S.t -> Prio.t -> Trail.chogen -> S.t = fun t d prio chogen ->
+ (** First we verify its the decision is at this point needed *)
+ try
+ match Conflict.choose_decision d chogen with
+ | Conflict.DecNo ->
+ t.wakeup_daemons <- prio;
+ d (** d can be precised by choose_decision *)
+ | Conflict.DecTodo todo ->
+ Debug.incr stats_dec;
+ S.Backtrackable.delayed_stop d;
+ (** The registered state keep the old prio *)
+ push t chogen;
+ (** We use the priority list without the decision only in the
+ branch where the decision is made *)
+ t.wakeup_daemons <- prio;
+ let declevel = S.Backtrackable.new_dec t.solver_state in
+ Debug.dprintf4 debug_pushpop
+ "[Scheduler] Make decision: decision %a level %a"
+ Trail.print_dec declevel
+ print_level t;
+ assert (Egraph.Backtrackable.current_nbdec t.solver_state > 0);
+ let d = new_delayed t in
+ todo d;
+ d
+ with S.Contradiction pexp ->
+ Debug.dprintf0 debug "[Scheduler] Contradiction";
+ conflict_analysis t pexp
+
+and run_until_dec t d =
+ let act = Prio.min t.wakeup_daemons in
+ match act with
+ | Some (Att.Daemon (_,att)) -> begin
+ let _, prio = Prio.extract_min t.wakeup_daemons in
+ Debug.incr stats_propa;
+ t.wakeup_daemons <- prio;
+ S.Backtrackable.run_daemon d att;
+ S.Backtrackable.flush d;
+ run_until_dec t d
+ end
+ | Some (Att.Decision (_,_)) | None -> ()
+
+
+let run_one_step t d =
+ let act, prio = Prio.extract_min t.wakeup_daemons in
+ match act with
+ | Att.Daemon (_,att) -> begin
+ Debug.incr stats_propa;
+ t.wakeup_daemons <- prio;
+ try
+ S.Backtrackable.run_daemon d att; d
+ with S.Contradiction pexp ->
+ Debug.dprintf0 debug "[Scheduler] Contradiction";
+ conflict_analysis t pexp
+ end
+ | Att.Decision (_,chogen) -> try_run_dec t d prio chogen
+
+let rec flush t d =
+ try
+ S.Backtrackable.flush d; d
+ with S.Contradiction pexp ->
+ Debug.dprintf0 debug "[Scheduler] Contradiction";
+ let d = conflict_analysis t pexp in
+ flush t d
+
+exception ReachStepLimit
+
+let rec run_inf_step ?limit ~nodec t d =
+ (match limit with | Some n when n <= 0 -> raise ReachStepLimit | _ -> ());
+ let d = flush t d in
+ let run =
+ match Prio.min t.wakeup_daemons with
+ | Some (Att.Decision _) -> not nodec
+ | Some (Att.Daemon _) -> true
+ | None -> false
+ in
+ if run
+ then
+ let d = run_one_step t d in
+ run_inf_step ?limit:(Opt.map pred limit) ~nodec t d
+ else begin
+ S.Backtrackable.delayed_stop d
+ end
+
+let run_inf_step ?limit ?(nodec=false) t =
+ if t.delayed <> None then raise NeedStopDelayed;
+ let d = new_delayed t in
+ try
+ run_inf_step ?limit ~nodec t d;
+ Debug.dprintf0 debug_pushpop "[Scheduler] sat";
+ with (Contradiction as e) ->
+ Debug.dprintf0 debug_pushpop "[Scheduler] unsat";
+ raise e
+
+let get_delayed t =
+ match t.delayed with
+ | Some d -> d
+ | None ->
+ let d = new_delayed t in
+ t.delayed <- Some d;
+ d
+
+let flush_delayed t =
+ match t.delayed with
+ | None -> ()
+ | Some d ->
+ t.delayed <- Some (flush t d)
+
+let stop_delayed t =
+ match t.delayed with
+ | None -> ()
+ | Some d ->
+ let d = flush t d in
+ S.Backtrackable.delayed_stop d;
+ t.delayed <- None
+
+let run_exn ?nodec ?limit ~theories f =
+ let t = new_solver () in
+ begin try
+ let d = get_delayed t in
+ List.iter (fun f -> f d) (SynTerm.init::theories);
+ Egraph.Backtrackable.flush d;
+ f d
+ with S.Contradiction _ ->
+ Debug.dprintf0 debug
+ "[Scheduler] Contradiction during initial assertion";
+ raise Contradiction
+ end;
+ stop_delayed t;
+ run_inf_step ~nodec:(nodec=Some ()) ?limit t;
+ get_delayed t
+
+let run ?nodec ?limit ~theories f =
+ try
+ `Done (run_exn ?nodec ?limit ~theories f)
+ with Contradiction ->
+ `Contradiction
diff --git a/src/solver/scheduler.mli b/src/solver/scheduler.mli
new file mode 100644
index 000000000..c88706891
--- /dev/null
+++ b/src/solver/scheduler.mli
@@ -0,0 +1,36 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+
+val run_exn:
+ ?nodec:unit ->
+ ?limit:int ->
+ theories:(Egraph.t -> unit) list ->
+ (Egraph.t -> unit) ->
+ Egraph.t
+
+val run:
+ ?nodec:unit ->
+ ?limit:int ->
+ theories:(Egraph.t -> unit) list ->
+ (Egraph.t -> unit) ->
+ [> `Contradiction
+ | `Done of Egraph.t
+ ]
diff --git a/src/solver/solver.ml b/src/solver/solver.ml
new file mode 100644
index 000000000..9cc3b0647
--- /dev/null
+++ b/src/solver/solver.ml
@@ -0,0 +1,22 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+module Scheduler = Scheduler
+module Input = Input
diff --git a/src/stdlib/comp_keys.ml b/src/stdlib/comp_keys.ml
new file mode 100644
index 000000000..4d91321fe
--- /dev/null
+++ b/src/stdlib/comp_keys.ml
@@ -0,0 +1,399 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Popop_stdlib
+open Std
+
+module type NamedType = sig
+ type t
+ val name : string
+end
+
+module type NamedType2 = sig
+ type t
+ type d
+ val name : string
+end
+
+exception BadCoercion
+
+module type Registry = sig
+ type 'a key
+ type 'a data
+
+ val register: 'a data -> unit
+ val check_is_registered : 'a key -> unit
+ val is_well_initialized : unit -> bool
+ val get : 'a key -> 'a data
+ val print : 'a key -> 'a Pp.pp
+
+ exception UnregisteredKey : 'a key -> exn
+ exception AlreadyRegisteredKey : 'a key -> exn
+
+end
+
+module type Key = sig
+ (** Key with arity 1 *)
+
+ module K: Datatype
+ type 'a t (* = private K.t *)
+
+ val pp: 'a t Pp.pp
+ val compare: 'a t -> 'b t -> int
+ val equal: 'a t -> 'b t -> bool
+ val hash : 'a t -> int
+ val tag: 'a t -> int
+ val key: 'a t -> K.t
+
+ type iter = {iter : 'a. 'a t -> unit}
+ val iter : iter -> unit
+ type 'b fold = {fold : 'a. 'a t -> 'b -> 'b}
+ val fold : 'b fold -> 'b -> 'b
+ val hint_size : unit -> int
+
+ module Eq: sig
+ val eq_type : 'a t -> 'b t -> ('a,'b) Poly.iseq
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned *)
+
+ val coerce_type : 'a t -> 'b t -> ('a,'b) Poly.eq
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned otherwise
+ the exception BadCoercion is raised *)
+
+ val coerce : 'a t -> 'b t -> 'a -> 'b
+ (** If the two arguments are physically identical then covnert the
+ argument otherwise taise BadCoercion *)
+
+ end
+ val create_key: (module NamedType with type t = 'a) -> 'a t
+
+ module MkVector(D:sig type ('a,'b) t end)
+ : Vector_hetero.S1 with
+ type 'a key = 'a t and type ('a,'b) data = ('a,'b) D.t
+
+ module MkMap(D:sig type ('a,'b) t end)
+ : Intmap_hetero.S1 with
+ type 'a key = 'a t and type ('a,'b) data = ('a,'b) D.t
+
+ module Vector : Vector_hetero.R1 with type 'a key = 'a t
+ module VectorH : Hashtbl_hetero.T1 with type 'a key = 'a t
+ module M : Intmap_hetero.R1 with type 'a key = 'a t
+ module Make_Registry(S:sig
+ type 'a data
+ val pp: 'a data -> 'a Pp.pp
+ val key: 'a data -> 'a t
+ end) : Registry with type 'a key := 'a t and type 'a data = 'a S.data
+end
+
+
+module Make_key(X:sig end): Key = struct
+ module K = Strings.Fresh(struct end)
+
+ type 'a t = K.t (* >= 0 *)
+ let pp fmt x = K.pp fmt x
+ let compare x y = K.compare x y
+ let equal x y = K.equal x y
+ let hash x = K.hash x
+ let tag (x:K.t) = (x:>int)
+ let key x = x
+
+ type iter = {iter : 'a. 'a t -> unit}
+ let iter f = K.iter f.iter
+ type 'b fold = {fold : 'a. 'a t -> 'b -> 'b}
+ let fold f acc = K.fold f.fold acc
+ let hint_size = K.hint_size
+
+ let create_key (type a) (module NT : NamedType with type t = a) : a t =
+ K.create NT.name
+
+ (** the 'a k can be used as equality witness because K gives fresh values *)
+ module Eq = struct
+ let eq_type :
+ type a b. a t -> b t -> (a,b) Poly.iseq =
+ fun a b ->
+ if equal a b
+ then ((Obj.magic (Poly.Eq : (a,a) Poly.eq)) : (a,b) Poly.iseq)
+ else Poly.Neq
+
+ let coerce_type :
+ type a b. a t -> b t -> (a,b) Poly.eq =
+ fun a b ->
+ if equal a b
+ then ((Obj.magic (Eq : (a,a) Poly.eq)) : (a,b) Poly.eq)
+ else raise BadCoercion
+
+ let coerce (type a) (type b) (a:a t) (b:b t) (x:a) : b =
+ match coerce_type a b with
+ | (Poly.Eq:(a,b) Poly.eq) -> x
+ end
+ module MkVector(D:sig type ('a,'b) t end) =
+ Vector_hetero.Make1(struct type nonrec 'a t = 'a t end)(D)
+ module MkMap(D:sig type ('a,'b) t end) =
+ Intmap_hetero.Make1(struct type nonrec 'a t = 'a t end)(D)
+ module Vector =
+ Vector_hetero.RMake1(struct type nonrec 'a t = 'a t end)
+ module VectorH : Hashtbl_hetero.T1 with type 'a key = 'a t = struct
+
+ module VH = Vector_hetero.TMake1(struct type nonrec 'a t = 'a t end)
+ type 'a key = 'a VH.key
+ type t = unit VH.t
+ let create = VH.create
+ let size = VH.size
+ let get = VH.get
+ let get_def = VH.get_def
+ let set = VH.set
+ let is_uninitialized = VH.is_uninitialized
+ let inc_size = VH.inc_size
+ type iter_initialized = { iter : 'a. 'a -> unit; }
+ type iter_initializedi = { iteri : 'a. 'a key -> 'a -> unit; }
+ let iter_initializedi ({iteri}:iter_initializedi) =
+ VH.iter_initializedi { VH.iteri }
+ let iter_initialized ({iter}:iter_initialized) =
+ VH.iter_initializedi { VH.iteri = fun _ c -> iter c }
+ type 'c fold_initialized = { fold : 'a. 'c -> 'a -> 'c; }
+ type 'c fold_initializedi = { foldi : 'a. 'c -> 'a key -> 'a -> 'c; }
+ let fold_initializedi ({foldi}:'c fold_initializedi) =
+ VH.fold_initializedi {VH.foldi}
+ let fold_initialized ({fold}:'c fold_initialized) =
+ VH.fold_initializedi { foldi = fun sofar _ c -> fold sofar c }
+ let copy = VH.copy
+ let move = VH.move
+ type printk = { printk : 'a. 'a key Format.printer }
+ type printd = { printd : 'a. 'a key -> 'a Format.printer }
+ let pp sep1 sep2 {printk} {printd} = VH.pp sep1 sep2 {VH.printk} {VH.printd}
+ let clear _ = ()
+ let remove _ = failwith "Unneeded"
+
+ end
+ module M =
+ Intmap_hetero.RMake1(struct type nonrec 'a t = 'a t end)
+
+ module Make_Registry(S:sig
+ type 'a data
+ val pp: 'a data -> 'a Pp.pp
+ val key: 'a data -> 'a t
+ end) = struct
+
+ type 'a data = 'a S.data
+
+ module V = MkVector(struct type ('a,'unedeed) t = 'a S.data end)
+
+ exception UnregisteredKey : 'a t -> exn
+ exception AlreadyRegisteredKey : 'a t -> exn
+
+ let () = Exn_printer.register (fun fmt exn ->
+ match exn with
+ | UnregisteredKey(key) ->
+ Format.fprintf fmt "The key %a have not been registered" K.pp key
+ | AlreadyRegisteredKey(key) ->
+ Format.fprintf fmt "The key %a have already been registered" K.pp key
+ | exn -> raise exn
+ )
+
+ let registry : unit V.t = V.create 8
+
+ let register data =
+ let key = S.key data in
+ V.inc_size key registry;
+ assert (if not (V.is_uninitialized registry key)
+ then raise (AlreadyRegisteredKey(key)) else true);
+ V.set registry key data
+
+ let check_is_registered key =
+ assert (if V.is_uninitialized registry key
+ then raise (UnregisteredKey(key)) else true)
+
+ let is_well_initialized () =
+ let well_initialized = ref true in
+ iter {iter = fun data ->
+ if V.is_uninitialized registry data then begin
+ Format.eprintf "[Warning] %a is not registered" pp data;
+ well_initialized := false;
+ end};
+ !well_initialized
+
+ let is_registered dom =
+ V.is_uninitialized registry dom
+
+ let get k =
+ check_is_registered k;
+ V.get registry k
+
+ let print (type a) (k : a t) fmt s =
+ let data = get k in
+ (S.pp data) fmt s
+ end
+
+end
+
+module type Registry2 = sig
+ type ('k,'d) key
+ type ('k,'d) data
+
+ val register: ('k,'d) data -> unit
+ val check_is_registered : ('k,'d) key -> unit
+ val is_well_initialized : unit -> bool
+ val get : ('k,'d) key -> ('k,'d) data
+ val printk : ('k,'d) key -> 'k Pp.pp
+ val printd : ('k,'d) key -> 'd Pp.pp
+
+
+ exception UnregisteredKey : ('a,'b) key -> exn
+ exception AlreadyRegisteredKey : ('a,'b) key -> exn
+end
+
+module type Key2 = sig
+ (** Key with arity 2 *)
+
+ module K: Datatype
+ type ('k,'d) t (* = private K.t *)
+ (** kind of daemon for semantic value of type 'a *)
+ val pp: ('k,'d) t Pp.pp
+ val equal: ('k1,'d1) t -> ('k2,'d2) t -> bool
+ val hash : ('k,'d) t -> int
+
+ type iter = {iter : 'k 'd. ('k,'d) t -> unit}
+ val iter : iter -> unit
+
+ val create_key: (module NamedType2 with type t = 'a1
+ and type d = 'a2)
+ -> ('a1,'a2) t
+
+ module Eq: sig
+ val eq_type : ('a1,'b1) t -> ('a2,'b2) t
+ -> ('a1*'b1,'a2*'b2) Poly.eq option
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned *)
+
+ val coerce_type : ('a1,'b1) t -> ('a2,'b2) t
+ -> ('a1*'b1,'a2*'b2) Poly.eq
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned otherwise
+ the exception BadCoercion is raised *)
+ end
+ module MkVector(D:sig type ('k,'d,'b) t end)
+ : Vector_hetero.S2 with type ('k,'d) key = ('k,'d) t
+ and type ('k,'d,'b) data = ('k,'d,'b) D.t
+ module Make_Registry(S:sig
+ type ('k,'d) data
+ val ppk: ('k,'d) data -> 'k Pp.pp
+ val ppd: ('k,'d) data -> 'd Pp.pp
+ val key: ('k,'d) data -> ('k,'d) t
+ end) : Registry2 with type ('k,'d) key := ('k,'d) t and type ('k,'d) data = ('k,'d) S.data
+end
+
+module Make_key2(X:sig end) : Key2 = struct
+ module K = Strings.Fresh(struct end)
+
+ type ('k,'d) t = K.t (* >= 0 *)
+ let pp fmt x = K.pp fmt x
+ let equal = K.equal
+ let hash x = K.hash x
+ let key x = x
+
+ type iter = {iter : 'k 'd. ('k,'d) t -> unit}
+ let iter f = K.iter f.iter
+
+ let create_key (type a1) (type a2) (module NT : NamedType2 with type t = a1
+ and type d = a2)
+ : (a1,a2) t =
+ K.create NT.name
+
+ (** the ('k,'d) k can be used as equality witness because K gives
+ fresh values *)
+ module Eq = struct
+
+ let eq_type :
+ type a1 b1 a2 b2. (a1,b1) t -> (a2,b2) t
+ -> (a1*b1,a2*b2) Poly.eq option =
+ fun a b ->
+ if equal a b
+ then
+ let eq = (Obj.magic (Poly.Eq : (a1*b1,a1*b1) Poly.eq) : (a1*b1,a2*b2) Poly.eq)
+ in Some eq
+ else None
+
+ let coerce_type :
+ type a1 b1 a2 b2. (a1,b1) t -> (a2,b2) t
+ -> (a1*b1,a2*b2) Poly.eq =
+ fun a b ->
+ if equal a b
+ then
+ let eq = (Obj.magic (Poly.Eq : (a1*b1,a1*b1) Poly.eq) : (a1*b1,a2*b2) Poly.eq)
+ in eq
+ else raise BadCoercion
+
+ end
+ module MkVector(D:sig type ('k,'d,'b) t end) =
+ Vector_hetero.Make2(struct type nonrec ('k,'d) t = ('k,'d) t end)(D)
+
+ module Make_Registry(S:sig
+ type ('k,'d) data
+ val ppk: ('k,'d) data -> 'k Pp.pp
+ val ppd: ('k,'d) data -> 'd Pp.pp
+ val key: ('k,'d) data -> ('k,'d) t
+ end) = struct
+
+ type ('k,'d) data = ('k,'d) S.data
+
+ module V = MkVector(struct type ('k,'d,'unedeed) t = ('k,'d) S.data end)
+
+ let registry : unit V.t = V.create 8
+
+ exception UnregisteredKey : ('a,'b) t -> exn
+ exception AlreadyRegisteredKey : ('a,'b) t -> exn
+
+ let register data =
+ let key = S.key data in
+ V.inc_size key registry;
+ assert (if not (V.is_uninitialized registry key)
+ then raise (AlreadyRegisteredKey key) else true);
+ V.set registry key data
+
+ let check_is_registered key =
+ assert (if V.is_uninitialized registry key
+ then raise (UnregisteredKey key) else true)
+
+ let is_well_initialized () =
+ let well_initialized = ref true in
+ iter {iter = fun data ->
+ if V.is_uninitialized registry data then begin
+ Format.eprintf "[Warning] %a is not registered" pp data;
+ well_initialized := false;
+ end};
+ !well_initialized
+
+ let is_registered dom =
+ V.is_uninitialized registry dom
+
+ let get k =
+ check_is_registered k;
+ V.get registry k
+
+ let printk (type k) (type d) (k : (k,d) t) fmt s =
+ let data = get k in
+ (S.ppk data) fmt s
+ let printd (type k) (type d) (k : (k,d) t) fmt s =
+ let data = get k in
+ (S.ppd data) fmt s
+ end
+end
diff --git a/src/stdlib/comp_keys.mli b/src/stdlib/comp_keys.mli
new file mode 100644
index 000000000..88f37bfbc
--- /dev/null
+++ b/src/stdlib/comp_keys.mli
@@ -0,0 +1,187 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Key generators *)
+
+(** Keys are the main programming tools used for implementing
+ extensible types (sem, value, dom, pexp, ...) *)
+
+open Witan_popop_lib
+open Popop_stdlib
+
+open Std
+
+module type NamedType = sig
+ type t
+ val name : string
+end
+
+module type NamedType2 = sig
+ type t
+ type d
+ val name : string
+end
+
+(** {2 Exceptions} *)
+
+(** {2 Type comparison and coercion } *)
+
+exception BadCoercion
+(** Raised when making a bad coercion *)
+
+(* type (_,_) eq = Eq : ('a,'a) eq
+ * (\** Proof of type equality *\) *)
+
+module type Registry = sig
+ type 'a key
+ type 'a data
+
+ val register: 'a data -> unit
+ val check_is_registered : 'a key -> unit
+ val is_well_initialized : unit -> bool
+ val get : 'a key -> 'a data
+ val print : 'a key -> 'a Pp.pp
+
+
+ (** the key shouldn't be used before its registration and shouldn't be
+ registered again *)
+ exception UnregisteredKey : 'a key -> exn
+ exception AlreadyRegisteredKey : 'a key -> exn
+
+end
+
+module type Key = sig
+ (** Key with arity 1 *)
+
+ module K: Datatype
+ type 'a t (* = private K.t *)
+
+ val pp: 'a t Pp.pp
+ val compare: 'a t -> 'b t -> int
+ val equal: 'a t -> 'b t -> bool
+ val hash : 'a t -> int
+ val tag: 'a t -> int
+ val key: 'a t -> K.t
+
+ type iter = {iter : 'a. 'a t -> unit}
+ val iter : iter -> unit
+ type 'b fold = {fold : 'a. 'a t -> 'b -> 'b}
+ val fold : 'b fold -> 'b -> 'b
+ val hint_size : unit -> int
+
+ module Eq: sig
+ val eq_type : 'a t -> 'b t -> ('a,'b) Poly.iseq
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned *)
+
+ val coerce_type : 'a t -> 'b t -> ('a,'b) Poly.eq
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned otherwise
+ the exception BadCoercion is raised *)
+
+ val coerce : 'a t -> 'b t -> 'a -> 'b
+ (** If the two arguments are physically identical then covnert the
+ argument otherwise taise BadCoercion *)
+
+ end
+ val create_key: (module NamedType with type t = 'a) -> 'a t
+
+ module MkVector(D:sig type ('a,'b) t end)
+ : Vector_hetero.S1 with
+ type 'a key = 'a t and type ('a,'b) data = ('a,'b) D.t
+
+ module MkMap(D:sig type ('a,'b) t end)
+ : Intmap_hetero.S1 with
+ type 'a key = 'a t and type ('a,'b) data = ('a,'b) D.t
+
+ module Vector : Vector_hetero.R1 with type 'a key = 'a t
+ module VectorH : Hashtbl_hetero.T1 with type 'a key = 'a t
+ (* module VectorH : Vector_hetero.T1 with type 'a key = 'a t *)
+ module M : Intmap_hetero.R1 with type 'a key = 'a t
+ module Make_Registry(S:sig
+ type 'a data
+ val pp: 'a data -> 'a Pp.pp
+ val key: 'a data -> 'a t
+ end) : Registry with type 'a key := 'a t and type 'a data = 'a S.data
+end
+
+module Make_key(X:sig end) : Key
+
+module type Registry2 = sig
+ type ('k,'d) key
+ type ('k,'d) data
+
+ val register: ('k,'d) data -> unit
+ val check_is_registered : ('k,'d) key -> unit
+ val is_well_initialized : unit -> bool
+ val get : ('k,'d) key -> ('k,'d) data
+ val printk : ('k,'d) key -> 'k Pp.pp
+ val printd : ('k,'d) key -> 'd Pp.pp
+
+ exception UnregisteredKey : ('a,'b) key -> exn
+ exception AlreadyRegisteredKey : ('a,'b) key -> exn
+
+end
+
+module type Key2 = sig
+ (** Key with arity 2 *)
+
+ module K: Datatype
+ type ('k,'d) t (* = private K.t *)
+ (** kind of daemon for semantic value of type 'a *)
+ val pp: ('k,'d) t Pp.pp
+ val equal: ('k1,'d1) t -> ('k2,'d2) t -> bool
+ val hash : ('k,'d) t -> int
+
+ type iter = {iter : 'k 'd. ('k,'d) t -> unit}
+ val iter : iter -> unit
+
+ val create_key: (module NamedType2 with type t = 'a1
+ and type d = 'a2)
+ -> ('a1,'a2) t
+
+ module Eq: sig
+ val eq_type : ('a1,'b1) t -> ('a2,'b2) t
+ -> ('a1*'b1,'a2*'b2) Poly.eq option
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned *)
+
+ val coerce_type : ('a1,'b1) t -> ('a2,'b2) t
+ -> ('a1*'b1,'a2*'b2) Poly.eq
+ (** If the two arguments are physically identical then an equality witness
+ between the types is returned otherwise
+ the exception BadCoercion is raised *)
+ end
+ module MkVector(D:sig type ('k,'d,'b) t end)
+ : Vector_hetero.S2 with type ('k,'d) key = ('k,'d) t
+ and type ('k,'d,'b) data = ('k,'d,'b) D.t
+ module Make_Registry(S:sig
+ type ('k,'d) data
+ val ppk: ('k,'d) data -> 'k Pp.pp
+ val ppd: ('k,'d) data -> 'd Pp.pp
+ val key: ('k,'d) data -> ('k,'d) t
+ end) : Registry2 with type ('k,'d) key := ('k,'d) t and type ('k,'d) data = ('k,'d) S.data
+
+end
+
+module Make_key2(X:sig end): Key2
diff --git a/src/stdlib/config.ml b/src/stdlib/config.ml
new file mode 100644
index 000000000..4c0c4ea63
--- /dev/null
+++ b/src/stdlib/config.ml
@@ -0,0 +1,21 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+[%%define keys "well-typed"]
diff --git a/src/stdlib/context.ml b/src/stdlib/context.ml
new file mode 100644
index 000000000..9a40170c0
--- /dev/null
+++ b/src/stdlib/context.ml
@@ -0,0 +1,244 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+type context = {
+ mutable bps: bp list;
+}
+
+and bp = {
+ mutable alive : bool; (** not poped *)
+ context : context;
+}
+
+type creator = context
+
+let creator t = t
+
+let bp_equal (a:bp) b = CCEqual.physical a b
+
+let create () =
+ let rec context = { bps = [bp];}
+ and bp = { alive = true; context} in
+ context
+
+let bp t = match t.bps with
+ | [] -> assert false (** absurd: the level0 can't be removed since there is no bp under it *)
+ | bp::_ -> bp
+
+let push context =
+ let bp = {alive = true; context} in
+ context.bps <- bp::context.bps
+
+exception AlreadyPoped
+
+let pop bp =
+ if not bp.alive then raise AlreadyPoped;
+ let rec aux = function
+ | [] -> assert false (** absurd: by invariant bp must be in the list *)
+ | (a::_) as l when bp_equal a bp ->
+ bp.context.bps <- l
+ | a::l ->
+ assert (a.alive);
+ a.alive <- false;
+ aux l
+ in
+ aux bp.context.bps
+
+module Ref = struct
+ type 'a t = {
+ mutable contents : 'a;
+ mutable previous : 'a hist_bp_ref list;
+ context : context;
+ }
+
+ and 'a hist_bp_ref = {
+ value : 'a;
+ at: bp;
+ }
+
+
+ let create context x = {
+ contents = x;
+ previous = [];
+ context;
+ }
+
+ let rewind r =
+ match r.previous with
+ | [] -> ()
+ | {at}::_ when at.alive -> ()
+ | _ ->
+ let rec aux v = function
+ | {at;value}::l when not at.alive -> aux value l
+ | l -> r.contents <- v; r.previous <- l
+ in
+ aux r.contents r.previous
+
+ let set r v =
+ rewind r;
+ if not (CCEqual.physical r.contents v)
+ then
+ match r.previous with
+ | {at}::_ when bp_equal at (bp r.context) -> r.contents <- v
+ | _ ->
+ r.previous <- {at=bp r.context; value = r.contents}::r.previous;
+ r.contents <- v
+
+ let get r =
+ rewind r;
+ r.contents
+
+ let creator (h:'a t) = h.context
+
+end
+
+
+module Ref2 = struct
+ type ('a,'b) t = {
+ mutable contents1 : 'a;
+ mutable contents2 : 'b;
+ mutable previous : ('a,'b) history list;
+ context : context;
+ }
+
+ and ('a,'b) history = {
+ value1 : 'a;
+ value2 : 'b;
+ at: bp;
+ }
+
+ let creator (h:('a,'b) t) = h.context
+
+ let create context x1 x2 = {
+ contents1 = x1;
+ contents2 = x2;
+ previous = [];
+ context;
+ }
+
+ let rewind r =
+ match r.previous with
+ | [] -> ()
+ | {at}::_ when at.alive -> ()
+ | _ ->
+ let rec aux v1 v2 = function
+ | {at;value1;value2}::l when not at.alive -> aux value1 value2 l
+ | l -> r.contents1 <- v1; r.contents2 <- v2; r.previous <- l
+ in
+ aux r.contents1 r.contents2 r.previous
+
+ let set1 r v1 =
+ rewind r;
+ if not (CCEqual.physical r.contents1 v1)
+ then
+ match r.previous with
+ | {at}::_ when bp_equal at (bp r.context) -> r.contents1 <- v1
+ | _ ->
+ r.previous <- {at=bp r.context; value1 = r.contents1; value2 = r.contents2}::r.previous;
+ r.contents1 <- v1
+
+ let get1 r =
+ rewind r;
+ r.contents1
+
+ let set2 r v2 =
+ rewind r;
+ if not (CCEqual.physical r.contents2 v2)
+ then
+ match r.previous with
+ | {at}::_ when bp_equal at (bp r.context) -> r.contents2 <- v2
+ | _ ->
+ r.previous <- {at=bp r.context; value1 = r.contents1; value2 = r.contents2}::r.previous;
+ r.contents2 <- v2
+
+ let get2 r =
+ rewind r;
+ r.contents2
+
+ let set r v1 v2 =
+ rewind r;
+ if not (CCEqual.physical r.contents1 v1 && CCEqual.physical r.contents2 v2)
+ then
+ match r.previous with
+ | {at}::_ when bp_equal at (bp r.context) ->
+ r.contents1 <- v1; r.contents2 <- v2
+ | _ ->
+ r.previous <- {at=bp r.context; value1 = r.contents1; value2 = r.contents2}::r.previous;
+ r.contents1 <- v1;
+ r.contents2 <- v2
+
+ let get r =
+ rewind r;
+ r.contents1, r.contents2
+end
+
+type 'a history = {
+ mutable previous : 'a hist list;
+ context : context;
+}
+
+and 'a hist = {
+ saved : 'a;
+ at: bp;
+}
+
+module Make(S:sig
+ type t
+ type saved
+
+ val save: t -> saved
+ val restore: saved -> t -> unit
+ val get_history: t -> saved history
+ end) = struct
+
+
+ let create context = {
+ previous = [];
+ context;
+ }
+
+ let refresh t =
+ let h = S.get_history t in
+ match h.previous with
+ | [] -> ()
+ | {at}::_ when at.alive -> ()
+ | {saved}::l ->
+ let rec aux saved = function
+ | {at;saved}::l when not at.alive -> aux saved l
+ | l -> S.restore saved t; h.previous <- l
+ in
+ aux saved l
+
+ let save t =
+ refresh t;
+ let h = S.get_history t in
+ match h.previous with
+ | {at}::_ when bp_equal at (bp h.context) -> ()
+ | _ ->
+ h.previous <- {at=bp h.context; saved = S.save t}::h.previous
+
+ type hidden = S.t
+ let ro t = refresh t; t
+ let rw t = save t; t
+ let hide t = t
+
+ let creator (h:'a history) = h.context
+
+end
diff --git a/src/stdlib/context.mli b/src/stdlib/context.mli
new file mode 100644
index 000000000..c61f6a250
--- /dev/null
+++ b/src/stdlib/context.mli
@@ -0,0 +1,136 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Context and backtrack point management *)
+
+type context
+(** A context, with an history of backtrack point *)
+
+type creator
+(** Same than context, but only used for creating datastructure *)
+
+val creator: context -> creator
+
+type bp
+(** A backtrack point associated to a context *)
+
+val create: unit -> context
+(** Create a new context, with a base backtrack point.
+ It is not possible to go below this backtrack point.
+*)
+
+val bp: context -> bp
+(** Get the current backtrack point *)
+
+val push : context -> unit
+(** Push a new backtrack point *)
+
+
+exception AlreadyPoped
+
+val pop : bp -> unit
+(** Pop the context associated to this backtrack point to this
+ backtrack point. All the backtrack point created since the given backtrack point are also poped.
+
+ raise AlreadyPoped if it already has been poped.
+ *)
+
+module Ref: sig
+ type 'a t
+ (** A reference aware of a context *)
+
+ val create: creator -> 'a -> 'a t
+ (** Create a reference in this context with the given value *)
+
+ val set: 'a t -> 'a -> unit
+ (** Modify the reference *)
+
+ val get: 'a t -> 'a
+ (** Get the current value of the reference *)
+
+ val creator: 'a t -> creator
+end
+
+module Ref2: sig
+ type ('a,'b) t
+ (** A reference aware of a context *)
+
+ val create: creator -> 'a -> 'b -> ('a,'b) t
+ (** Create a reference in this context with the given value *)
+
+ val set: ('a,'b) t -> 'a -> 'b -> unit
+ (** Modify the reference *)
+
+ val get: ('a,'b) t -> 'a * 'b
+ (** Get the current value of the reference *)
+
+ val set1: ('a,'b) t -> 'a -> unit
+ (** Modify the reference *)
+
+ val get1: ('a,'b) t -> 'a
+ (** Get the current value of the reference *)
+
+ val set2: ('a,'b) t -> 'b -> unit
+ (** Modify the reference *)
+
+ val get2: ('a,'b) t -> 'b
+ (** Get the current value of the reference *)
+
+ val creator: ('a,'b) t -> creator
+
+end
+
+type 'a history
+(** history of the values *)
+
+module Make(S:sig
+ type t
+ (** a type to make context aware *)
+
+ type saved
+ (** The data to save at backtrack point *)
+
+ val save: t -> saved
+ (** Get the data to save from the original type *)
+
+ val restore: saved -> t -> unit
+ (** Restore the saved data after a pop (delayed at the next {!refresh}) *)
+
+ val get_history: t -> saved history
+ end): sig
+
+ val create: creator -> S.saved history
+ (** Create an history *)
+
+ val refresh: S.t -> unit
+ (** Function to call before accessing the value when a pop could have occured *)
+
+ val save: S.t -> unit
+ (** Function to call before modifying the value, it does also refresh *)
+
+ type hidden
+ (** To be used for enforcing the use of the previous function *)
+ val ro: hidden -> S.t
+ val rw: hidden -> S.t
+ val hide: S.t -> hidden
+
+ val creator: 'a history -> creator
+
+end
diff --git a/src/stdlib/dune b/src/stdlib/dune
new file mode 100644
index 000000000..0973647a7
--- /dev/null
+++ b/src/stdlib/dune
@@ -0,0 +1,11 @@
+(library
+ (name witan_stdlib)
+ (public_name witan.stdlib)
+ (synopsis "Stdlib for witan")
+ (libraries zarith containers witan_popop_lib)
+ (preprocess
+ (pps ppx_optcomp ppx_deriving.std))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always -open
+ Containers)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/stdlib/hashtbl_hetero.ml b/src/stdlib/hashtbl_hetero.ml
new file mode 100644
index 000000000..836b43b0f
--- /dev/null
+++ b/src/stdlib/hashtbl_hetero.ml
@@ -0,0 +1,210 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Std
+
+include Hashtbl_hetero_sig
+
+module MakeS1(K:Keys1)(D:sig type ('a,'b) t end)
+= struct
+ module H = Hashtbl.Make(Int)
+
+ type 'a key = 'a K.t
+ type ('a,'b) data = ('a,'b) D.t
+
+ type 'b elt = Pair : 'a key * ('a,'b) D.t -> 'b elt
+ type 'b t = 'b elt H.t
+
+ type 'b iter_initialized = { iter : 'a. ('a, 'b) data -> unit; }
+ type 'b iter_initializedi = { iteri : 'a. 'a key -> ('a, 'b) data -> unit }
+ type ('b, 'c) fold_initialized = { fold : 'a. 'c -> ('a, 'b) data -> 'c; }
+ type ('b, 'c) fold_initializedi = { foldi : 'a. 'c -> 'a key -> ('a, 'b) data -> 'c }
+ type printk = { printk : 'a. 'a key Format.printer }
+ type 'b printd = { printd : 'a. 'a key -> ('a, 'b) data Format.printer }
+
+ module Includable = struct
+
+ let create capacity : 'b t = H.create capacity
+
+ let get (type a) (m: 'b t) (k : a key) : (a, 'b) data =
+ let Pair(k',r) = H.find m (K.tag k) in
+ match K.equal k k' with
+ | Poly.Eq -> r
+ | Poly.Neq -> raise IncoherentTable
+
+ let get_def : 'b t -> 'a key -> ('a, 'b) data -> ('a, 'b) data =
+ fun m k def ->
+ try get m k
+ with Not_found -> def
+
+ let set (m: 'b t) (k: 'a key) (v : ('a, 'b) data) : unit =
+ H.replace m (K.tag k) (Pair(k,v))
+
+ let is_uninitialized (m: 'b t) (k : 'a key) : bool = not(H.mem m (K.tag k))
+
+ let remove (m: 'b t) (k : 'a key) : unit = H.remove m (K.tag k)
+
+ let clear : 'b t -> unit = H.clear
+
+ let iter_initialized (f : 'b iter_initialized) (m: 'b t) : unit =
+ H.iter (fun _ (Pair(_,v)) -> f.iter v) m
+
+ let fold_initialized (f : ('b, 'c) fold_initialized) (seed: 'c) (m:'b t) =
+ H.fold (fun _ (Pair(_,v)) sofar -> f.fold sofar v) m seed
+
+ let iter_initializedi (f : 'b iter_initializedi) (m: 'b t) : unit =
+ H.iter (fun _ (Pair(k,v)) -> f.iteri k v) m
+
+ let fold_initializedi (f: ('b, 'c) fold_initializedi) (seed : 'c) (m : 'b t) : 'c =
+ H.fold (fun _ (Pair(k,v)) sofar -> f.foldi sofar k v) m seed
+
+ let copy : 'b t -> 'b t = H.copy
+ let move ~from ~to_ =
+ H.reset to_;
+ let aux k v = H.replace to_ k v in
+ H.iter aux from
+
+ let pp (sep1 : unit Format.printer) (sep2 : unit Format.printer)
+ (printkey : printk) (printdata : 'b printd) : 'b t Format.printer
+ =
+ fun fmt t ->
+ let printkeydata fmt (Pair(k,v)) =
+ Format.fprintf fmt "%a%a%a" printkey.printk k sep2 () (printdata.printd k) v
+ in
+ let as_list = H.fold (fun _ v sofar -> v::sofar) t [] in
+ Format.list ~sep:sep1 printkeydata fmt as_list
+ end
+
+ include Includable
+end
+
+module MakeR1(K:Keys1) : R1 with type 'a key = 'a K.t = struct
+
+ include MakeS1(K)(struct type (_,'b) t = 'b end)
+
+ let iter_initialized f m = H.iter (fun _ (Pair(_,v)) -> f v) m
+ let fold_initialized f seed m = H.fold (fun _ (Pair(_,v)) sofar -> f sofar v) m seed
+ let apply_initialized f m =
+ H.filter_map_inplace (fun _ (Pair(k,v)) -> Some(Pair(k,f v))) m
+
+ let pp (type b) (sep1 : unit Format.printer) (sep2 : unit Format.printer)
+ (printkey : printk) (printdata : b Format.printer) : b t Format.printer
+ =
+ fun fmt t ->
+ let printkeydata fmt (Pair(k,v)) =
+ Format.fprintf fmt "%a%a%a" printkey.printk k sep2 () printdata v
+ in
+ let as_list = H.fold (fun _ v sofar -> v::sofar) t [] in
+ Format.list ~sep:sep1 printkeydata fmt as_list
+
+end
+
+module MakeT1(K:Keys1) : T1 with type 'a key = 'a K.t = struct
+ module S1 = MakeS1(K)(struct type ('a,_) t = 'a end)
+ type t = unit S1.t
+ type 'a key = 'a K.t
+ type iter_initialized = { iter : 'a. 'a -> unit; }
+ type iter_initializedi = { iteri : 'a. 'a key -> 'a -> unit; }
+ type 'c fold_initialized = { fold : 'a. 'c -> 'a -> 'c; }
+ type 'c fold_initializedi = { foldi : 'a. 'c -> 'a key -> 'a -> 'c; }
+ type printk = { printk : 'a. 'a key Containers.Format.printer; }
+ type printd = { printd : 'a. 'a key -> 'a Containers.Format.printer; }
+ include S1.Includable
+ let iter_initialized {iter} = S1.iter_initialized {iter}
+ let iter_initializedi {iteri} = S1.iter_initializedi {iteri}
+ let fold_initialized {fold} = S1.fold_initialized {fold}
+ let fold_initializedi {foldi} = S1.fold_initializedi {foldi}
+ let pp (sep1 : unit Format.printer) (sep2 : unit Format.printer)
+ (printkey : printk) (printdata : printd) : t Format.printer
+ =
+ fun fmt t ->
+ let printkeydata fmt (S1.Pair(k,v)) =
+ Format.fprintf fmt "%a%a%a" printkey.printk k sep2 () (printdata.printd k) v
+ in
+ let as_list = S1.H.fold (fun _ v sofar -> v::sofar) t [] in
+ Format.list ~sep:sep1 printkeydata fmt as_list
+end
+
+module Make2
+ (K: Keys2)
+ (D:sig type ('a1,'a2,'b) t end)
+ : S2 with type ('a1,'a2) key = ('a1,'a2) K.t
+ and type ('a1,'a2,'b) data = ('a1,'a2,'b) D.t
+= struct
+
+ module H = Hashtbl.Make(Int)
+
+ type ('a1,'a2) key = ('a1,'a2) K.t
+ type ('a1,'a2,'b) data = ('a1,'a2,'b) D.t
+
+ type 'b elt = Pair : ('a1,'a2) key * ('a1,'a2,'b) D.t -> 'b elt
+ type 'b t = 'b elt H.t
+
+ let create capacity : 'b t = H.create capacity
+
+ let get (type a1 a2) (m: 'b t) (k : (a1,a2) key) : (a1,a2, 'b) data =
+ let Pair(k',r) = H.find m (K.tag k) in
+ match K.equal k k' with
+ | Poly.Eq -> r
+ | Poly.Neq -> raise IncoherentTable
+
+ let get_def : 'b t -> ('a1,'a2) key -> ('a1,'a2, 'b) data -> ('a1,'a2, 'b) data =
+ fun m k def ->
+ try get m k
+ with Not_found -> def
+
+ let set (m: 'b t) (k: ('a1,'a2) key) (v : ('a1,'a2, 'b) data) : unit =
+ H.replace m (K.tag k) (Pair(k,v))
+
+ let is_uninitialized (m: 'b t) (k : ('a1,'a2) key) : bool = not(H.mem m (K.tag k))
+
+ let remove (m: 'b t) (k : ('a1,'a2) key) : unit = H.remove m (K.tag k)
+
+ let clear : 'b t -> unit = H.clear
+
+ type 'b iter_initialized = { iter: 'a1 'a2. ('a1, 'a2, 'b) data -> unit }
+ let iter_initialized (f : 'b iter_initialized) (m: 'b t) : unit =
+ H.iter (fun _ (Pair(_,v)) -> f.iter v) m
+
+ type ('b,'c) fold_initialized =
+ { fold: 'a1 'a2. 'c -> ('a1,'a2,'b) data -> 'c }
+ let fold_initialized (f : ('b, 'c) fold_initialized) (seed: 'c) (m:'b t) =
+ H.fold (fun _ (Pair(_,v)) sofar -> f.fold sofar v) m seed
+
+ type 'b iter_initializedi =
+ { iteri: 'a1 'a2. ('a1,'a2) key -> ('a1,'a2,'b) data -> unit }
+ let iter_initializedi (f : 'b iter_initializedi) (m: 'b t) : unit =
+ H.iter (fun _ (Pair(k,v)) -> f.iteri k v) m
+
+ type ('b,'c) fold_initializedi =
+ { foldi: 'a1 'a2. 'c -> ('a1,'a2) key -> ('a1,'a2,'b) data -> 'c }
+ let fold_initializedi (f: ('b, 'c) fold_initializedi) (seed : 'c) (m : 'b t) : 'c =
+ H.fold (fun _ (Pair(k,v)) sofar -> f.foldi sofar k v) m seed
+
+ let copy : 'b t -> 'b t = H.copy
+ let move ~from ~to_ =
+ H.reset to_;
+ let aux k v = H.replace to_ k v in
+ H.iter aux from
+
+end
diff --git a/src/stdlib/hashtbl_hetero.mli b/src/stdlib/hashtbl_hetero.mli
new file mode 100644
index 000000000..13d65943a
--- /dev/null
+++ b/src/stdlib/hashtbl_hetero.mli
@@ -0,0 +1,35 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+include module type of Hashtbl_hetero_sig
+
+module MakeS1(K:Keys1)(D:sig type ('a,'b) t end)
+ : S1 with type 'a key = 'a K.t
+ and type ('a,'b) data = ('a,'b) D.t
+
+module MakeR1(K:Keys1) : R1 with type 'a key = 'a K.t
+module MakeT1(K:Keys1) : T1 with type 'a key = 'a K.t
+
+module Make2(K: Keys2)(D:sig type ('a1,'a2,'b) t end)
+ : S2 with type ('a1,'a2) key = ('a1,'a2) K.t
+ and type ('a1,'a2,'b) data = ('a1,'a2,'b) D.t
diff --git a/src/stdlib/hashtbl_hetero_sig.ml b/src/stdlib/hashtbl_hetero_sig.ml
new file mode 100644
index 000000000..aad9c5c31
--- /dev/null
+++ b/src/stdlib/hashtbl_hetero_sig.ml
@@ -0,0 +1,168 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Std
+
+exception IncoherentTable
+
+module type Keys1 = sig
+ type 'a t
+ val tag : 'a t -> int
+ val equal : 'a t -> 'b t -> ('a,'b) Poly.iseq
+end
+
+(** imperative, extensible and heterogene hash-tables *)
+
+module type S1 = sig
+ type 'a key
+ type ('a,'b) data
+ type 'b t
+
+ val create : int -> 'b t
+ val get : 'b t -> 'a key -> ('a,'b) data
+ val get_def : 'b t -> 'a key -> ('a,'b) data -> ('a,'b) data
+ val set : 'b t -> 'a key -> ('a,'b) data -> unit
+ val clear : 'b t -> unit
+ val is_uninitialized : 'b t -> 'a key -> bool
+ val remove : 'b t -> 'a key -> unit
+
+ type 'b iter_initialized = { iter: 'a. ('a,'b) data -> unit }
+ val iter_initialized : 'b iter_initialized -> 'b t -> unit
+
+ type ('b,'c) fold_initialized = { fold: 'a. 'c -> ('a,'b) data -> 'c }
+ val fold_initialized :
+ ('b,'c) fold_initialized -> 'c -> 'b t -> 'c
+
+ type 'b iter_initializedi = { iteri: 'a. 'a key -> ('a,'b) data -> unit }
+ val iter_initializedi :
+ 'b iter_initializedi -> 'b t -> unit
+
+ type ('b,'c) fold_initializedi =
+ { foldi: 'a. 'c -> 'a key -> ('a,'b) data -> 'c }
+ val fold_initializedi :
+ ('b,'c) fold_initializedi -> 'c -> 'b t -> 'c
+
+ val copy : 'b t -> 'b t
+ (* shallow *)
+ val move: from:'b t -> to_:'b t -> unit
+
+ type printk = { printk: 'a. 'a key Format.printer }
+ type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Format.printer }
+ val pp:
+ unit Format.printer ->
+ unit Format.printer ->
+ printk ->
+ 'b printd ->
+ 'b t Format.printer
+
+end
+
+(** Same as S1 but for ('a,'b) data = 'b *)
+module type R1 = sig
+ (* type ('a,'b) data = 'b *)
+ include S1 with type ('a,'b) data = 'b
+ (* Some primitives get their types simplified *)
+ val iter_initialized : ('b -> unit) -> 'b t -> unit
+ val fold_initialized : ('c -> 'b -> 'c) -> 'c -> 'b t -> 'c
+ val apply_initialized : ('b -> 'b) -> 'b t -> unit
+ val pp:
+ unit Format.printer ->
+ unit Format.printer ->
+ printk ->
+ 'b Format.printer ->
+ 'b t Format.printer
+end
+
+(** Same as S1 but for ('a,'b) data = 'a *)
+module type T1 = sig
+ type t
+ type 'a key
+ val create : int -> t
+ val get : t -> 'a key -> 'a
+ val get_def : t -> 'a key -> 'a -> 'a
+ val set : t -> 'a key -> 'a -> unit
+ val clear : t -> unit
+ val is_uninitialized : t -> 'a key -> bool
+ val remove : t -> 'a key -> unit
+ type iter_initialized = { iter : 'a. 'a -> unit; }
+ val iter_initialized : iter_initialized -> t -> unit
+ type 'c fold_initialized = { fold : 'a. 'c -> 'a -> 'c; }
+ val fold_initialized : 'c fold_initialized -> 'c -> t -> 'c
+ type iter_initializedi = { iteri : 'a. 'a key -> 'a -> unit; }
+ val iter_initializedi : iter_initializedi -> t -> unit
+ type 'c fold_initializedi = { foldi : 'a. 'c -> 'a key -> 'a -> 'c; }
+ val fold_initializedi : 'c fold_initializedi -> 'c -> t -> 'c
+ val copy : t -> t
+ val move : from: t -> to_: t -> unit
+ type printk = { printk : 'a. 'a key Containers.Format.printer; }
+ type printd = { printd : 'a. 'a key -> 'a Containers.Format.printer; }
+ val pp :
+ unit Containers.Format.printer ->
+ unit Containers.Format.printer ->
+ printk -> printd -> t Containers.Format.printer
+end
+
+
+module type Keys2 = sig
+ type ('a1,'a2) t
+ val tag : ('a1,'a2) t -> int
+ val equal : ('a1,'a2) t -> ('b1,'b2) t -> ('a1*'a2,'b1*'b2) Poly.iseq
+end
+
+module type S2 = sig
+ type ('a1,'a2) key
+ type ('a1,'a2,'b) data
+ type 'b t
+
+ val create : int -> 'b t
+
+ val get : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data
+ val get_def : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data -> ('a1,'a2,'b) data
+ val set : 'b t -> ('a1,'a2) key -> ('a1,'a2,'b) data -> unit
+ val clear: 'b t -> unit
+
+ val is_uninitialized : 'b t -> ('a1,'a2) key -> bool
+ val remove : 'b t -> ('a1,'a2) key -> unit
+
+ type 'b iter_initialized = { iter: 'a1 'a2. ('a1, 'a2, 'b) data -> unit }
+ val iter_initialized : 'b iter_initialized -> 'b t -> unit
+
+ type ('b,'c) fold_initialized =
+ { fold: 'a1 'a2. 'c -> ('a1,'a2,'b) data -> 'c }
+ val fold_initialized :
+ ('b,'c) fold_initialized -> 'c -> 'b t -> 'c
+
+ type 'b iter_initializedi =
+ { iteri: 'a1 'a2. ('a1,'a2) key -> ('a1,'a2,'b) data -> unit }
+ val iter_initializedi :
+ 'b iter_initializedi -> 'b t -> unit
+
+ type ('b,'c) fold_initializedi =
+ { foldi: 'a1 'a2. 'c -> ('a1,'a2) key -> ('a1,'a2,'b) data -> 'c }
+ val fold_initializedi :
+ ('b,'c) fold_initializedi -> 'c -> 'b t -> 'c
+
+ val copy : 'b t -> 'b t
+ (* shallow *)
+ val move: from:'b t -> to_:'b t -> unit
+end
diff --git a/src/stdlib/keys.ml b/src/stdlib/keys.ml
new file mode 100644
index 000000000..cc80c6e58
--- /dev/null
+++ b/src/stdlib/keys.ml
@@ -0,0 +1,278 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+[%%import "config.ml"]
+
+[%%if keys = "well-typed"]
+
+open Std
+
+module Strings = Witan_popop_lib.Strings
+module StringH = Witan_popop_lib.Popop_stdlib.DStr.H
+module Exn_printer = Witan_popop_lib.Exn_printer
+
+include Keys_sig
+
+module Make_key(X:sig end) = struct
+
+ type _ gadt = ..
+ type 'a t = { gadt : 'a gadt;
+ name : string;
+ id : int;
+ iseq : 'b. 'b gadt -> ('a,'b) Poly.iseq }
+
+ let pp fmt x = String.pp fmt x.name
+ let equal a b = a.id = b.id
+ let compare x y = compare x.id y.id
+ let hash x = x.id
+ let tag x = x.id
+ let name x = x.name
+
+ module Eq = struct
+ let eq_type a b = a.iseq b.gadt
+ let coerce_type a b = eq_type a b |> Poly.eq
+ let coerce (type a) (type b) (a:a t) (b:b t) (x:a) : b =
+ let Poly.Eq = coerce_type a b in x
+ end
+
+ type key = K : _ t -> key [@@unboxed]
+
+ module AllKeys = Hashtbl.Make(struct
+ type t = key
+ let equal (K a) (K b) = equal a b
+ let hash (K a) = a.id
+ end)
+
+ let all_keys = AllKeys.create 17
+ let used_names : (* next id to use *) int StringH.t = StringH.create 17
+
+ let create_key (type a) (module NT : NamedType with type t = a) : a t =
+ let module TMP = struct
+ type _ gadt += K : NT.t gadt
+ end in
+ let iseq : type b. b gadt -> (NT.t,b) Poly.iseq = function
+ | TMP.K -> Poly.Eq
+ | _ -> Poly.Neq
+ in
+ let key = { gadt = TMP.K;
+ name = Strings.find_new_name used_names NT.name;
+ id = AllKeys.length all_keys;
+ iseq }
+ in
+ AllKeys.replace all_keys (K key) ();
+ key
+
+
+ type iter = {iter : 'a. 'a t -> unit} [@@unboxed]
+ let iter f = AllKeys.iter (fun (K x) () -> f.iter x) all_keys
+ type 'b fold = {fold : 'a. 'a t -> 'b -> 'b} [@@unboxed]
+ let fold f = AllKeys.fold (fun (K x) () -> f.fold x) all_keys
+
+ module K1 = struct
+ type nonrec 'a t = 'a t
+ let equal = Eq.eq_type
+ let tag = tag
+ end
+
+ module MkVector(D:sig type ('a,'b) t end) = Hashtbl_hetero.MakeS1(K1)(D)
+ module Vector = Hashtbl_hetero.MakeR1(K1)
+ module VectorH = Hashtbl_hetero.MakeT1(K1)
+ module MkMap(D:sig type ('a,'b) t end) = Map_hetero.MakeS(K1)(D)
+ module M = Map_hetero.MakeR(K1)
+
+ module Make_Registry(S:sig
+ type 'a data
+ val pp: 'a data -> 'a Format.printer
+ val key: 'a data -> 'a t
+ end) = struct
+
+ type 'a data = 'a S.data
+
+ module V = MkVector(struct type ('a,'unedeed) t = 'a S.data end)
+
+ exception UnregisteredKey : 'a t -> exn
+ exception AlreadyRegisteredKey : 'a t -> exn
+
+ let () = Exn_printer.register (fun fmt exn ->
+ match exn with
+ | UnregisteredKey(key) ->
+ Format.fprintf fmt "The key %a have not been registered" pp key
+ | AlreadyRegisteredKey(key) ->
+ Format.fprintf fmt "The key %a have already been registered" pp key
+ | exn -> raise exn
+ )
+
+ let registry : unit V.t = V.create 8
+
+ let register data =
+ let key = S.key data in
+ assert (if not (V.is_uninitialized registry key)
+ then raise (AlreadyRegisteredKey key) else true);
+ V.set registry key data
+
+ let check_is_registered key =
+ assert (if V.is_uninitialized registry key
+ then raise (UnregisteredKey key) else true)
+
+ let is_well_initialized () =
+ let well_initialized = ref true in
+ iter {iter = fun data ->
+ if V.is_uninitialized registry data then begin
+ Format.eprintf "[Warning] %a is not registered" pp data;
+ well_initialized := false;
+ end};
+ !well_initialized
+
+ let is_registered dom =
+ V.is_uninitialized registry dom
+
+ let get k =
+ check_is_registered k;
+ V.get registry k
+
+ let print (type a) (k : a t) fmt s =
+ let data = get k in
+ S.pp data fmt s
+ end
+
+end
+
+
+
+
+
+module Make_key2(X:sig end) : Key2 = struct
+
+ type (_,_) gadt = ..
+ type ('k,'d) t = { gadt : ('k,'d) gadt;
+ name : string;
+ id : int;
+ iseq : 'b1 'b2. ('b1,'b2) gadt -> ('k*'d,'b1*'b2) Poly.iseq }
+
+ let pp fmt x = String.pp fmt x.name
+ let equal a b = a.id = b.id
+ let compare x y = compare x.id y.id
+ let hash x = x.id
+ let tag = hash
+ let name x = x.name
+
+ module Eq = struct
+ let eq_type a b = a.iseq b.gadt
+ let coerce_type a b = eq_type a b |> Poly.eq
+ end
+
+ type key = K : _ t -> key [@@unboxed]
+
+ module AllKeys = Hashtbl.Make(struct
+ type t = key
+ let equal (K a) (K b) = equal a b
+ let hash (K a) = a.id
+ end)
+
+ let all_keys = AllKeys.create 17
+ let used_names : (* next id to use *) int StringH.t = StringH.create 17
+
+ let create_key (type a1) (type a2) (module NT : NamedType2 with type t = a1
+ and type d = a2)
+ : (a1,a2) t =
+ let module TMP = struct
+ type (_,_) gadt += K : (NT.t,NT.d) gadt
+ end in
+ let iseq : type b1 b2. (b1,b2) gadt -> (NT.t*NT.d,b1*b2) Poly.iseq = function
+ | TMP.K -> Poly.Eq
+ | _ -> Poly.Neq
+ in
+ let key = { gadt = TMP.K;
+ name = Strings.find_new_name used_names NT.name;
+ id = AllKeys.length all_keys;
+ iseq }
+ in
+ AllKeys.add all_keys (K key) ();
+ key
+
+ type iter = {iter : 'k 'd. ('k,'d) t -> unit} [@@unboxed]
+ let iter f = AllKeys.iter (fun (K x) () -> f.iter x) all_keys
+ type 'b fold = {fold : 'a1 'a2. ('a1,'a2) t -> 'b -> 'b} [@@unboxed]
+ let fold f = AllKeys.fold (fun (K x) () -> f.fold x) all_keys
+
+ module K2 = struct
+ type nonrec ('a1,'a2) t = ('a1,'a2) t
+ let equal = Eq.eq_type
+ let tag = tag
+ end
+
+ module MkVector(D:sig type ('k,'d,'b) t end) = Hashtbl_hetero.Make2(K2)(D)
+
+ module Make_Registry(S:sig
+ type ('k,'d) data
+ val ppk: ('k,'d) data -> 'k Format.printer
+ val ppd: ('k,'d) data -> 'd Format.printer
+ val key: ('k,'d) data -> ('k,'d) t
+ end) = struct
+
+ type ('k,'d) data = ('k,'d) S.data
+
+ module V = MkVector(struct type ('k,'d,'unedeed) t = ('k,'d) S.data end)
+
+ let registry : unit V.t = V.create 8
+
+ exception UnregisteredKey : ('a,'b) t -> exn
+ exception AlreadyRegisteredKey : ('a,'b) t -> exn
+
+ let register data =
+ let key = S.key data in
+ assert (if not (V.is_uninitialized registry key)
+ then raise (AlreadyRegisteredKey key) else true);
+ V.set registry key data
+
+ let check_is_registered key =
+ assert (if V.is_uninitialized registry key
+ then raise (UnregisteredKey key) else true)
+
+ let is_well_initialized () =
+ let well_initialized = ref true in
+ iter {iter = fun data ->
+ if V.is_uninitialized registry data then begin
+ Format.eprintf "[Warning] %a is not registered" pp data;
+ well_initialized := false;
+ end};
+ !well_initialized
+
+ let is_registered dom =
+ V.is_uninitialized registry dom
+
+ let get k =
+ check_is_registered k;
+ V.get registry k
+
+ let printk (type k) (type d) (k : (k,d) t) fmt s =
+ let data = get k in
+ (S.ppk data) fmt s
+ let printd (type k) (type d) (k : (k,d) t) fmt s =
+ let data = get k in
+ (S.ppd data) fmt s
+ end
+end
+
+[%%else]
+
+include Comp_keys
+
+[%%endif]
diff --git a/src/arith/arith.mli b/src/stdlib/keys.mli
similarity index 51%
rename from src/arith/arith.mli
rename to src/stdlib/keys.mli
index 751307ccc..ccaac1447 100644
--- a/src/arith/arith.mli
+++ b/src/stdlib/keys.mli
@@ -1,38 +1,37 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Types
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
-val real: Ty.t
-val real_ctr: Ty.Constr.t
+[%%import "config.ml"]
-val cst : Q.t -> Cl.t
-val add : Cl.t -> Cl.t -> Cl.t
-val sub : Cl.t -> Cl.t -> Cl.t
+[%%if keys = "well-typed"]
-val mult_cst : Q.t -> Cl.t -> Cl.t
+include module type of Keys_sig
+module Make_key(X:sig end) : Key
+module Make_key2(X:sig end): Key2
-val mult : Cl.t -> Cl.t -> Cl.t
+[%%else]
-val th_register : Solver.d -> unit
-val zero: Cl.t
+include module type of Comp_keys
+
+[%%endif]
diff --git a/src/stdlib/keys_sig.ml b/src/stdlib/keys_sig.ml
new file mode 100644
index 000000000..4db140df3
--- /dev/null
+++ b/src/stdlib/keys_sig.ml
@@ -0,0 +1,174 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Key generators *)
+
+(** Keys are the main programming tools used for implementing
+ extensible types (sem, value, dom, pexp, ...) *)
+
+open Std
+
+(** {2 Exceptions} *)
+
+(** {2 Type comparison and coercion } *)
+
+module type Registry = sig
+ type 'a key
+ type 'a data
+
+ val register: 'a data -> unit
+ val check_is_registered : 'a key -> unit
+ val is_well_initialized : unit -> bool
+ val get : 'a key -> 'a data
+ val print : 'a key -> 'a Format.printer
+
+ (** the key shouldn't be used before its registration and shouldn't be
+ registered again *)
+ exception UnregisteredKey : 'a key -> exn
+ exception AlreadyRegisteredKey : 'a key -> exn
+
+end
+
+module type NamedType = sig
+ type t
+ val name : string
+end
+
+module type Key = sig
+ (** Key with arity 1 *)
+
+ (* module K: Datatype *)
+ type 'a t
+
+ val pp: 'a t Format.printer
+ val compare: 'a t -> 'b t -> int
+ val equal: 'a t -> 'b t -> bool
+ val hash : 'a t -> int
+ val tag : 'a t -> int
+ val name : 'a t -> string
+
+ type iter = {iter : 'a. 'a t -> unit} [@@unboxed]
+ val iter : iter -> unit
+ type 'b fold = {fold : 'a. 'a t -> 'b -> 'b} [@@unboxed]
+ val fold : 'b fold -> 'b -> 'b
+
+ module Eq: sig
+ val eq_type : 'a t -> 'b t -> ('a,'b) Poly.iseq
+ (** If the two arguments are identical then an equality witness
+ between the types is returned *)
+
+ val coerce_type : 'a t -> 'b t -> ('a,'b) Poly.eq
+ (** If the two arguments are identical then an equality witness
+ between the types is returned otherwise
+ the exception BadCoercion is raised *)
+
+ val coerce : 'a t -> 'b t -> 'a -> 'b
+ (** If the two arguments are identical then covnert the
+ argument otherwise taise BadCoercion *)
+
+ end
+ val create_key: (module NamedType with type t = 'a) -> 'a t
+
+ module MkVector(D:sig type ('a,'b) t end)
+ : Hashtbl_hetero.S1 with type 'a key = 'a t
+ and type ('a,'b) data = ('a,'b) D.t
+ module Vector : Hashtbl_hetero.R1 with type 'a key = 'a t
+ module VectorH : Hashtbl_hetero.T1 with type 'a key = 'a t
+
+ module MkMap(D:sig type ('a,'b) t end)
+ : Map_hetero.S with type 'a key = 'a t
+ and type ('a,'b) data = ('a,'b) D.t
+ module M : Map_hetero.R with type 'a key = 'a t
+ module Make_Registry(S:sig
+ type 'a data
+ val pp : 'a data -> 'a Format.printer
+ val key: 'a data -> 'a t
+ end) : Registry with type 'a key := 'a t and type 'a data = 'a S.data
+end
+
+
+(* Arity 2 *)
+
+module type NamedType2 = sig
+ type t
+ type d
+ val name : string
+end
+
+module type Registry2 = sig
+ type ('k,'d) key
+ type ('k,'d) data
+
+ val register: ('k,'d) data -> unit
+ val check_is_registered : ('k,'d) key -> unit
+ val is_well_initialized : unit -> bool
+ val get : ('k,'d) key -> ('k,'d) data
+ val printk : ('k,'d) key -> 'k Format.printer
+ val printd : ('k,'d) key -> 'd Format.printer
+
+
+ exception UnregisteredKey : ('a,'b) key -> exn
+ exception AlreadyRegisteredKey : ('a,'b) key -> exn
+end
+
+module type Key2 = sig
+ (** Key with arity 2 *)
+
+ type ('k,'d) t
+
+ val pp: ('k,'d) t Format.printer
+ val equal: ('k1,'d1) t -> ('k2,'d2) t -> bool
+ val hash : ('k,'d) t -> int
+ val name : ('k,'d) t -> string
+
+ type iter = {iter : 'k 'd. ('k,'d) t -> unit} [@@unboxed]
+ val iter : iter -> unit
+
+ type 'b fold = {fold : 'a1 'a2. ('a1,'a2) t -> 'b -> 'b} [@@unboxed]
+ val fold : 'b fold -> 'b -> 'b
+
+ val create_key: (module NamedType2 with type t = 'a1
+ and type d = 'a2)
+ -> ('a1,'a2) t
+
+ module Eq: sig
+ val eq_type : ('a1,'a2) t -> ('b1,'b2) t -> ('a1*'a2,'b1*'b2) Poly.iseq
+ (** If the two arguments are identical then an equality witness
+ between the types is returned *)
+
+ val coerce_type : ('a1,'a2) t -> ('b1,'b2) t -> ('a1*'a2,'b1*'b2) Poly.eq
+ (** If the two arguments are identical then an equality witness
+ between the types is returned otherwise
+ the exception BadCoercion is raised *)
+ end
+ module MkVector(D:sig type ('k,'d,'b) t end)
+ : Hashtbl_hetero.S2 with type ('k,'d) key = ('k,'d) t
+ and type ('k,'d,'b) data = ('k,'d,'b) D.t
+ module Make_Registry(S:sig
+ type ('k,'d) data
+ val ppk: ('k,'d) data -> 'k Format.printer
+ val ppd: ('k,'d) data -> 'd Format.printer
+ val key: ('k,'d) data -> ('k,'d) t
+ end) : Registry2 with type ('k,'d) key := ('k,'d) t and type ('k,'d) data = ('k,'d) S.data
+end
+
diff --git a/src/stdlib/map_hetero.ml b/src/stdlib/map_hetero.ml
new file mode 100644
index 000000000..c389e5fff
--- /dev/null
+++ b/src/stdlib/map_hetero.ml
@@ -0,0 +1,144 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Std
+open Witan_popop_lib
+
+include Map_hetero_sig
+
+module MakeS
+ (K: Keys)
+ (D:sig type ('a,'b) t end)
+ = struct
+
+ type 'a key = 'a K.t
+ type ('a,'b) data = ('a,'b) D.t
+ type 'b pair = Pair : 'a K.t * ('a,'b) D.t -> 'b pair
+
+ module GIM = Intmap.Make(struct include Int let tag x = x end)
+ module IM = GIM.NT
+ type 'b t = 'b pair IM.t
+
+ let eq (type a a') (k : a key) (k' : a' key) : (a,a') Poly.eq =
+ match K.equal k k' with
+ | Poly.Eq -> Poly.Eq
+ | Poly.Neq -> raise IncoherentMap
+
+
+ let empty = IM.empty
+ let is_empty = IM.is_empty
+ let set_submap = IM.set_submap
+
+ let singleton (type a) (type b) (k: a K.t) (d : (a,b) data) : b t =
+ IM.singleton (K.tag k) (Pair(k,d))
+
+ let add (type a) (type b) (k : a K.t) d (t : b t) =
+ IM.add (K.tag k) (Pair(k,d)) t
+
+ let change (type a) (type b) f (k : a K.t) (t : b t) =
+ let f = function
+ | None -> f None
+ | Some(Pair(k',v)) -> let Poly.Eq = eq k k' in f(Some (v : (a,b) data))
+ in
+ IM.change (fun x -> f x |> Option.map (fun v -> Pair(k,v))) (K.tag k) t
+
+ let add_change (type a) (type b) empty add (k : a K.t) v (t : b t) =
+ let empty x = Pair(k,empty x) in
+ let add x (Pair(k',v')) = let Poly.Eq = eq k k' in Pair(k, add x (v':(a,b)data)) in
+ IM.add_change empty add (K.tag k) v t
+
+ let find_common (type a) (k : a K.t) (Pair(k',v) : 'b pair) : (a,'b) data =
+ let Poly.Eq = eq k k' in v
+
+ let find (type a) (k : a K.t) (t : 'b t) : (a,'b) data =
+ IM.find (K.tag k) t |> find_common k
+
+ let find_opt (type a) (k : a K.t) t =
+ IM.find_opt (K.tag k) t |> Option.map (find_common k)
+
+ let find_def (type a) def (k : a K.t) t =
+ find_opt k t |> Option.get_or ~default:def
+
+ let find_exn (type a) exn (k : a K.t) t =
+ IM.find_exn exn (K.tag k) t |> find_common k
+
+
+ type 'b union =
+ { union: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> ('a,'b) data option }
+
+ let union f t1 t2 =
+ IM.union
+ (fun _ (Pair(k1,d1)) (Pair(k2,d2)) ->
+ let Poly.Eq = eq k1 k2 in Option.map (fun d -> Pair(k1,d)) (f.union k1 d1 d2))
+ t1 t2
+
+ type ('b,'c) fold2_inter =
+ { fold2_inter: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> 'c -> 'c }
+
+ let fold2_inter f t1 t2 acc =
+ IM.fold2_inter
+ (fun _ (Pair(k1,d1)) (Pair(k2,d2)) acc ->
+ let Poly.Eq = eq k1 k2 in f.fold2_inter k1 d1 d2 acc)
+ t1 t2 acc
+
+ type 'b iter = { iter: 'a. 'a key -> ('a,'b) data -> unit }
+
+ let iter f t = IM.iter (fun _ (Pair(k,d)) -> f.iter k d) t
+
+ type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> ('a,'b) data -> 'c }
+
+ let fold f acc t = IM.fold_left (fun acc _ (Pair(k,d)) -> f.fold acc k d) acc t
+
+ type 'b mapi = { mapi: 'a. 'a key -> ('a,'b) data -> ('a,'b) data }
+ let mapi f t = IM.mapi (fun _ (Pair(k,d)) -> Pair(k,f.mapi k d)) t
+
+ type printk = { printk : 'a. 'a key Format.printer }
+ type 'b printd = { printd : 'a. 'a key -> ('a, 'b) data Format.printer }
+
+ let pp (sep1 : unit Format.printer) (sep2 : unit Format.printer)
+ (printkey : printk) (printdata : 'b printd) : 'b t Format.printer
+ =
+ fun fmt t ->
+ let printkeydata fmt (Pair(k,v)) =
+ Format.fprintf fmt "%a%a%a" printkey.printk k sep2 () (printdata.printd k) v
+ in
+ let as_list = IM.fold (fun _ v sofar -> v::sofar) t [] in
+ Format.list ~sep:sep1 printkeydata fmt as_list
+
+end
+
+
+module MakeR (K:Keys) = struct
+ include MakeS(K)(struct type ('a,'b) t = 'b end)
+
+ let pp (type b) (sep1 : unit Format.printer) (sep2 : unit Format.printer)
+ (printkey : printk) (printdata : b Format.printer) : b t Format.printer
+ =
+ fun fmt t ->
+ let printkeydata fmt (Pair(k,v)) =
+ Format.fprintf fmt "%a%a%a" printkey.printk k sep2 () printdata v
+ in
+ let as_list = IM.fold (fun _ v sofar -> v::sofar) t [] in
+ Format.list ~sep:sep1 printkeydata fmt as_list
+
+end
diff --git a/src/stdlib/map_hetero.mli b/src/stdlib/map_hetero.mli
new file mode 100644
index 000000000..346474949
--- /dev/null
+++ b/src/stdlib/map_hetero.mli
@@ -0,0 +1,30 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+include module type of Map_hetero_sig
+
+module MakeS(K:Keys)(D:sig type ('a,'b) t end)
+ : S with type 'a key = 'a K.t
+ and type ('a,'b) data = ('a,'b) D.t
+
+module MakeR(K:Keys) : R with type 'a key = 'a K.t
diff --git a/src/stdlib/map_hetero_sig.ml b/src/stdlib/map_hetero_sig.ml
new file mode 100644
index 000000000..65b913c97
--- /dev/null
+++ b/src/stdlib/map_hetero_sig.ml
@@ -0,0 +1,153 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Std
+
+exception IncoherentMap
+
+module type Keys = sig
+ type 'a t
+ val tag : 'a t -> int
+ val equal : 'a t -> 'b t -> ('a,'b) Poly.iseq
+end
+
+module type S = sig
+ type 'a key
+ type ('a,'b) data
+ type 'b t
+
+ val empty: 'b t
+ val is_empty: 'b t -> bool
+ val set_submap : 'a t -> 'b t -> bool
+
+ val singleton: 'a key -> ('a,'b) data -> 'b t
+
+ val find: 'a key -> 'b t -> ('a,'b) data
+ (** [find x m] returns the current binding of [x] in [m],
+ or raises [Not_found] if no such binding exists. *)
+
+ val find_def : ('a,'b) data -> 'a key -> 'b t -> ('a,'b) data
+ val find_opt : 'a key -> 'b t -> ('a,'b) data option
+ val find_exn : exn -> 'a key -> 'b t -> ('a,'b) data
+
+ val add: 'a key -> ('a,'b) data -> 'b t -> 'b t
+ (** [add x y m] returns a map containing the same bindings as
+ [m], plus a binding of [x] to [y]. If [x] was already bound
+ in [m], its previous binding disappears. *)
+
+ val change :
+ (('a,'b) data option -> ('a,'b) data option) -> 'a key -> 'b t -> 'b t
+ val add_change :
+ ('c -> ('a,'b) data) ->
+ ('c -> ('a,'b) data -> ('a,'b) data) ->
+ 'a key -> 'c -> 'b t -> 'b t
+
+ type 'b union =
+ { union: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> ('a,'b) data option }
+ val union : 'b union -> 'b t -> 'b t -> 'b t
+
+ type ('b,'c) fold2_inter =
+ { fold2_inter: 'a. 'a key -> ('a,'b) data -> ('a,'b) data -> 'c -> 'c }
+ val fold2_inter: ('b,'c) fold2_inter -> 'b t -> 'b t -> 'c -> 'c
+
+ type 'b iter = { iter: 'a. 'a key -> ('a,'b) data -> unit }
+ val iter : 'b iter -> 'b t -> unit
+
+ type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> ('a,'b) data -> 'c }
+ val fold : ('b,'c) fold -> 'c -> 'b t -> 'c
+
+ type 'b mapi = { mapi: 'a. 'a key -> ('a,'b) data -> ('a,'b) data }
+ val mapi : 'b mapi -> 'b t -> 'b t
+
+ type printk = { printk: 'a. 'a key Format.printer }
+ type 'b printd = { printd: 'a. 'a key -> ('a,'b) data Format.printer }
+ val pp:
+ unit Format.printer ->
+ unit Format.printer ->
+ printk ->
+ 'b printd ->
+ 'b t Format.printer
+
+end
+
+
+(** The following are needed in order to avoid ('a,'b) t = 'b in an
+ instanciation of the previous functors
+ (cf. ocaml mantis #5083:
+ J.Garrigue : "Phantom types must be either abstract or private.
+ In particular, using an abbreviation for a phantom type is just
+ a Russian roulette.")
+*)
+
+(** Same as S but for ('a,'b) data = 'b *)
+module type R = sig
+ type 'a key
+ type 'b t
+
+ val empty: 'b t
+ val is_empty: 'b t -> bool
+ val set_submap : 'a t -> 'b t -> bool
+
+ val singleton: 'a key -> 'b -> 'b t
+
+ val find: 'a key -> 'b t -> 'b
+ (** [find x m] returns the current binding of [x] in [m],
+ or raises [Not_found] if no such binding exists. *)
+
+ val find_def : 'b -> 'a key -> 'b t -> 'b
+ val find_opt : 'a key -> 'b t -> 'b option
+ val find_exn : exn -> 'a key -> 'b t -> 'b
+
+ val add: 'a key -> 'b -> 'b t -> 'b t
+ (** [add x y m] returns a map containing the same bindings as
+ [m], plus a binding of [x] to [y]. If [x] was already bound
+ in [m], its previous binding disappears. *)
+
+ val change :
+ ('b option -> 'b option) -> 'a key -> 'b t -> 'b t
+ val add_change :
+ ('c -> 'b) ->
+ ('c -> 'b -> 'b) ->
+ 'a key -> 'c -> 'b t -> 'b t
+
+ type 'b union = { union: 'a. 'a key -> 'b -> 'b -> 'b option }
+ val union : 'b union -> 'b t -> 'b t -> 'b t
+
+ type 'b iter = { iter: 'a. 'a key -> 'b -> unit }
+ val iter : 'b iter -> 'b t -> unit
+
+ type ('b,'c) fold = { fold: 'a. 'c -> 'a key -> 'b -> 'c }
+ val fold : ('b,'c) fold -> 'c -> 'b t -> 'c
+
+ type 'b mapi = { mapi: 'a. 'a key -> 'b -> 'b }
+ val mapi : 'b mapi -> 'b t -> 'b t
+
+ type printk = { printk : 'a. 'a key Containers.Format.printer; }
+ val pp:
+ unit Format.printer ->
+ unit Format.printer ->
+ printk ->
+ 'b Format.printer ->
+ 'b t Format.printer
+
+end
diff --git a/src/util/shuffle.ml b/src/stdlib/shuffle.ml
similarity index 63%
rename from src/util/shuffle.ml
rename to src/stdlib/shuffle.ml
index fde1546fd..8d127a417 100644
--- a/src/util/shuffle.ml
+++ b/src/stdlib/shuffle.ml
@@ -1,3 +1,23 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
(** {!shuffle} is used for test. Used for shuffling input entry *)
let opt_shuffle = ref None
@@ -11,7 +31,7 @@ let make_random =
Hashtbl.add h i s;
Random.State.copy s
-let int m =
+let int m =
match !opt_shuffle with
| Some rnd -> Random.State.int rnd m
| None -> max 0 (m-1)
@@ -20,7 +40,7 @@ let set_shuffle = function
| None -> opt_shuffle := None
| Some i -> opt_shuffle := Some (make_random i)
-let is_shuffle () = !opt_shuffle <> None
+let is_shuffle () = match !opt_shuffle with | None -> false | Some _ -> true
let shuffle2 ((t1,t2) as p) =
match !opt_shuffle with
@@ -124,3 +144,13 @@ let chooseb f g t =
match !opt_shuffle with
| None -> f t
| Some rnd -> g (fun () -> Random.State.bool rnd) t
+
+let choosef f g t =
+ match !opt_shuffle with
+ | None -> f t
+ | Some rnd -> g (Random.State.float rnd) t
+
+let choosei f g t =
+ match !opt_shuffle with
+ | None -> f t
+ | Some rnd -> g (Random.State.int rnd) t
diff --git a/src/stdlib/shuffle.mli b/src/stdlib/shuffle.mli
new file mode 100644
index 000000000..e014b4180
--- /dev/null
+++ b/src/stdlib/shuffle.mli
@@ -0,0 +1,60 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** Module for shuffling arbitrary choices. *)
+
+(** {1 Initialization } *)
+
+val set_shuffle: int array option -> unit
+(** if None is given shuffling is disable (default). The functions are
+ the identity *)
+
+val is_shuffle: unit -> bool
+
+(** {1 Shuffling on common types } *)
+
+val shuffle2: ('a * 'a) -> ('a * 'a)
+(** [shuffle p] invert or keep identical the elements of the pair.
+ Uniform *)
+
+val shuffle3: ('a * 'a * 'a) -> ('a * 'a * 'a)
+(** uniform *)
+
+val shufflel: 'a list -> 'a list
+(** not uniform *)
+
+val seq2: ('a -> 'b) -> ('a * 'a) -> ('b * 'b)
+(** uniform *)
+
+val seq3: ('a -> 'b) -> ('a * 'a * 'a) -> ('b * 'b * 'b)
+(** uniform *)
+
+val seql': ('a -> unit) -> 'a list -> unit
+val seql : (unit -> unit) list -> unit
+
+val chooseb: ('a -> 'b) -> ((unit -> bool) ->'a -> 'b) -> 'a -> 'b
+(** [chooseb f g] call f if there is no shuffling or g otherwise.
+ The first argument given to g is a random boolean generator.
+*)
+
+val choosef: ('a -> 'b) -> ((float -> float) ->'a -> 'b) -> 'a -> 'b
+val choosei: ('a -> 'b) -> ((int -> int) ->'a -> 'b) -> 'a -> 'b
+
+val int: int -> int
diff --git a/src/stdlib/std.ml b/src/stdlib/std.ml
new file mode 100644
index 000000000..ba98859a1
--- /dev/null
+++ b/src/stdlib/std.ml
@@ -0,0 +1,101 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+include Std_sig
+
+let nnil = function [] -> false | _::_ -> true
+
+module Poly = struct
+
+ type (_,_,_) t =
+ | Eq : ('a,'a,[< `Eq | `IsEq | `Ord]) t
+ | Neq: (_,_,[`IsEq]) t
+ | Gt : (_,_,[`Ord]) t
+ | Lt : (_,_,[`Ord]) t
+
+ type ('a,'b) eq = ('a,'b,[`Eq]) t
+ type ('a,'b) iseq = ('a,'b,[`IsEq]) t
+ type ('a,'b) ord = ('a,'b,[`Ord]) t
+
+ exception NotEq
+
+ let iseq (type a b) : (a,b,[< `Eq | `IsEq | `Ord]) t -> (a,b) iseq = function
+ | Eq -> Eq
+ | _ -> Neq
+
+ let eq (type a b) : (a,b,[< `Eq | `IsEq | `Ord]) t -> (a,b) eq = function
+ | Eq -> Eq
+ | _ -> raise NotEq
+
+end
+
+module Goption = struct
+ type (_,_) t =
+ | Some: 'a -> ('a,[`Some]) t
+ | None: ('a,[`None]) t
+end
+
+(* Extending Q module from Zarith *)
+module Q = struct
+ module Arg = struct
+ include Q (* Module from Zarith *)
+ let hash = Hash.poly
+ let pp fmt q =
+ Format.(
+ match Q.classify q with
+ | Q.ZERO -> char fmt '0'
+ | Q.INF -> string fmt "+∞"
+ | Q.MINF -> string fmt "-∞"
+ | Q.UNDEF -> string fmt "!undef!"
+ | Q.NZERO -> Q.pp_print fmt q
+ )
+ end
+ include Arg
+ include Witan_popop_lib.Popop_stdlib.MkDatatype(Arg)
+ let two = Q.of_int 2
+ let ge = Q.geq
+ let le = Q.leq
+
+ let of_string_decimal =
+ let decimal = Str.regexp "\\(+\\|-\\)?\\([0-9]+\\)\\([.]\\([0-9]*\\)\\)?" in
+ fun s ->
+ if not (Str.string_match decimal s 0) then None
+ else
+ let sgn = match Str.matched_group 1 s with
+ | "-" -> Q.minus_one
+ | "+" -> Q.one
+ | exception Not_found -> Q.one
+ | _ -> assert false in
+ let int_part = Q.of_string (Str.matched_group 2 s) in
+ let dec_part = match Str.matched_group 4 s with
+ | exception Not_found -> Q.zero
+ | "" -> Q.zero
+ | dec ->
+ let l = String.length dec in
+ let dec = Q.of_string dec in
+ let ten = Q.of_int 10 in
+ Witan_popop_lib.Util.foldi (fun acc _ -> Q.(acc * ten)) dec 1 l
+ in
+ Some Q.(sgn * (int_part + dec_part))
+
+end
diff --git a/src/stdlib/std.mli b/src/stdlib/std.mli
new file mode 100644
index 000000000..4f087cbdd
--- /dev/null
+++ b/src/stdlib/std.mli
@@ -0,0 +1,60 @@
+(*************************************************************************)
+(* This file is part of Witan. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* INRIA (Institut National de Recherche en Informatique et en *)
+(* Automatique) *)
+(* CNRS (Centre national de la recherche scientifique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+include module type of Std_sig
+
+val nnil : 'a list -> bool
+
+module Poly : sig
+
+ type (_,_,_) t =
+ | Eq : ('a,'a,[< `Eq | `IsEq | `Ord]) t
+ | Neq: (_,_,[`IsEq]) t
+ | Gt : (_,_,[`Ord]) t
+ | Lt : (_,_,[`Ord]) t
+
+ type ('a,'b) eq = ('a,'b,[`Eq]) t
+ type ('a,'b) iseq = ('a,'b,[`IsEq]) t
+ type ('a,'b) ord = ('a,'b,[`Ord]) t
+
+ val iseq : ('a,'b,[< `Eq | `IsEq | `Ord]) t -> ('a,'b) iseq
+
+ exception NotEq
+ val eq : ('a,'b,[< `Eq | `IsEq | `Ord]) t -> ('a,'b) eq
+
+end
+
+module Goption : sig
+ type (_,_) t =
+ | Some: 'a -> ('a,[`Some]) t
+ | None: ('a,[`None]) t
+end
+
+module Q : sig
+ include module type of Q
+ include Witan_popop_lib.Popop_stdlib.Datatype with type t := t
+ val two : t
+ val ge : t -> t -> bool
+ val le : t -> t -> bool
+ val of_string_decimal : string -> t option
+end
diff --git a/src/stdlib/std_sig.ml b/src/stdlib/std_sig.ml
new file mode 100644
index 000000000..42862b932
--- /dev/null
+++ b/src/stdlib/std_sig.ml
@@ -0,0 +1,48 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+exception Impossible (* Absurd *)
+exception TODO of string
+
+module type TaggedType =
+sig
+ type t
+ val tag : t -> int
+ val pp: t Format.printer
+end
+
+module type OrderedHashedType =
+sig
+ type t
+ val hash : t -> int
+ val equal : t -> t -> bool
+ val compare : t -> t -> int
+ val pp: t Format.printer
+end
+
+(* module type Datatype = sig
+ * include OrderedHashedType
+ *
+ * module M : Map_intf.PMap with type key = t
+ * module S : Map_intf.Set with type 'a M.t = 'a M.t
+ * and type M.key = M.key
+ * module H : Exthtbl.Hashtbl.S with type key = t
+ * end *)
+
diff --git a/src/template.ml b/src/template.ml
deleted file mode 100644
index 70b7080c8..000000000
--- a/src/template.ml
+++ /dev/null
@@ -1,106 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Stdlib
-open Popop.Types
-open Solver
-
-let lazy_propagation = false
-
-(* expressionModule *)
-module T = struct
- type t = unit
-
- let print _ = failwith "todo print"
- let compare _ = failwith "todo compare"
- let equal _ = failwith "todo equal"
- let hash _ = failwith "todo hash"
-
-end
-(* end *)
-
-(* semanticModule *)
-module Th = struct
- include MkDatatype(T)
- let key = Sem.create_key "todo key sem"
-end
-(* end *)
-
-(* registringSem *)
-module ThE = RegisterSem(Th)
-(* end *)
-
-module D = struct
- type t = unit
-
- let key = Dom.create_key "todo types"
- let print _ = failwith "todo print dom "
- let merge _ = failwith "todo merge "
- let merged _ = failwith "todo merged "
-end
-
-module DE = RegisterDom(D)
-
-module ExpProp = struct
- type t = unit
-
- let print _ = failwith "todo print exp "
- let analyse _ = failwith "todo analyse exp "
- let key = Explanation.Exp.create_key "todo key exp "
- let expdom _ = failwith "todo expdom exp "
-end
-
-module EP = Conflict.RegisterExp(ExpProp)
-
-module DaemonPropa = struct
- module Data = struct
- type t = unit
- let print _ = failwith "todo print Data print "
- end
-
- let key = Demon.Fast.create "todo key for daemon propa"
- let immediate = true (* failwith "todo immediate for daemon propa"*)
- let throttle = 0 (* failwith "todo throttle for daemon propa" *)
- let wakeup _ = failwith "todo wakeup for daemon propa"
-end
-
-module RDaemonPropa = Demon.Fast.Register(DaemonPropa)
-
-module Cho = struct
- module Key = Cl (* failwith "todo Module Key for Choice" *)
- module Data = D (* failwith "todo Module Data for Choice" *)
- let choose_decision _ = failwith "todo choose decision for Choice"
- let make_decision _ = failwith "todo make decision for Choice"
- let analyse _ = failwith "todo analyse for Choice"
- let key = Explanation.Cho.create_key "todo key for Choice"
-end
-module ECho = Conflict.RegisterCho(Cho)
-(*
-module Con = struct
- type t = unit
- let print _ = failwith "todo print Con "
- let key = "todo key for Con"
- let propacl _ = failwith "todo propacl for Con"
- let same_sem _ = failwith "todo same_sem for Con"
- let finalize _ = failwith "todo finalize for Con"
-end
-module EC = Conflict.RegisterCon(Con)
-*)
diff --git a/src/tests/dune b/src/tests/dune
new file mode 100644
index 000000000..304220bb3
--- /dev/null
+++ b/src/tests/dune
@@ -0,0 +1,15 @@
+(executable
+ (modes byte exe)
+ (name tests)
+ (libraries containers witan.core witan.theories.bool witan.theories.LRA
+ oUnit witan.solver witan.stdlib)
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-9@8 -color always)
+ (ocamlopt_flags :standard -O3 -unbox-closures -unbox-closures-factor 20))
+
+(rule
+ (alias runtest)
+ (deps
+ (:< tests.exe)
+ (source_tree solve/))
+ (action
+ (run %{<})))
diff --git a/src/tests/solve/dimacs/sat/anomaly_agetooold.cnf b/src/tests/solve/dimacs/sat/anomaly_agetooold.cnf
new file mode 100644
index 000000000..61413cffb
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/anomaly_agetooold.cnf
@@ -0,0 +1,15 @@
+p cnf 15 14
+1 -2 0
+3 2 0
+-1 4 0
+6 -1 0
+-2 -6 0
+2 -1 8 0
+-9 -8 0
+9 12 0
+-7 -13 0
+-14 0
+-3 1 0
+-12 -15 5 2 0
+11 10 0
+-4 -5 0
diff --git a/src/tests/solve/dimacs/sat/anomaly_agetooold2.cnf b/src/tests/solve/dimacs/sat/anomaly_agetooold2.cnf
new file mode 100644
index 000000000..93ba09bb3
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/anomaly_agetooold2.cnf
@@ -0,0 +1,32 @@
+p cnf 31 31
+4 -3 0
+1 7 0
+8 6 0
+-9 -10 -11 0
+9 10 0
+-9 10 0
+9 -10 11 0
+-7 11 0
+-10 12 0
+-13 14 0
+2 -15 0
+-4 -16 0
+-17 16 0
+-18 17 0
+19 18 0
+21 -20 0
+-22 -21 0
+-23 -12 0
+24 23 0
+20 25 0
+-26 -25 0
+13 27 0
+-27 28 0
+29 -28 0
+-5 30 0
+5 30 0
+-31 -30 0
+-19 -14 -2 0
+31 -29 0
+22 -24 0
+26 15 0
diff --git a/src/tests/solve/dimacs/sat/assertion_fail.cnf b/src/tests/solve/dimacs/sat/assertion_fail.cnf
new file mode 100644
index 000000000..56a8f3dbf
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/assertion_fail.cnf
@@ -0,0 +1,2 @@
+p cnf 36 1
+36 0
diff --git a/src/tests/solve/dimacs/sat/fuzzing1.cnf b/src/tests/solve/dimacs/sat/fuzzing1.cnf
new file mode 100644
index 000000000..bf3dfc6f1
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/fuzzing1.cnf
@@ -0,0 +1,17 @@
+c generated by FuzzSAT
+p cnf 7 15
+-1 -2 -3 0
+1 2 -3 0
+-1 2 3 0
+1 -2 3 0
+-4 -2 0
+-4 2 0
+5 2 0
+5 -2 0
+6 -4 0
+6 5 0
+4 -5 -6 0
+7 -3 0
+7 6 0
+3 -6 -7 0
+7 0
diff --git a/src/tests/solve/dimacs/sat/fuzzing2.cnf b/src/tests/solve/dimacs/sat/fuzzing2.cnf
new file mode 100644
index 000000000..9facc9e4f
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/fuzzing2.cnf
@@ -0,0 +1,11 @@
+c generated by FuzzSAT
+p cnf 5 9
+-1 -2 0
+1 -2 0
+-3 -1 0
+-3 2 0
+1 -2 3 0
+-5 -3 0
+-5 -4 0
+3 4 5 0
+5 0
diff --git a/src/tests/solve/dimacs/sat/par8-1-c.cnf b/src/tests/solve/dimacs/sat/par8-1-c.cnf
new file mode 100644
index 000000000..d9bcd5827
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/par8-1-c.cnf
@@ -0,0 +1,275 @@
+c FILE: par8-1-c.cnf
+c
+c SOURCE: James Crawford (jc@research.att.com)
+c
+c DESCRIPTION: Instance arises from the problem of learning the parity
+c function.
+c
+c parxx-y denotes a parity problem on xx bits. y is simply the
+c intance number.
+c
+c parxx-y-c denotes an instance identical to parxx-y except that
+c the instances have been simplified (to create an equivalent
+c problem).
+c
+c NOTE: Satisfiable (checked for 8 and 16 size instances. All
+c instances are satisfiable by construction)
+c
+c NOTE: Number of clauses corrected August 3, 1993
+c
+c Converted from tableau format Tue Aug 3 09:55:20 EDT 1993
+p cnf 64 254
+ -2 1 0
+ -3 -2 0
+ -3 -2 -1 0
+ 3 2 -1 0
+ -3 2 1 0
+ 3 -2 1 0
+ -4 2 0
+ -5 -4 0
+ -5 -4 -2 0
+ 5 4 -2 0
+ -5 4 2 0
+ 5 -4 2 0
+ -6 4 0
+ -7 -6 0
+ -7 -6 -4 0
+ 7 6 -4 0
+ -7 6 4 0
+ 7 -6 4 0
+ -8 6 0
+ -9 -8 0
+ -9 -8 -6 0
+ 9 8 -6 0
+ -9 8 6 0
+ 9 -8 6 0
+ -10 8 0
+ -11 -10 0
+ -11 -10 -8 0
+ 11 10 -8 0
+ -11 10 8 0
+ 11 -10 8 0
+ -12 10 0
+ -13 -12 0
+ -13 -12 -10 0
+ 13 12 -10 0
+ -13 12 10 0
+ 13 -12 10 0
+ -14 12 0
+ -15 -14 0
+ -15 -14 -12 0
+ 15 14 -12 0
+ -15 14 12 0
+ 15 -14 12 0
+ -16 14 0
+ -17 -16 0
+ -17 -16 -14 0
+ 17 16 -14 0
+ -17 16 14 0
+ 17 -16 14 0
+ -18 16 0
+ -19 -18 0
+ -19 -18 -16 0
+ 19 18 -16 0
+ -19 18 16 0
+ 19 -18 16 0
+ -20 18 0
+ -21 -20 0
+ -21 -20 -18 0
+ 21 20 -18 0
+ -21 20 18 0
+ 21 -20 18 0
+ -22 20 0
+ -23 -22 0
+ -23 -22 -20 0
+ 23 22 -20 0
+ -23 22 20 0
+ 23 -22 20 0
+ -24 22 0
+ -25 -24 0
+ -25 -24 -22 0
+ 25 24 -22 0
+ -25 24 22 0
+ 25 -24 22 0
+ -26 24 0
+ -27 -26 0
+ -27 -26 -24 0
+ 27 26 -24 0
+ -27 26 24 0
+ 27 -26 24 0
+ -28 26 0
+ -29 -28 0
+ -29 -28 -26 0
+ 29 28 -26 0
+ -29 28 26 0
+ 29 -28 26 0
+ 28 -30 0
+ -31 -30 0
+ -31 -28 -30 0
+ 31 -28 30 0
+ -31 28 30 0
+ 31 28 -30 0
+ -33 -32 -3 0
+ 33 32 -3 0
+ -33 32 3 0
+ 33 -32 3 0
+ -35 -34 -32 0
+ 35 34 -32 0
+ -35 34 32 0
+ 35 -34 32 0
+ -37 -34 36 0
+ 37 -34 -36 0
+ -37 34 -36 0
+ 37 34 36 0
+ -39 -38 -5 0
+ 39 38 -5 0
+ -39 38 5 0
+ 39 -38 5 0
+ -35 -40 -38 0
+ 35 40 -38 0
+ -35 40 38 0
+ 35 -40 38 0
+ -42 -41 -40 0
+ 42 41 -40 0
+ -42 41 40 0
+ 42 -41 40 0
+ -36 -41 43 0
+ 36 -41 -43 0
+ -36 41 -43 0
+ 36 41 43 0
+ -44 -7 29 0
+ 44 -7 -29 0
+ 44 7 29 0
+ -44 7 -29 0
+ -33 -45 -44 0
+ 33 45 -44 0
+ -33 45 44 0
+ 33 -45 44 0
+ -37 -36 -45 0
+ 37 36 -45 0
+ -37 36 45 0
+ 37 -36 45 0
+ -37 -46 -9 0
+ 37 46 -9 0
+ -37 46 9 0
+ 37 -46 9 0
+ -36 -43 -46 0
+ 36 43 -46 0
+ -36 43 46 0
+ 36 -43 46 0
+ -39 -47 -11 0
+ 39 47 -11 0
+ -39 47 11 0
+ 39 -47 11 0
+ -33 -48 -47 0
+ 33 48 -47 0
+ -33 48 47 0
+ 33 -48 47 0
+ -37 -36 -48 0
+ 37 36 -48 0
+ -37 36 48 0
+ 37 -36 48 0
+ -39 -49 -13 0
+ 39 49 -13 0
+ -39 49 13 0
+ 39 -49 13 0
+ -33 -36 -49 0
+ 33 36 -49 0
+ -33 36 49 0
+ 33 -36 49 0
+ -50 -15 29 0
+ 50 -15 -29 0
+ 50 15 29 0
+ -50 15 -29 0
+ -35 -37 -50 0
+ 35 37 -50 0
+ -35 37 50 0
+ 35 -37 50 0
+ -39 -35 -17 0
+ 39 35 -17 0
+ -39 35 17 0
+ 39 -35 17 0
+ -39 -51 -19 0
+ 39 51 -19 0
+ -39 51 19 0
+ 39 -51 19 0
+ -35 -52 -51 0
+ 35 52 -51 0
+ -35 52 51 0
+ 35 -52 51 0
+ -37 -52 42 0
+ 37 -52 -42 0
+ -37 52 -42 0
+ 37 52 42 0
+ -53 -21 29 0
+ 53 -21 -29 0
+ 53 21 29 0
+ -53 21 -29 0
+ -33 -54 -53 0
+ 33 54 -53 0
+ -33 54 53 0
+ 33 -54 53 0
+ -35 -54 42 0
+ 35 -54 -42 0
+ -35 54 -42 0
+ 35 54 42 0
+ -33 -23 42 0
+ 33 -23 -42 0
+ -33 23 -42 0
+ 33 23 42 0
+ -55 -25 29 0
+ 55 -25 -29 0
+ 55 25 29 0
+ -55 25 -29 0
+ -33 -56 -55 0
+ 33 56 -55 0
+ -33 56 55 0
+ 33 -56 55 0
+ -35 -56 36 0
+ 35 -56 -36 0
+ -35 56 -36 0
+ 35 56 36 0
+ -39 -57 -27 0
+ 39 57 -27 0
+ -39 57 27 0
+ 39 -57 27 0
+ -58 -57 29 0
+ 58 -57 -29 0
+ 58 57 29 0
+ -58 57 -29 0
+ -35 -59 -58 0
+ 35 59 -58 0
+ -35 59 58 0
+ 35 -59 58 0
+ -37 -59 -36 0
+ 37 -59 36 0
+ -37 59 36 0
+ 37 59 -36 0
+ -37 -60 -31 0
+ 37 60 -31 0
+ -37 60 31 0
+ 37 -60 31 0
+ -42 -61 -60 0
+ 42 61 -60 0
+ -42 61 60 0
+ 42 -61 60 0
+ -36 -61 43 0
+ 36 -61 -43 0
+ -36 61 -43 0
+ 36 61 43 0
+ -39 -62 -30 0
+ 39 62 -30 0
+ -39 62 30 0
+ 39 -62 30 0
+ -33 -63 -62 0
+ 33 63 -62 0
+ -33 63 62 0
+ 33 -63 62 0
+ -42 -64 -63 0
+ 42 64 -63 0
+ -42 64 63 0
+ 42 -64 63 0
+ -36 -64 -43 0
+ 36 -64 43 0
+ -36 64 43 0
+ 36 64 -43 0
diff --git a/src/tests/solve/dimacs/sat/pigeon-2.cnf b/src/tests/solve/dimacs/sat/pigeon-2.cnf
new file mode 100644
index 000000000..4fea8d909
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/pigeon-2.cnf
@@ -0,0 +1,24 @@
+c pigeon-2: placing 3 pigeons into 2 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 6 9
+1 2 0
+3 4 0
+5 6 0
+-1 -3 0
+-1 -5 0
+-3 -5 0
+-2 -4 0
+-2 -6 0
diff --git a/src/tests/solve/dimacs/sat/pigeon-3.cnf b/src/tests/solve/dimacs/sat/pigeon-3.cnf
new file mode 100644
index 000000000..4f2fd41d8
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/pigeon-3.cnf
@@ -0,0 +1,37 @@
+c pigeon-3: placing 4 pigeons into 3 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 12 22
+1 2 3 0
+4 5 6 0
+10 11 12 0
+-1 -4 0
+-1 -7 0
+-1 -10 0
+-4 -7 0
+-4 -10 0
+-7 -10 0
+-2 -5 0
+-2 -8 0
+-2 -11 0
+-5 -8 0
+-5 -11 0
+-8 -11 0
+-3 -6 0
+-3 -9 0
+-3 -12 0
+-6 -9 0
+-6 -12 0
+-9 -12 0
diff --git a/src/tests/solve/dimacs/sat/pigeon-4.cnf b/src/tests/solve/dimacs/sat/pigeon-4.cnf
new file mode 100644
index 000000000..690fbe4a8
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/pigeon-4.cnf
@@ -0,0 +1,60 @@
+c pigeon-4: placing 5 pigeons into 4 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 20 45
+1 2 3 4 0
+5 6 7 8 0
+9 10 11 12 0
+13 14 15 16 0
+17 18 19 20 0
+-1 -5 0
+-1 -9 0
+-1 -13 0
+-1 -17 0
+-5 -9 0
+-5 -13 0
+-5 -17 0
+-9 -13 0
+-9 -17 0
+-13 -17 0
+-2 -6 0
+-2 -10 0
+-2 -14 0
+-2 -18 0
+-6 -10 0
+-6 -14 0
+-6 -18 0
+-10 -14 0
+-10 -18 0
+-14 -18 0
+-3 -7 0
+-3 -11 0
+-3 -15 0
+-3 -19 0
+-7 -11 0
+-7 -15 0
+-7 -19 0
+-11 -15 0
+-11 -19 0
+-15 -19 0
+-4 -8 0
+-4 -12 0
+-4 -16 0
+-4 -20 0
+-8 -12 0
+-8 -16 0
+-8 -20 0
+-12 -16 0
+-16 -20 0
diff --git a/src/tests/solve/dimacs/sat/quinn.cnf b/src/tests/solve/dimacs/sat/quinn.cnf
new file mode 100644
index 000000000..9c662227a
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/quinn.cnf
@@ -0,0 +1,21 @@
+c quinn.cnf
+c
+p cnf 16 18
+ 1 2 0
+ -2 -4 0
+ 3 4 0
+ -4 -5 0
+ 5 -6 0
+ 6 -7 0
+ 6 7 0
+ 7 -16 0
+ 8 -9 0
+ -8 -14 0
+ 9 10 0
+ 9 -10 0
+-10 -11 0
+ 10 12 0
+ 11 12 0
+ 13 14 0
+ 14 -15 0
+ 15 16 0
diff --git a/src/tests/solve/dimacs/sat/simple_v3_c2.cnf b/src/tests/solve/dimacs/sat/simple_v3_c2.cnf
new file mode 100644
index 000000000..93f36fcb4
--- /dev/null
+++ b/src/tests/solve/dimacs/sat/simple_v3_c2.cnf
@@ -0,0 +1,5 @@
+c simple_v3_c2.cnf
+c
+p cnf 3 2
+1 -3 0
+2 3 -1 0
diff --git a/src/tests/solve/dimacs/unsat/anomaly_agetooold.cnf b/src/tests/solve/dimacs/unsat/anomaly_agetooold.cnf
new file mode 100644
index 000000000..5bb5254c5
--- /dev/null
+++ b/src/tests/solve/dimacs/unsat/anomaly_agetooold.cnf
@@ -0,0 +1,22 @@
+p cnf 20 21
+3 -2 0
+1 2 0
+4 -5 0
+6 4 0
+-6 7 0
+-8 -7 0
+8 -9 0
+10 9 0
+12 11 0
+13 -2 0
+-1 -14 0
+14 -12 15 0
+-7 16 0
+17 -12 0
+4 -13 18 0
+-11 19 0
+-18 -20 0
+-4 -17 0
+-16 -15 0
+-19 -11 0
+-10 20 0
diff --git a/src/tests/solve/dimacs/unsat/modus_ponens.cnf b/src/tests/solve/dimacs/unsat/modus_ponens.cnf
new file mode 100644
index 000000000..9ee720c86
--- /dev/null
+++ b/src/tests/solve/dimacs/unsat/modus_ponens.cnf
@@ -0,0 +1,6 @@
+c simple_v3_c2.cnf
+c
+p cnf 2 3
+1 0
+-1 2 0
+-2 0
diff --git a/src/tests/solve/dimacs/unsat/pigeon-1.cnf b/src/tests/solve/dimacs/unsat/pigeon-1.cnf
new file mode 100644
index 000000000..c27f94a3d
--- /dev/null
+++ b/src/tests/solve/dimacs/unsat/pigeon-1.cnf
@@ -0,0 +1,19 @@
+c pigeon-1: placing 2 pigeons into 1 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 2 3
+1 0
+2 0
+-1 -2 0
diff --git a/src/tests/solve/dimacs/unsat/pigeon-2.cnf b/src/tests/solve/dimacs/unsat/pigeon-2.cnf
new file mode 100644
index 000000000..b46ad69c8
--- /dev/null
+++ b/src/tests/solve/dimacs/unsat/pigeon-2.cnf
@@ -0,0 +1,25 @@
+c pigeon-2: placing 3 pigeons into 2 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 6 9
+1 2 0
+3 4 0
+5 6 0
+-1 -3 0
+-1 -5 0
+-3 -5 0
+-2 -4 0
+-2 -6 0
+-4 -6 0
diff --git a/src/tests/solve/dimacs/unsat/pigeon-3.cnf b/src/tests/solve/dimacs/unsat/pigeon-3.cnf
new file mode 100644
index 000000000..86113f2d5
--- /dev/null
+++ b/src/tests/solve/dimacs/unsat/pigeon-3.cnf
@@ -0,0 +1,38 @@
+c pigeon-3: placing 4 pigeons into 3 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 12 22
+1 2 3 0
+4 5 6 0
+7 8 9 0
+10 11 12 0
+-1 -4 0
+-1 -7 0
+-1 -10 0
+-4 -7 0
+-4 -10 0
+-7 -10 0
+-2 -5 0
+-2 -8 0
+-2 -11 0
+-5 -8 0
+-5 -11 0
+-8 -11 0
+-3 -6 0
+-3 -9 0
+-3 -12 0
+-6 -9 0
+-6 -12 0
+-9 -12 0
diff --git a/src/tests/solve/dimacs/unsat/pigeon-4.cnf b/src/tests/solve/dimacs/unsat/pigeon-4.cnf
new file mode 100644
index 000000000..436656c8c
--- /dev/null
+++ b/src/tests/solve/dimacs/unsat/pigeon-4.cnf
@@ -0,0 +1,61 @@
+c pigeon-4: placing 5 pigeons into 4 holes
+c
+c File generated by 'pigeonhole', (c) Tjark Weber
+c
+c The SAT encoding of this problem is very straightforward. For each pigeon i
+c and each hole j we have a variable x_{n*(i-1)+j} which means that pigeon i
+c is placed in hole j. Then we have n+1 clauses which say that a pigeon has
+c to be placed in some hole. Then for each hole we have a set of clauses
+c ensuring that only one single pigeon is placed into that hole.
+c
+c This encoding leads to a total of (n+1) * n propositional variables and
+c (n+1) + n * (n * (n+1) / 2) clauses.
+c
+c The resulting SAT problem is unsatisfiable.
+c
+p cnf 20 45
+1 2 3 4 0
+5 6 7 8 0
+9 10 11 12 0
+13 14 15 16 0
+17 18 19 20 0
+-1 -5 0
+-1 -9 0
+-1 -13 0
+-1 -17 0
+-5 -9 0
+-5 -13 0
+-5 -17 0
+-9 -13 0
+-9 -17 0
+-13 -17 0
+-2 -6 0
+-2 -10 0
+-2 -14 0
+-2 -18 0
+-6 -10 0
+-6 -14 0
+-6 -18 0
+-10 -14 0
+-10 -18 0
+-14 -18 0
+-3 -7 0
+-3 -11 0
+-3 -15 0
+-3 -19 0
+-7 -11 0
+-7 -15 0
+-7 -19 0
+-11 -15 0
+-11 -19 0
+-15 -19 0
+-4 -8 0
+-4 -12 0
+-4 -16 0
+-4 -20 0
+-8 -12 0
+-8 -16 0
+-8 -20 0
+-12 -16 0
+-12 -20 0
+-16 -20 0
diff --git a/src/tests/solve/smt_lra/sat/arith_merge_case_4.smt2 b/src/tests/solve/smt_lra/sat/arith_merge_case_4.smt2
new file mode 100644
index 000000000..94b0337eb
--- /dev/null
+++ b/src/tests/solve/smt_lra/sat/arith_merge_case_4.smt2
@@ -0,0 +1,14 @@
+(set-logic QF_LRA)
+(declare-fun z () Real)
+(assert
+ (let ((?3 3))
+ (let ((?n2 (+ z ?3)))
+ (let ((?2 2))
+ (let ((?n4 (= ?n2 ?2)))
+ (let ((?n5 (= z ?n2)))
+ (let ((?n7 (not ?n5)))
+ (let ((?n8 (and ?n4 ?n7)))
+ (let ((?n9 (not ?n8))) ?n9
+)))))))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_lra/sat/arith_zero_dom.smt2 b/src/tests/solve/smt_lra/sat/arith_zero_dom.smt2
new file mode 100644
index 000000000..86b63aa8e
--- /dev/null
+++ b/src/tests/solve/smt_lra/sat/arith_zero_dom.smt2
@@ -0,0 +1,11 @@
+(set-logic QF_LRA)
+(declare-fun v2 () Real)
+(declare-fun v1 () Real)
+(declare-fun b () Bool)
+(assert
+ (let ((?1 1) (?0 0))
+ (let ((?ite (ite b ?0 ?1)))
+ (let ((?n7 (= ?1 ?ite))) ?n7
+))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/sat/bad_conflict.smt2 b/src/tests/solve/smt_uf/sat/bad_conflict.smt2
new file mode 100644
index 000000000..55588b593
--- /dev/null
+++ b/src/tests/solve/smt_uf/sat/bad_conflict.smt2
@@ -0,0 +1,12 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(declare-sort S1 0)
+(declare-fun p0 ( S0) Bool)
+(declare-fun v0 () S0)
+(assert
+ (let ((?n1 true))
+ (let ((?n2 (p0 v0)))
+ (let ((?n3 (xor ?n1 ?n2))) ?n3
+))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/NEQ004_size4__decide_eq_us.smt2 b/src/tests/solve/smt_uf/unsat/NEQ004_size4__decide_eq_us.smt2
new file mode 100644
index 000000000..1dd30a3ad
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/NEQ004_size4__decide_eq_us.smt2
@@ -0,0 +1,23 @@
+(set-logic QF_UF)
+(set-info :status unknown)
+(declare-sort U 0)
+(declare-fun c15 () U)
+(declare-fun c_3 () U)
+(declare-fun c_2 () U)
+(declare-fun p8 ( U) Bool)
+(declare-fun c11 () U)
+(declare-fun c13 () U)
+(declare-fun c14 () U)
+(assert
+ (let ((?n2 (p8 c_2)))
+ (let ((?n3 (not ?n2)))
+ (let ((?n4 (p8 c_3)))
+ (let ((?n5 (not ?n4)))
+ (let ((?n8 (p8 c15)))
+ (let ((?n10 (= c_2 c15)))
+ (let ((?n11 (= c_3 c15)))
+ (let ((?n12 (or ?n10 ?n11)))
+ (let ((?n13 (and ?n3 ?n5 ?n8 ?n12))) ?n13
+))))))))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/deltaed0.smt2 b/src/tests/solve/smt_uf/unsat/deltaed0.smt2
new file mode 100644
index 000000000..186f05bf5
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/deltaed0.smt2
@@ -0,0 +1,20 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(declare-sort S1 0)
+(declare-fun p0 ( S0) Bool)
+(declare-fun v0 () S0)
+(declare-fun v1 () S1)
+(declare-fun v2 () S1)
+(assert
+ (let ((?n1 (= v2 v1)))
+ (let ((?n2 (ite ?n1 v0 v0)))
+ (let ((?n3 (p0 ?n2)))
+ (let ((?n4 false))
+ (let ((?n5 (p0 v0)))
+ (let ((?n6 (= ?n4 ?n5)))
+ (let ((?n7 (xor ?n4 ?n6)))
+ (let ((?n8 (xor ?n4 ?n7)))
+ (let ((?n9 (= ?n3 ?n8))) ?n9
+))))))))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/diff_to_value_for_bool.smt2 b/src/tests/solve/smt_uf/unsat/diff_to_value_for_bool.smt2
new file mode 100644
index 000000000..186f05bf5
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/diff_to_value_for_bool.smt2
@@ -0,0 +1,20 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(declare-sort S1 0)
+(declare-fun p0 ( S0) Bool)
+(declare-fun v0 () S0)
+(declare-fun v1 () S1)
+(declare-fun v2 () S1)
+(assert
+ (let ((?n1 (= v2 v1)))
+ (let ((?n2 (ite ?n1 v0 v0)))
+ (let ((?n3 (p0 ?n2)))
+ (let ((?n4 false))
+ (let ((?n5 (p0 v0)))
+ (let ((?n6 (= ?n4 ?n5)))
+ (let ((?n7 (xor ?n4 ?n6)))
+ (let ((?n8 (xor ?n4 ?n7)))
+ (let ((?n9 (= ?n3 ?n8))) ?n9
+))))))))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/diff_value_substupfalse.smt2 b/src/tests/solve/smt_uf/unsat/diff_value_substupfalse.smt2
new file mode 100644
index 000000000..e6f5d14b5
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/diff_value_substupfalse.smt2
@@ -0,0 +1,14 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(declare-sort S1 0)
+(declare-fun p0 ( S0) Bool)
+(declare-fun v0 () S0)
+(assert
+ (let ((?n1 (p0 v0)))
+ (let ((?n2 false))
+ (let ((?n3 (= ?n2 ?n1)))
+ (let ((?n4 (xor ?n2 ?n3)))
+ (let ((?n5 (= ?n1 ?n4))) ?n5
+))))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/distinct.smt2 b/src/tests/solve/smt_uf/unsat/distinct.smt2
new file mode 100644
index 000000000..c0640415f
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/distinct.smt2
@@ -0,0 +1,10 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(assert
+ (let ((?n1 true))
+ (let ((?n2 false))
+ (let ((?n3 (xor ?n1 ?n2)))
+ (let ((?n4 (xor ?n1 ?n3))) ?n4
+)))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/eq_diamond2.smt2 b/src/tests/solve/smt_uf/unsat/eq_diamond2.smt2
new file mode 100644
index 000000000..e5fd59452
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/eq_diamond2.smt2
@@ -0,0 +1,20 @@
+(set-logic QF_UF)
+(set-info :source |
+Generating minimum transitivity constraints in P-time for deciding Equality Logic,
+Ofer Strichman and Mirron Rozanov,
+SMT Workshop 2005.
+
+Translator: Leonardo de Moura. |)
+(set-info :smt-lib-version 2.0)
+(set-info :category "crafted")
+(set-info :status unsat)
+(declare-sort U 0)
+(declare-fun x0 () U)
+(declare-fun y0 () U)
+(declare-fun z0 () U)
+(declare-fun x1 () U)
+(declare-fun y1 () U)
+(declare-fun z1 () U)
+(assert (and (or (and (= x0 y0) (= y0 x1)) (and (= x0 z0) (= z0 x1))) (not (= x0 x1))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/equality_norm_set.smt2 b/src/tests/solve/smt_uf/unsat/equality_norm_set.smt2
new file mode 100644
index 000000000..c5e38a47e
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/equality_norm_set.smt2
@@ -0,0 +1,12 @@
+(set-logic QF_UF)
+(declare-sort S1 0)
+(declare-sort S0 0)
+(declare-fun v0 () S0)
+(assert
+ (let ((?n1 true))
+ (let ((?n2 (ite ?n1 v0 v0)))
+ (let ((?n3 (= v0 ?n2)))
+ (let ((?n4 (xor ?n1 ?n3))) ?n4
+)))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/many_distinct.smt2 b/src/tests/solve/smt_uf/unsat/many_distinct.smt2
new file mode 100644
index 000000000..59f49c4ed
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/many_distinct.smt2
@@ -0,0 +1,37 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(declare-fun ?n1 () S0)
+(declare-fun ?n2 () S0)
+(declare-fun ?n3 () S0)
+(declare-fun ?n4 () S0)
+(declare-fun ?n5 () S0)
+(declare-fun ?b1 () Bool)
+(declare-fun ?b2 () Bool)
+(declare-fun ?b3 () Bool)
+
+(assert
+ (ite ?b1
+ (and
+ (distinct ?n1 ?n2)
+ (ite
+ ?b2
+ (and
+ (distinct ?n1 ?n3)
+ (distinct ?n2 ?n4)
+ (ite ?b3
+ (and
+ (= ?n1 ?n5)
+ (= ?n5 ?n2)
+ )
+ false
+ )
+ )
+ false
+ )
+ )
+ false
+ )
+ )
+
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/polyeq_genequality_deltaed.smt2 b/src/tests/solve/smt_uf/unsat/polyeq_genequality_deltaed.smt2
new file mode 100644
index 000000000..af542566c
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/polyeq_genequality_deltaed.smt2
@@ -0,0 +1,13 @@
+(set-logic QF_UF)
+(declare-sort S0 0)
+(declare-sort S1 0)
+(declare-fun p2 ( S0 S1) Bool)
+(declare-fun v1 () S1)
+(declare-fun v0 () S0)
+(assert
+ (let ((?n1 (p2 v0 v1)))
+ (let ((?n2 (not ?n1)))
+ (let ((?n3 (= ?n1 ?n2))) ?n3
+))))
+(check-sat)
+(exit)
diff --git a/src/tests/solve/smt_uf/unsat/xor.smt2 b/src/tests/solve/smt_uf/unsat/xor.smt2
new file mode 100644
index 000000000..916b434f5
--- /dev/null
+++ b/src/tests/solve/smt_uf/unsat/xor.smt2
@@ -0,0 +1,11 @@
+(set-logic QF_UF)
+(declare-fun _substvar_1662_ () Bool)
+(declare-fun _substvar_2244_ () Bool)
+(assert
+ (let ((e183 (xor _substvar_2244_ _substvar_2244_)))
+ (let ((e184 (not e183)))
+ (let ((e185 (= _substvar_1662_ _substvar_1662_)))
+ (let ((e186 (xor e184 e185)))
+ e186)))))
+(check-sat)
+
diff --git a/src/tests/test.ml b/src/tests/test.ml
new file mode 100644
index 000000000..779a2037e
--- /dev/null
+++ b/src/tests/test.ml
@@ -0,0 +1,26 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+let () =
+ (* let solver = Witan_core.Egraph.new_t () in *)
+ (* let d = Witan_core.Egraph. *)
+ (* Witan_theories_bool.Bool.th_register solver; *)
+ Format.printf "All tests OK ! (total: 0)@."
+
diff --git a/src/tests/tests.ml b/src/tests/tests.ml
new file mode 100644
index 000000000..ba008aa24
--- /dev/null
+++ b/src/tests/tests.ml
@@ -0,0 +1,142 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open OUnit
+open Witan_stdlib
+open Witan_core
+open Tests_lib
+
+
+let opt_seed = ref 0
+
+let print_seed fmt = function
+ | None -> Format.fprintf fmt "No"
+ | Some [|i|] -> Format.fprintf fmt "%i" i
+ | _ -> assert false
+
+let make_tests acc seed =
+ let test = ((Witan_popop_lib.Pp.sprintf "seed %a" print_seed seed) >:::
+ [ Tests_bool.tests; Tests_uf.tests; Tests_LRA.tests ])
+ in
+ let test = test_decorate
+ (fun f -> (fun () -> Shuffle.set_shuffle seed; f ())) test in
+ test::acc
+
+let tests () =
+ let l = Witan_popop_lib.Util.foldi (fun acc i -> make_tests acc (Some [|i|])) []
+ (!opt_seed + 1) (!opt_seed + 9)in
+ make_tests l None
+
+let tests () =
+ if Printexc.backtrace_status ()
+ then
+ (test_decorate
+ (fun f ->
+ fun () ->
+ try f ()
+ with exn ->
+ Format.fprintf (Witan_popop_lib.Debug.get_debug_formatter ()) "%s"
+ (Printexc.get_backtrace ());
+ raise exn
+ )) (TestList (tests ()))
+ else
+ (TestList (tests ()))
+
+(** From oUnit.ml v 1.2.2 *)
+(** just need to make the tests lazily computed *)
+
+(* 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
+
+
+(* Call this one from you test suites *)
+let run_test_tt_main ?(arg_specs=[]) suite =
+ let only_test = ref [] in
+ let () =
+ Arg.parse
+ (Arg.align
+ [
+ "-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 () = Witan_popop_lib.Debug.Args.set_flags_selected () in
+ let verbose = Witan_popop_lib.Debug.test_flag debug 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 = run_test_tt ~verbose nsuite in
+ if not (was_successful result) then
+ exit 1
+ else
+ result
+
+(*** End *)
+
+let () =
+ if not (Egraph.check_initialization () && Conflict.check_initialization ()) then
+ exit 1
+
+let _ =
+ try
+ run_test_tt_main
+ ~arg_specs:(["--seed",Arg.Set_int opt_seed,
+ " Base seed used for shuffling the arbitrary decision";
+ Witan_popop_lib.Debug.Args.desc_debug_all]@
+ Witan_popop_lib.Debug.Args.desc_debug)
+ tests
+ with e when not (Witan_popop_lib.Debug.test_flag Witan_popop_lib.Debug.stack_trace) ->
+ Format.eprintf "%a" Witan_popop_lib.Exn_printer.exn_printer e;
+ exit 1
diff --git a/src/tests/tests_LRA.ml b/src/tests/tests_LRA.ml
new file mode 100644
index 000000000..5dc64c2d2
--- /dev/null
+++ b/src/tests/tests_LRA.ml
@@ -0,0 +1,300 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open OUnit
+open Tests_lib
+open Witan_theories_bool
+open Witan_theories_LRA
+open Witan_solver
+open Witan_core
+open Witan_stdlib.Std
+open Witan_stdlib
+
+let theories = [Boolean.th_register; Equality.th_register; Uninterp.th_register; LRA.th_register]
+
+let ($$) f x = f x
+
+let run = Scheduler.run_exn ~nodec:() ~theories
+let run_dec = Scheduler.run_exn ?nodec:None ~theories
+let ($$) f x = f x
+
+(* The tests with rundec check only the result on a model satisfying
+ the hypothesis *)
+
+
+let solve0a () =
+ let a = fresh Term._Real "ar" in
+ let _1 = LRA.cst Q.one in
+ let a1 = LRA.add a _1 in
+ let env = run $$ fun env ->
+ register env a1; register env _1;
+ merge env a1 _1
+ in
+ assert_bool "a+1 = 1 => a = 0" (is_equal env a LRA.zero)
+
+(* let solve0b () =
+ * let a = fresh Term._Real "ar" in
+ * let _1 = LRA.cst Q.one in
+ * let _2 = LRA.cst Q.two in
+ * let _4 = LRA.cst (Q.of_int 4) in
+ * let a1 = LRA.add a _1 in
+ * let _2a2 = LRA.add' Q.two a Q.one _2 in
+ * let env = run $$ fun env ->
+ * List.iter (register env) [a1;_1;_2;_4;_2a2];
+ * merge env a1 _2
+ * in
+ * assert_bool "a+1 = 2 => 2*a+2 = 4" (is_equal env _2a2 _4) *)
+
+let solve0c () =
+ let a = fresh Term._Real "ar" in
+ let b = fresh Term._Real "br" in
+ let _1 = LRA.cst Q.one in
+ let a1 = LRA.add a _1 in
+ let b1 = LRA.add b _1 in
+ let env = run_dec $$ fun env ->
+ register env a1; register env b1;
+ merge env a1 b1
+ in
+ assert_bool "a+1 = b+1 => a = b" (is_equal env a b)
+
+let solve1 () =
+ let a,b = Shuffle.seq2 (fresh Term._Real) ("ar","br") in
+ let _1 = LRA.cst Q.one in
+ let a1 = LRA.add a _1 in
+ let b1 = LRA.add b _1 in
+ let _2 = LRA.cst (Q.of_int 2) in
+ let a2 = LRA.add a _2 in
+ let b2 = LRA.add b _2 in
+ let env = run_dec $$ fun env ->
+ Shuffle.seql' (register env) [a1; b1; a2; b2];
+ merge env a1 b1
+ in
+ assert_bool "a+1 = b+1 => a+2 = b+2" (is_equal env a2 b2)
+
+let solve2 () =
+ let a,b = Shuffle.seq2 (fresh Term._Real) ("ar","br") in
+ let _1 = LRA.cst Q.one in
+ let a1 = LRA.add a _1 in
+ let b1 = LRA.add b _1 in
+ let _2 = LRA.cst (Q.of_int 2) in
+ let a2 = LRA.add a _2 in
+ let b2 = LRA.add b _2 in
+ let env = run_dec $$ fun env ->
+ Shuffle.seql' (register env) [a1; b1; a2; b2];
+ merge env a2 b1
+ in
+ assert_bool "a+2 = b+1 => a+1 = b" (is_equal env a1 b)
+
+let solve3 () =
+ let a,b = Shuffle.seq2 (fresh Term._Real) ("ar","br") in
+ let _1 = LRA.cst Q.one in
+ let b1 = LRA.add b _1 in
+ let _2 = LRA.cst (Q.of_int 2) in
+ let a2 = LRA.add a _2 in
+ let _3 = LRA.cst (Q.of_int 3) in
+ let env = run $$ fun env ->
+ Shuffle.seql [
+ (fun () ->
+ Shuffle.seql' (register env) [b1;a2];
+ merge env a2 b1;
+ );
+ (fun () ->
+ Shuffle.seql' (register env) [a;_2];
+ merge env a _2;
+ );
+ (fun () ->
+ register env _3;
+ );
+ ]
+ in
+ assert_bool "" (not (is_equal env b _2));
+ assert_bool "a+2 = b+1 => a = 2 => b = 3" (is_equal env b _3)
+
+
+let solve4 () =
+ let a,b,c =
+ Shuffle.seq3 (fresh Term._Real) ("ar","br","cr") in
+ let t1 = LRA.cst (Q.of_int 2) in
+ let t1 = LRA.add t1 c in
+ let t1 = LRA.add a t1 in
+ let t1' = (LRA.cst (Q.of_int 1)) in
+ let t1' = LRA.add b t1' in
+ let t2 = a in
+ let t2' = LRA.cst (Q.of_int 2) in
+ let t2' = LRA.add t2' b in
+ let t3' = LRA.cst (Q.of_int (-3)) in
+ let env = run_dec $$ fun env ->
+ Shuffle.seql [
+ (fun () ->
+ Shuffle.seql' (register env) [t1;t1'];
+ merge env t1 t1');
+ (fun () ->
+ Shuffle.seql' (register env) [t2;t2'];
+ merge env t2 t2');
+ (fun () -> register env t3');
+ ]
+ in
+ assert_bool "a+(2+c) = b+1 => a = 2 + b => c = -3" (is_equal env c t3')
+
+
+let solve5 () =
+ let a = fresh Term._Real "ar" in
+ let b = fresh Term._Real "br" in
+ let c = fresh Term._Real "cr" in
+ let t1 = LRA.sub b c in
+ let t1 = LRA.add a t1 in
+ let t1' = (LRA.cst (Q.of_int 2)) in
+ let t2 = a in
+ let t2' = LRA.cst (Q.of_int 2) in
+ let t3 = LRA.add b c in
+ let t3' = LRA.add b b in
+ let env = run_dec $$ fun env ->
+ Shuffle.seql [
+ (fun () ->
+ Shuffle.seql' (register env) [t1;t1'];
+ merge env t1 t1');
+ (fun () ->
+ Shuffle.seql' (register env) [t2;t2'];
+ merge env t2 t2');
+ (fun () ->
+ Shuffle.seql' (register env) [t3;t3'];)
+ ]
+ in
+ assert_bool "a+(b-c) = 2 => a = 2 => b + c = 2b" (is_equal env t3 t3')
+
+
+let basic = "LRA.Basic" &:
+ [solve0a;
+ (* solve0b; *)
+ solve0c;
+ solve1;
+ solve2;
+ solve3;
+ solve4;
+ solve5
+ ]
+
+(* let mult0 () =
+ * let a = fresh Term._Real "ar" in
+ * let b = fresh Term._Real "br" in
+ * let t1 = LRA.sub a b in
+ * let t1' = LRA.mult a b in
+ * let t2 = a in
+ * let t2' = LRA.cst (Q.of_int 1) in
+ * let t3 = LRA.mult_cst (Q.of_int 2) b in
+ * let t3' = LRA.cst (Q.of_int 1) in
+ * let env = run $$ fun env ->
+ * Shuffle.seql [
+ * (fun () ->
+ * Shuffle.seql' (register env) [t1;t1'];
+ * merge env t1 t1');
+ * (fun () ->
+ * Shuffle.seql' (register env) [t2;t2'];
+ * merge env t2 t2');
+ * (fun () ->
+ * Shuffle.seql' (register env) [t3;t3'];)
+ * ]
+ * in
+ * assert_bool "a - b = a * b -> a = 1 -> 1 = 2b" (is_equal env t3 t3')
+ *
+ * (\** test that mult normalization trigger the needed solve *\)
+ * let mult1 () =
+ * let a = fresh Term._Real "ar" in
+ * let b = fresh Term._Real "br" in
+ * let c = fresh Term._Real "cr" in
+ * let t1 = LRA.mult a b in
+ * let t1 = LRA.add a t1 in
+ * let t1' = LRA.add b c in
+ * let t1' = LRA.mult t1' a in
+ * let t2 = a in
+ * let t2' = LRA.cst (Q.of_int 2) in
+ * let t3 = c in
+ * let t3' = LRA.cst (Q.of_int 1) in
+ * let env = run $$ fun env ->
+ * Shuffle.seql [
+ * (fun () ->
+ * Shuffle.seql' (register env) [t1;t1'];
+ * merge env t1 t1');
+ * (fun () ->
+ * Shuffle.seql' (register env) [t2;t2'];
+ * merge env t2 t2');
+ * (fun () ->
+ * Shuffle.seql' (register env) [t3;t3'];)
+ * ]
+ * in
+ * assert_bool "a + (a * b) = (b + c) * a -> a = 2 -> c = 1"
+ * (is_equal env t3 t3')
+ *
+ * let mult = "LRA.Mult" &: [mult0;mult1]
+ *
+ *
+ * let files = ["tests/tests_altergo_arith.split";
+ * "tests/tests_popop.split";
+ * "tests/tests_altergo_qualif.split"
+ * ]
+ *
+ * let altergo = TestList (List.map Tests_lib.test_split files)
+*)
+
+
+let check_file filename =
+ let statements = Witan_solver.Input.read
+ ~language:Witan_solver.Input.Smtlib
+ ~dir:(Filename.dirname filename)
+ (Filename.basename filename)
+ in
+ Witan_solver.Notypecheck.run ~theories ~limit:1000 statements
+
+let tests_smt2 expected dir =
+ if Sys.file_exists dir then
+ let files = Sys.readdir dir in
+ Array.sort String.compare files;
+ let files = Array.to_list files in
+ List.map
+ (fun s ->
+ s >: TestCase (fun () ->
+ begin match check_file (Filename.concat dir s) with
+ | `Sat ->
+ Witan_popop_lib.Debug.dprintf1 Tests_lib.debug "@[%s: Sat@]" s;
+ assert_bool s (`Sat = expected)
+ | `Unsat ->
+ Witan_popop_lib.Debug.dprintf1 Tests_lib.debug "@[%s: Unsat@]" s;
+ assert_bool s (`Unsat = expected)
+ | exception Witan_solver.Notypecheck.Typing_error (msg, t) ->
+ assert_string
+ (Format.asprintf
+ "%a:@\n%s:@ %a"
+ Dolmen.ParseLocation.fmt (Witan_solver.Notypecheck.get_loc t) msg
+ Dolmen.Term.print t
+ )
+ end;
+ )) files
+ else
+ []
+
+let smtlib2sat =
+ "smtlib2-lra-sat" >:::
+ tests_smt2 `Sat "solve/smt_lra/sat/"
+
+let smtlib2unsat =
+ "smtlib2-lra-unsat" >:::
+ tests_smt2 `Unsat "solve/smt_lra/unsat/"
+
+let tests = TestList [basic;(* (\* mult;*\)altergo;*) (* smtlib2sat; smtlib2unsat *)]
diff --git a/src/tests/tests_bool.ml b/src/tests/tests_bool.ml
new file mode 100644
index 000000000..ae7b9bf84
--- /dev/null
+++ b/src/tests/tests_bool.ml
@@ -0,0 +1,186 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open OUnit
+open Witan_stdlib
+open Witan_core
+open Tests_lib
+open Witan_theories_bool
+
+let theories = [(* Uninterp.th_register; *) Boolean.th_register]
+
+let ($$) f x = f x
+
+let run = Tests_lib.run_exn ~theories
+
+let bool_interp () =
+ let ta = Term.const (Id.mk "a" Boolean.ty) in
+ let tb = Term.const (Id.mk "b" Boolean.ty) in
+ let tc = Term.const (Id.mk "c" Boolean.ty) in
+ let to_n x = SynTerm.node_of_term x in
+ let na = to_n ta in
+ let nb = to_n tb in
+ let nc = to_n tc in
+ let leaf ~a ~b ~c t =
+ if Term.equal t ta
+ then Some (Value.index Boolean.dom a Boolean.ty)
+ else if Term.equal t tb
+ then Some (Value.index Boolean.dom b Boolean.ty)
+ else if Term.equal t tc
+ then Some (Value.index Boolean.dom c Boolean.ty)
+ else None
+ in
+ let l = [
+ "true", Boolean._true, true, (fun _-> None);
+ "false", Boolean._false, false, (fun _-> None);
+ "or(a,b,c)", Boolean._or [na;nb;nc], false, leaf ~a:false ~b:false ~c:false;
+ "or(a,b,c)", Boolean._or [na;nb;nc], true, leaf ~a:false ~b:true ~c:false;
+ "not(or(a,not b,and(c,c)))",
+ Boolean.gen true [na,false;nb,true;(Boolean._and [nc;nc]),false], true, leaf ~a:false ~b:true ~c:false;
+ ]
+ in
+ let test (msg,n,v,leaf) =
+ let v' = Interp.node ~leaf n in
+ match Value.value Boolean.dom v' with
+ | None -> assert_failure (Printf.sprintf "Not a value of type bool: %s" msg)
+ | Some v' -> assert_bool msg (v = v')
+ in
+ List.iter test l
+
+let true_is_true () =
+ let env = run (fun _ -> ()) in
+ assert_bool "" (Boolean.is_true env Boolean._true);
+ assert_bool "" (not (Boolean.is_false env Boolean._true))
+
+let not_true_is_false () =
+ let not_true = Boolean._not Boolean._true in
+ let env = run $$ fun env -> Egraph.register env not_true in
+ assert_bool "" (Boolean.is_false env not_true);
+ assert_bool "" (not (Boolean.is_true env not_true))
+
+let and_true_is_true () =
+ let _t = Boolean._true in
+ let _and = Boolean._and [_t;_t;_t] in
+ let env = run $$ fun env -> Egraph.register env _and in
+ assert_bool "" (Boolean.is_true env _and);
+ assert_bool "" (not (Boolean.is_false env _and))
+
+let or_not_true_is_false () =
+ let _f = (Boolean._not Boolean._true) in
+ let _or = Boolean._and [_f;_f;_f] in
+ let env = run $$ fun env -> Egraph.register env _or in
+ assert_bool "" (Boolean.is_false env _or);
+ assert_bool "" (not (Boolean.is_true env _or))
+
+let merge_true () =
+ let a = fresh Boolean.ty "a" in
+ let b = fresh Boolean.ty "b" in
+ let c = fresh Boolean.ty "c" in
+ let d = fresh Boolean.ty "d" in
+ let _and = Boolean._and [a;b;c] in
+ let env = run $$ fun env ->
+ Egraph.register env _and;
+ List.iter (Egraph.register env) [a;b;c;d];
+ Shuffle.seql
+ [(fun () -> merge env a b);
+ (fun () -> merge env a c);
+ ];
+ merge env a d;
+ Boolean.set_true env Trail.pexp_fact d;
+ in
+ assert_bool "" (Boolean.is_true env _and)
+
+let imply_implies () =
+ let a = Term.const (Id.mk "a" Term._Prop) in
+ let b = Term.const (Id.mk "b" Term._Prop) in
+ let t = Term.apply Term.imply_term [a;b] in
+ let an = SynTerm.node_of_term a in
+ let bn = SynTerm.node_of_term b in
+ let tn = SynTerm.node_of_term t in
+ let env = run $$ fun env ->
+ Egraph.register env tn;
+ Boolean.set_true env Trail.pexp_fact tn;
+ Egraph.register env an;
+ Boolean.set_true env Trail.pexp_fact an;
+ in
+ assert_bool "" (Boolean.is_true env bn)
+
+let basic = "Boolean.Basic" >::: [ "bool_interp" >:: bool_interp;
+ "true_is_true" >:: true_is_true;
+ "not_true_is_false" >:: not_true_is_false;
+ "and_true_is_true" >:: and_true_is_true;
+ "or_not_true_is_false" >:: or_not_true_is_false;
+ "merge_true" >:: merge_true;
+ "imply_implies" >:: imply_implies;
+ (* "modus_ponens" >:: modus_ponens; *)
+ ]
+
+
+let check_file filename =
+ let statements = Witan_solver.Input.read
+ ~language:Witan_solver.Input.Dimacs
+ ~dir:(Filename.dirname filename)
+ (Filename.basename filename)
+ in
+ try
+ Witan_solver.Notypecheck.run ~theories ~limit:1000 statements
+ with
+ | Witan_solver.Notypecheck.Typing_error (msg, t) ->
+ assert_failure
+ (Format.asprintf
+ "%a:@\n%s:@ %a"
+ Dolmen.ParseLocation.fmt (Witan_solver.Notypecheck.get_loc t) msg
+ Dolmen.Term.print t
+ )
+
+let tests_dimacs expected dir =
+ let files = Sys.readdir dir in
+ Array.sort String.compare files;
+ let files = Array.to_list files in
+ List.map
+ (fun s ->
+ s >: TestCase (fun () ->
+ let res = check_file (Filename.concat dir s) in
+ begin match res with
+ | `Sat -> Witan_popop_lib.Debug.dprintf1 Tests_lib.debug "@[%s: Sat@]" s
+ | `Unsat -> Witan_popop_lib.Debug.dprintf1 Tests_lib.debug "@[%s: Unsat@]" s
+ end;
+ assert_bool s (res = expected);
+ )) files
+
+let dimacssat =
+ "dimacs-sat" >::: tests_dimacs `Sat "solve/dimacs/sat/"
+
+let dimacsunsat =
+ "dimacs-unsat" >::: tests_dimacs `Unsat "solve/dimacs/unsat/"
+
+let tests = TestList [basic; dimacssat;dimacsunsat]
+
+
+let () = Witan_popop_lib.Exn_printer.register (fun fmt exn ->
+ match exn with
+ | Dolmen.ParseLocation.Syntax_error(l,"") ->
+ Format.fprintf fmt "%a: syntax error."
+ Dolmen.ParseLocation.fmt l
+ | Dolmen.ParseLocation.Syntax_error(l,c) ->
+ Format.fprintf fmt "%a: syntax error %s."
+ Dolmen.ParseLocation.fmt l c
+ | exn -> raise exn
+ )
diff --git a/src/tests/tests_lib.ml b/src/tests/tests_lib.ml
new file mode 100644
index 000000000..d6a34c68f
--- /dev/null
+++ b/src/tests/tests_lib.ml
@@ -0,0 +1,68 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open OUnit
+open Witan_popop_lib
+open Witan_core
+
+let debug = Debug.register_flag
+ ~desc:" Run the test in verbose mode." "ounit"
+
+let fresh ty s = SynTerm.node_of_term (Term.const (Id.mk s ty))
+
+let (&:) s l = s >::: (List.map (fun f -> TestCase f) l)
+
+let register d cl =
+ Egraph.register d cl;
+ Egraph.Backtrackable.flush d
+
+let merge d cl1 cl2 =
+ Egraph.merge d Trail.pexp_fact cl1 cl2;
+ Egraph.Backtrackable.flush d
+
+let is_equal = Egraph.is_equal
+
+(** without decisions *)
+type t =
+ { wakeup_daemons : Events.Wait.daemon_key Queue.t;
+ solver_state : Egraph.Backtrackable.t;
+ context : Witan_stdlib.Context.context;
+ }
+
+
+let new_solver () =
+ let context = Witan_stdlib.Context.create () in
+ {
+ wakeup_daemons = Queue.create ();
+ solver_state = Egraph.Backtrackable.new_t (Witan_stdlib.Context.creator context);
+ context;
+ }
+
+let new_delayed t =
+ let sched_daemon dem = Queue.push dem t.wakeup_daemons in
+ let sched_decision _ = () in
+ Egraph.Backtrackable.new_delayed ~sched_daemon ~sched_decision t.solver_state
+
+exception ReachStepLimit
+exception Contradiction
+
+let run_exn = Witan_solver.Scheduler.run_exn
+
+let fresh ty s = SynTerm.node_of_term (Term.const (Id.mk s ty))
diff --git a/tests/tests_uf.ml b/src/tests/tests_uf.ml
similarity index 64%
rename from tests/tests_uf.ml
rename to src/tests/tests_uf.ml
index 7e1c675de..9359afc2d 100644
--- a/tests/tests_uf.ml
+++ b/src/tests/tests_uf.ml
@@ -1,22 +1,42 @@
-open OUnit
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open OUnit
+open Witan_core
open Tests_lib
-open Scheduler
+open Witan_theories_bool
-let theories = [Variable.th_register; Uninterp.th_register]
-let run = Scheduler.run_exn ~nodec:() ~theories
+let theories = [Boolean.th_register; Equality.th_register; Uninterp.th_register ]
+let run = Tests_lib.run_exn ~theories ~nodec:()
let ($$) f x = f x
-let a = Variable.fresh ty "a"
-let b = Variable.fresh ty "b"
-let c = Variable.fresh ty "c"
-
+let a = SynTerm.node_of_term (Term.const (Id.mk "a" Boolean.ty))
+let b = SynTerm.node_of_term (Term.const (Id.mk "b" Boolean.ty))
+let c = SynTerm.node_of_term (Term.const (Id.mk "c" Boolean.ty))
let empty () =
let env = run $$ fun env ->
register env a; register env b;
in
- assert_bool "a != b" (not (is_equal env a b))
+ assert_bool "⊬ a == b" (not (is_equal env a b))
let tauto () =
let env = run $$ fun env ->
@@ -26,6 +46,14 @@ let tauto () =
assert_bool "a = b => a = b"
(is_equal env a b)
+let tauto_equal () =
+ let env = run $$ fun env ->
+ register env a; register env b;
+ merge env a b;
+ in
+ assert_bool "a = b => a = b"
+ (is_equal env a b)
+
let trans () =
let env = run $$ fun env ->
register env a; register env b; register env c;
@@ -44,7 +72,7 @@ let noteq () =
let basic = "Uf.Basic" >::: ["empty" >:: empty; "tauto" >:: tauto;
"trans" >:: trans; "noteq" >:: noteq]
-
+(*
let f = Uninterp.fun1 ty "f"
let fa = f a
let fb = f b
@@ -241,19 +269,53 @@ let altergo2 () =
let altergo = "Uf.altergo tests" &: [altergo0; altergo1; altergo2]
-let files = ["tests/tests_altergo_qualif.split"]
+let files = []
let altergo2 = TestList (List.map Tests_lib.test_split files)
+*)
+
+
+let check_file filename =
+ let statements = Witan_solver.Input.read
+ ~language:Witan_solver.Input.Smtlib
+ ~dir:(Filename.dirname filename)
+ (Filename.basename filename)
+ in
+ try
+ Witan_solver.Notypecheck.run ~theories ~limit:1000 statements
+ with
+ | Witan_solver.Notypecheck.Typing_error (msg, t) ->
+ assert_failure
+ (Format.asprintf
+ "%a:@\n%s:@ %a"
+ Dolmen.ParseLocation.fmt (Witan_solver.Notypecheck.get_loc t) msg
+ Dolmen.Term.print t
+ )
+
+let tests_smt2 expected dir =
+ let files = Sys.readdir dir in
+ Array.sort String.compare files;
+ let files = Array.to_list files in
+ List.map
+ (fun s ->
+ s >: TestCase (fun () ->
+ let res = check_file (Filename.concat dir s) in
+ begin match res with
+ | `Sat -> Witan_popop_lib.Debug.dprintf1 Tests_lib.debug "@[%s: Sat@]" s
+ | `Unsat -> Witan_popop_lib.Debug.dprintf1 Tests_lib.debug "@[%s: Unsat@]" s
+ end;
+ assert_bool s (res = expected);
+ )) files
+
let smtlib2sat =
"smtlib2-uf-sat" >:::
- tests_smt2 Popop_of_smtlib2.Sat "tests/smtlib2/uf/sat/"
+ tests_smt2 `Sat "solve/smt_uf/sat/"
let smtlib2unsat =
"smtlib2-uf-unsat" >:::
- tests_smt2 Popop_of_smtlib2.Unsat "tests/smtlib2/uf/unsat/"
-
+ tests_smt2 `Unsat "solve/smt_uf/unsat/"
-let tests = TestList [basic;congru1;congru2;altergo;altergo2;
- smtlib2sat;smtlib2unsat]
+let tests = TestList [basic;(* congru1;congru2;altergo;altergo2;*)
+ smtlib2sat; smtlib2unsat]
diff --git a/src/theories/LRA/LRA.ml b/src/theories/LRA/LRA.ml
new file mode 100644
index 000000000..be09e0f9f
--- /dev/null
+++ b/src/theories/LRA/LRA.ml
@@ -0,0 +1,1123 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+(** This module use one domain and two semantic values. *)
+open Witan_popop_lib
+open Witan_core
+open Witan_stdlib.Std
+
+let debug = Debug.register_info_flag
+ ~desc:"for the arithmetic theory"
+ "LRA"
+
+let real = ValueKind.create_key (module struct type t = Q.t let name = "Q" end)
+
+module RealValue = ValueKind.Register(struct
+ include Q
+ let key = real
+ end)
+
+let cst' c = RealValue.index ~basename:(Format.asprintf "%aR" Q.pp c) c Term._Real
+let cst c = RealValue.node (cst' c)
+
+let debug_todo = debug
+type bound = Interval_sig.bound = Strict | Large
+ [@@deriving eq,ord,show]
+module S = struct
+ module T = struct
+ type t =
+ | Add of Q.t * Node.t * Q.t * Node.t
+ | GZero of Node.t * bound
+ | Conflict of Polynome.t * bound
+ [@@ deriving eq,ord]
+
+ let pp fmt = function
+ | Add (q1,cl1,q2,cl2) ->
+ let pp fmt (q,node) =
+ if Q.equal q Q.one then Node.pp fmt node else
+ if Q.equal q Q.minus_one
+ then Format.fprintf fmt "-%a" Node.pp node
+ else Format.fprintf fmt "%a%a" Q.pp q Node.pp node
+ in
+ if Q.equal q2 Q.minus_one
+ then Format.fprintf fmt "%a - %a" pp (q1,cl1) Node.pp cl2
+ else Format.fprintf fmt "%a + %a" pp (q1,cl1) pp (q2,cl2)
+ | GZero (node,b) ->
+ Format.fprintf fmt "0 %a %a" Interval.pp_bound b Node.pp node
+ | Conflict (p,b) ->
+ Format.fprintf fmt "0 %a %a" Interval.pp_bound b Polynome.pp p
+
+ let hash = function
+ | Add (q1,cl1,q2,cl2) ->
+ 7 * (2*(Hashtbl.hash q1) + 3*Node.hash cl1
+ + 5*(Hashtbl.hash q2) + 7*Node.hash cl2) + 1
+ | GZero (node,Strict) -> 7 * Node.hash node + 2
+ | GZero (node,Large) -> 7 * Node.hash node + 3
+ | Conflict(p,Strict) -> CCHash.combine2 (Polynome.hash p) 4
+ | Conflict(p,Large) -> CCHash.combine2 (Polynome.hash p) 5
+
+ end
+ include T
+ include Popop_stdlib.MkDatatype(T)
+ let key = ThTermKind.create_key (module struct type nonrec t = t let name = "SARITH" end)
+end
+
+module SE = ThTermKind.Register(S)
+
+module D = Interval.Convexe
+
+let dom = DomKind.create_key (module struct type t = D.t let name = "ARITH" end)
+
+type exp =
+ | ExpAdd of SE.t * Node.t (** on what we propagated *)
+ | ExpEmptyDomMerge of Trail.Pexp.t * Node.t * Node.t
+ | ExpEmptyDomInter of Trail.Pexp.t * Node.t
+ | ExpDistIsZero of SE.t
+ | ExpGZeroUp of SE.t * bool
+ | ExpGZeroDown of SE.t * Node.t * bool
+ | ExpIsSingleton of Trail.Pexp.t * Node.t
+ * bool (* the domain of node *) * RealValue.t
+ | ExpCst of RealValue.t
+ | ExpDec of Node.t * Q.t
+[@@ deriving show]
+
+(** The explanation for a dom will always work on conflict which is an inequality *)
+
+let exp = Trail.Exp.create_key (module struct type t = exp let name = "LRA.exp" end)
+
+let set_dom d pexp node v b =
+ match D.is_singleton v with
+ | Some q ->
+ let cst = cst' q in
+ let pexp = Egraph.mk_pexp d exp (ExpIsSingleton(pexp,node,b,cst)) in
+ Egraph.set_value d pexp node (RealValue.nodevalue cst)
+ | None ->
+ (** the pexp must be in the dom *)
+ Egraph.set_dom d dom node v
+
+let minus_or_one inv =
+ if inv then Q.minus_one else Q.one
+
+let print_bag_node = Bag.pp Format.(const char ',') Node.pp
+
+let () = DomKind.register(module struct
+ include D
+ let key = dom
+ let merged i1 i2 =
+ match i1, i2 with
+ | None, None -> true
+ | Some i1, Some i2 -> D.equal i1 i2
+ | _ -> false
+
+ let merge d pexp (i1,cl1) (i2,cl2) _ =
+ assert (not (Egraph.is_equal d cl1 cl2));
+ match i1, cl1, i2, cl2 with
+ | Some i1,_, Some i2,_ ->
+ begin match D.inter i1 i2 with
+ | None ->
+ let pexp = Egraph.mk_pexp d exp (ExpEmptyDomMerge(pexp,cl1,cl2)) in
+ Egraph.contradiction d pexp
+ | Some i ->
+ if not (D.equal i i1) then
+ Egraph.set_dom d dom cl1 i;
+ if not (D.equal i i2) then
+ Egraph.set_dom d dom cl2 i
+ end
+ | Some i1, _, _, cl2 | _, cl2, Some i1, _ ->
+ Egraph.set_dom d dom cl2 i1
+ | None,_,None,_ -> raise Impossible
+ end)
+
+module DaemonPropa = struct
+ let key = Demon.Fast.create "LRA.DaemonPropa"
+
+ module Data = SE
+
+ let immediate = false
+ let throttle = 100
+
+ let gt_zero = D.gt Q.zero
+ let ge_zero = D.ge Q.zero
+ let lt_zero = D.lt Q.zero
+ let le_zero = D.le Q.zero
+
+ let get_dom del node = Opt.get_def D.reals (Egraph.get_dom del dom node)
+ let get_value del node =
+ match Egraph.get_value del real node with
+ | None -> D.reals
+ | Some d -> D.singleton d
+
+ let upd del node d d' pexp =
+ match D.inter d d' with
+ | None ->
+ let pexp = Egraph.mk_pexp del exp pexp in
+ let pexp = Egraph.mk_pexp del exp (ExpEmptyDomInter(pexp,node)) in
+ Debug.dprintf6 debug "[LRA] upd node = %a d = %a d' = %a"
+ Node.pp node D.pp d D.pp d';
+ Egraph.contradiction del pexp
+ | Some d' ->
+ if not (D.equal d d')
+ then set_dom del (Egraph.mk_pexp del exp pexp) node d'
+ (Equal.option Q.equal (D.is_singleton d') None)
+
+ let upd_value del node d d' pexp =
+ match D.inter d d' with
+ | None ->
+ let pexp = Egraph.mk_pexp del exp pexp in
+ let pexp = Egraph.mk_pexp del exp (ExpEmptyDomInter(pexp,node)) in
+ Debug.dprintf6 debug "[LRA] upd node = %a d = %a d' = %a"
+ Node.pp node D.pp d D.pp d';
+ Egraph.contradiction del pexp
+ | Some d' ->
+ if not (D.equal d d')
+ then set_dom del (Egraph.mk_pexp del exp pexp) node d'
+ (Equal.option Q.equal (D.is_singleton d') None)
+
+ let propagate del s =
+ match SE.sem s with
+ | S.Add(q1,cl1,q2,cl2) ->
+ let cl0 = SE.node s in
+ let d0 = get_value del cl0 in
+ if Q.equal q1 Q.one && Q.equal q2 Q.minus_one &&
+ D.equal d0 D.zero then
+ let pexp = Egraph.mk_pexp del exp (ExpDistIsZero(s)) in
+ Egraph.merge del pexp cl1 cl2
+ else
+ let d1 = get_value del cl1 in
+ let d2 = get_value del cl2 in
+ let upd_value node d d' = upd_value del node d d' (ExpAdd(s,node)) in
+ let qd1 = D.mult_cst q1 d1 in
+ let qd2 = D.mult_cst q2 d2 in
+ upd_value cl0 d0 (D.add qd1 qd2);
+ upd_value cl1 d1 (D.mult_cst (Q.inv q1) (D.minus d0 qd2));
+ upd_value cl2 d2 (D.mult_cst (Q.inv q2) (D.minus d0 qd1))
+ | S.GZero(node,b) -> begin
+ let cl0 = SE.node s in
+ let d = get_value del node in
+ let dzero_true = if equal_bound b Strict then gt_zero else ge_zero in
+ let dzero_false = if equal_bound b Strict then le_zero else lt_zero in
+ if D.is_included d dzero_true
+ then begin
+ let pexp = Egraph.mk_pexp del exp (ExpGZeroUp(s,true)) in
+ Boolean.set_true del pexp cl0
+ end
+ else if D.is_included d dzero_false
+ then
+ let pexp = Egraph.mk_pexp del exp (ExpGZeroUp(s,false)) in
+ Boolean.set_false del pexp cl0
+ end
+ | S.Conflict(p,b) ->
+ (** Choose representative of the equivalence class among the
+ present classes, not the current representative *)
+ let repr = Polynome.fold (fun acc node _ ->
+ Node.M.add (Egraph.find del node) node acc)
+ Node.M.empty p in
+ let p' = Polynome.fold (fun acc node q ->
+ let node = Egraph.find del node in
+ let node = Node.M.find_exn Impossible node repr in
+ Polynome.add acc (Polynome.monome q node)
+ )
+ (Polynome.cst p.cst)
+ p in
+ let rec aux d_first = function
+ | [] -> begin
+ let cl0 = SE.node s in
+ if Equal.option Q.equal (D.is_singleton d_first) None then
+ let d = d_first in
+ let dzero_true = if equal_bound b Strict then gt_zero else ge_zero in
+ let dzero_false = if equal_bound b Strict then le_zero else lt_zero in
+ if D.is_included d dzero_true
+ then begin
+ let pexp = Egraph.mk_pexp del exp (ExpGZeroUp(s,true)) in
+ Boolean.set_true del pexp cl0;
+ raise Exit
+ end
+ else if D.is_included d dzero_false
+ then
+ let pexp = Egraph.mk_pexp del exp (ExpGZeroUp(s,false)) in
+ Boolean.set_false del pexp cl0;
+ raise Exit
+ else
+ assert false
+ else
+ match Boolean.is del cl0 with
+ | Some nonot ->
+ let dzero = if equal_bound b Strict
+ then if nonot then gt_zero else le_zero
+ else if nonot then ge_zero else lt_zero in
+ dzero,nonot
+ | None ->
+ raise Exit
+ end
+ | (node,q)::l ->
+ let d = get_dom del node in
+ let d' = (D.mult_cst q d) in
+ let d_last,b = aux (D.add d' d_first) l in
+ Debug.dprintf6 debug "node=%a d_first=%a d_last=%a"
+ Node.pp node D.pp d_first D.pp d_last;
+ let upd node d d' = upd del node d d' (ExpGZeroDown(s,node,b)) in
+ upd node d (D.mult_cst (Q.inv q) (D.minus d_last d_first));
+ D.minus d_last d', b
+ in
+ try
+ ignore (aux (D.singleton p'.cst) (Node.M.bindings p'.poly))
+ with Exit -> ()
+
+ let wakeup del = function
+ | Events.Fired.EventValue(_,_,s)
+ | Events.Fired.EventDom(_,_,s) ->
+ propagate del s
+ | Events.Fired.EventChange(_,s) ->
+ propagate del s
+ | _ -> raise UnwaitedEvent
+
+ let init del s =
+ begin match SE.sem s with
+ | S.Add (_,cl1,_,cl2) ->
+ Debug.dprintf2 debug "TOTO: %a" SE.pp s;
+ Egraph.register del cl1; Egraph.register del cl2;
+ Demon.Fast.attach del key
+ [Demon.Create.EventValue(SE.node s, real, s);
+ Demon.Create.EventValue(cl1, real, s);
+ Demon.Create.EventValue(cl2, real, s);
+ ]
+ | GZero (node,_) ->
+ Egraph.register del node;
+ Demon.Fast.attach del key
+ [Demon.Create.EventValue(SE.node s, Boolean.dom, s);
+ Demon.Create.EventValue(node, real, s)]
+ | Conflict(p,_) ->
+ Demon.Fast.attach del key
+ [Demon.Create.EventValue(SE.node s, Boolean.dom, s)];
+ Polynome.iter (fun node _ ->
+ Egraph.register del node;
+ Demon.Fast.attach del key
+ [Demon.Create.EventValue(node, real, s);
+ Demon.Create.EventChange(node, s);
+ ]
+ ) p
+ end;
+ propagate del s;
+end
+
+module RDaemonPropa = Demon.Fast.Register(DaemonPropa)
+
+let zero = cst Q.zero
+let one = cst Q.one
+let index s = SE.index s Term._Real
+
+let add' q1 cl1 q2 cl2 =
+ let norm q node = if Q.equal q Q.zero then Q.one, zero else q, node in
+ let q1, cl1 = norm q1 cl1 in
+ let q2, cl2 = norm q2 cl2 in
+ if Q.leq q2 q1 then
+ index (S.Add(q1,cl1,q2,cl2))
+ else
+ index (S.Add(q2,cl2,q1,cl1))
+
+let of_poly p =
+ let m, c = Polynome.get_tree p in
+ let rec aux = function
+ | Polynome.Empty -> `None
+ | Node(left,node,q,right,_) ->
+ let left = aux left in
+ let right = aux right in
+ let r =
+ match left, right with
+ | `Some (lq,l), `Some (rq,r) ->
+ `Some(Q.one,SE.node (add' lq l rq r))
+ | `None, r | r, `None -> r
+ in
+ match r with
+ | `None -> `Some(q,node)
+ | `Some(rq,r) -> `Some(Q.one,SE.node (add' q node rq r))
+ in
+ match aux m with
+ | `None -> cst c
+ | `Some(rq,r) when Q.equal rq Q.one && Q.equal c Q.zero -> r
+ | `Some(rq,r) -> SE.node (add' rq r c one)
+
+let to_poly = function
+ | S.Add(q1,cl1,q2,cl2) -> Polynome.of_list Q.one [cl1,q1;cl2,q2]
+ | Conflict (p,_) -> p
+ | GZero _ -> raise Impossible
+
+let choarith =
+ Trail.Cho.create_key (module struct type t = Node.t let name = "LRA.cho" end)
+
+let make_dec node = Trail.GCho(node,choarith,node)
+
+(** Choice *)
+(*
+(** Conflict *)
+(** Reason of equalities between arithmetical terms
+ exp: with all the decisions and propagation applied
+ imp: without any decision and propagation applied
+*)
+type conpoly = {imp : Polynome.t; exp : Polynome.t; bound: bound;
+ deps: Deps.t [@printer (fun _ _ -> ())]}
+let pp_conpoly fmt x =
+ Format.fprintf fmt "0 %s@ %a@ (%a)"
+ (match x.bound with | Strict -> "<" | Large -> "<=")
+ Polynome.pp x.imp
+ Polynome.pp x.exp
+let pp_conpoly' fmt x =
+ Format.fprintf fmt "%a@ (%a)@ %s 0"
+ Polynome.pp x.imp
+ Polynome.pp x.exp
+ (match x.bound with | Strict -> "<" | Large -> "<=")
+
+type conpair = {mi: conpoly option; ma:conpoly option}
+(** used as [0 <= x + P = mi /\ x + P = ma <= 0] *)
+let pp_conpair fmt = function
+ | {mi=None; ma=None} -> Format.fprintf fmt "None"
+ | {mi=Some mi;ma=None} -> pp_conpoly fmt mi
+ | {mi=None;ma=Some ma} -> pp_conpoly' fmt ma
+ | {mi=Some mi;ma=Some ma} ->
+ Format.fprintf fmt "%a@,â‹€ %a" pp_conpoly mi pp_conpoly' ma
+
+let interp_conpoly d p =
+ let acc = Node.M.fold_left (fun acc node q ->
+ let v = Opt.get_def D.reals (Egraph.get_dom d dom node) in
+ D.add (D.mult_cst q v) acc
+ ) D.zero p.imp.Polynome.poly in
+ let acc = D.add_cst p.imp.cst acc in
+ let good =
+ if p.bound = Strict then DaemonPropa.gt_zero
+ else DaemonPropa.ge_zero
+ in
+ match D.inter acc good with
+ | None -> Conflict.False
+ | Some i when D.equal i acc -> Conflict.True
+ | Some _ -> Conflict.ToDecide
+
+let condom : conpair Trail.con = Trail.Con.create_key "LRA.dom"
+
+(** Return the corresponding bound *)
+let get_exp_conpoly {exp={Polynome.cst}} = Q.neg cst
+
+let mk_conpoly p = {imp = p; exp = p; bound=Large; deps = Deps.empty}
+let mk_conpair p = let p = mk_conpoly p in {mi = Some p; ma = Some p}
+let zero_conpoly = mk_conpoly Polynome.zero
+let zero_conpair = mk_conpair Polynome.zero
+
+let add_bound b1 b2 =
+ match b1, b2 with
+ | Large, Large -> Large
+ | Strict, _ | _, Strict -> Strict
+
+let switch q b1 b2 =
+ if Q.leq Q.zero q then b1 else b2
+
+let inv_bound = function
+ | Large -> Strict
+ | Strict -> Large
+
+let add_conpoly p1 p2 =
+ if p2 == zero_conpoly then p1
+ else if p1 == zero_conpoly then p2
+ else
+ { imp = Polynome.add p1.imp p2.imp;
+ exp = Polynome.add p1.exp p2.exp;
+ bound = add_bound p1.bound p2.bound;
+ deps = Deps.concat p1.deps p2.deps}
+
+let add_conpair p1 p2 =
+ {mi = Opt.map2 add_conpoly p1.mi p2.mi;
+ ma = Opt.map2 add_conpoly p1.ma p2.ma}
+
+let conpair_is_an_equality p1 =
+ match p1.mi, p1.ma with
+ | Some mi, Some ma ->
+ Polynome.equal mi.exp ma.exp &&
+ Q.equal mi.exp.cst Q.zero
+ | _ -> false
+
+let x_p_cy_conpoly p1 q p2 =
+ if p2 == zero_conpoly then p1
+ else
+ {imp = Polynome.x_p_cy p1.imp q p2.imp;
+ exp = Polynome.x_p_cy p1.exp q p2.exp;
+ bound = add_bound p1.bound p2.bound;
+ deps = Deps.concat p1.deps p2.deps
+ }
+
+let cx_p_cy_conpoly q1 p1 q2 p2 =
+ {imp = Polynome.cx_p_cy q1 p1.imp q2 p2.imp;
+ exp = Polynome.cx_p_cy q1 p1.exp q2 p2.exp;
+ bound = add_bound p1.bound p2.bound;
+ deps = Deps.concat p1.deps p2.deps;
+ }
+
+let cst_mult_conpoly q p =
+ {imp = Polynome.mult_cst q p.imp;
+ exp = Polynome.mult_cst q p.exp;
+ bound = p.bound;
+ deps = p.deps;
+ }
+
+let cst_mult_conpair q p =
+ {mi = Opt.map (cst_mult_conpoly q) (switch q p.mi p.ma);
+ ma = Opt.map (cst_mult_conpoly q) (switch q p.ma p.mi);
+ }
+
+let x_p_cy_conpair p1 q p2 =
+ {mi = Opt.map2 (fun x y -> x_p_cy_conpoly x q y)
+ p1.mi (switch q p2.mi p2.ma);
+ ma = Opt.map2 (fun x y -> x_p_cy_conpoly x q y)
+ p1.ma (switch q p2.ma p2.mi);
+ }
+
+let cx_p_cy_conpair q1 p1 q2 p2 =
+ {mi = Opt.map2 (fun x y -> cx_p_cy_conpoly q1 x q2 y)
+ (switch q1 p1.mi p1.ma)
+ (switch q2 p2.mi p2.ma);
+ ma = Opt.map2 (fun x y -> cx_p_cy_conpoly q1 x q2 y)
+ (switch q1 p1.ma p1.mi)
+ (switch q2 p2.ma p2.mi);
+ }
+
+let implies q p =
+ begin match q.mi, p.mi with
+ | _, None -> true
+ | None, _ -> false
+ | Some q, Some p ->
+ match Polynome.is_cst (Polynome.sub p.exp q.exp) with
+ | None -> false
+ | Some cst ->
+ let c = Q.compare Q.zero cst in
+ if c = 0 then
+ not (p.bound = Strict) || q.bound = Strict
+ else c < 0
+ end
+ &&
+ begin match q.ma, p.ma with
+ | _, None -> true
+ | None, _ -> false
+ | Some q, Some p ->
+ match Polynome.is_cst (Polynome.sub p.exp q.exp) with
+ | None -> false
+ | Some cst ->
+ let c = Q.compare Q.zero cst in
+ if c = 0 then
+ not (p.bound = Strict) || q.bound = Strict
+ else c > 0
+ end
+
+(** cl1 -> cl2 *)
+let dist cl1 cl2 =
+ (* contrary of vectors: here AB = OA - OB
+ It is more instuitive for the distance with a constant:
+ 0 <= node - c node - d <= 0
+ *)
+ Polynome.of_list Q.zero [cl1,Q.one;cl2,Q.minus_one]
+
+let dist_conpoly cl1 cl2 =
+ mk_conpoly (dist cl1 cl2)
+
+let dist_conpair cl1 cl2 =
+ mk_conpair (dist cl1 cl2)
+
+let print_conpoly fmt t =
+ Format.fprintf fmt "{imp=%a;exp=%a}" Polynome.pp t.imp Polynome.pp t.exp
+
+let get_rlist_conpair_deps t cl1 cl2 deps =
+ let r,deps =
+ Conflict.ComputeConflict.Equal.one_equal
+ t ~from:cl1 ~to_:cl2 condom zero_conpair deps
+ in
+ (* Debug.dprintf8 debug "cl1=%a cl2=%a r=%a dist=%a" *)
+ (* Node.pp cl1 Node.pp cl2 pp_conpair r Polynome.pp (dist cl1 cl2); *)
+ assert (conpair_is_an_equality r);
+ assert (Polynome.equal (Opt.get r.mi).exp (dist cl1 cl2));
+ r,deps
+
+let get_rlist_conpair t cl1 cl2 =
+ let r, deps = get_rlist_conpair_deps t cl1 cl2 Trail.Deps.empty in
+ Conflict.ComputeConflict.add_deps t deps;
+ r
+
+(** Gen Equality and disequality *)
+module GenEquality = struct
+ open Conflict
+
+ let equality t cl1 cl2 =
+ (** cl1 -> cl2 *)
+ let p = get_rlist_conpair t cl1 cl2 in
+ assert (conpair_is_an_equality p);
+ (* Debug.dprintf6 debug "cl1=%a cl2=%a p=%a" *)
+ (* Node.pp cl1 Node.pp cl2 pp_conpair p; *)
+ (** cl2 -> cl1 *)
+ let p = add_conpair p (dist_conpair cl2 cl1) in
+ (** cl1 -> cl2 -> cl1 = 0 *)
+ assert (conpair_is_an_equality p);
+ assert (Polynome.is_zero (Opt.get p.mi).exp);
+ Debug.dprintf6 debug "[LRA] %a=%a: %a" Node.pp cl1 Node.pp cl2 pp_conpair p;
+ ComputeConflict.unknown_con t condom p
+
+ let expspecial =
+ { Equality.equality = equality;
+ disequality = (fun t _age ~hyp:_ cl1d cl1e cl2e cl2d ->
+ equality t cl1d cl1e;
+ equality t cl2d cl2e);
+ merged = (fun t deps _age cl1d cl1 pexp cl2 cl2d ->
+ let eq_t = ComputeConflict.Equal.init condom
+ zero_conpair deps ~from:cl1d in
+ let eq_t = ComputeConflict.Equal.add_equal t eq_t ~to_:cl1 in
+ let eq_t = ComputeConflict.Equal.add_pexp t eq_t ~to_:cl2 pexp in
+ let eq_t = ComputeConflict.Equal.add_equal t eq_t ~to_:cl2d in
+ let p,deps = ComputeConflict.Equal.close eq_t in
+ (** cl2d -> cl1d *)
+ let pd = dist_conpair cl2d cl1d in
+ let p = add_conpair p pd in
+ (* Debug.dprintf2 debug "sum: %a" pp_conpair p; *)
+ Trail.Deps.add_unknown_con deps condom p);
+ dodec = true (** TODO *);
+ new_true_disequality = (fun _ _ _ -> ());
+ }
+
+ let () = Equality.register_sort Term._Real expspecial
+
+end
+*)
+
+type hypbound =
+ | Eq
+ | Le
+ | Lt
+[@@deriving eq]
+
+let _ = Eq
+let _ = Le
+let _ = Lt
+
+type hyppoly = {
+ bound: hypbound ;
+ poly: Polynome.t ;
+}
+
+let pp_hyppoly fmt c =
+ let bound = function
+ | Eq -> "="
+ | Le -> "ó €¼â‰¤"
+ | Lt -> "<"
+ in
+ Format.fprintf fmt "0 %s %a"
+ (bound c.bound)
+ Polynome.pp c.poly
+
+module HypDom = struct
+ type t = hyppoly
+
+ let pp = pp_hyppoly
+
+ let key =
+ Trail.Hyp.create_key (module struct type nonrec t = t let name = "Arith.hyp" end)
+
+ let pp_v fmt v =
+ let aux fmt (_,v) = pp_hyppoly fmt v in
+ SE.M.bindings v |> Format.(list ~sep:(const char ';') aux) fmt
+
+ let levels _ = assert false
+ let split _ = assert false
+ let apply_learnt hyp =
+ match hyp.bound with
+ | Eq ->
+ let n = of_poly hyp.poly in
+ (Equality.equality [n;zero], Conflict.Neg)
+ | Le | Lt ->
+ let b = if equal_hypbound hyp.bound Le then Interval.Large else Interval.Strict in
+ let i = SE.index (S.Conflict(hyp.poly, b)) Term._Real in
+ let i = SE.node i in
+ (i, Conflict.Neg)
+ let useful_nodes _ = assert false
+end
+
+let () = Conflict.register_hyp(module HypDom)
+
+module ExpEquality = struct
+ (* open Conflict *)
+
+ type t = exp
+ let pp = pp_exp
+ let key = exp
+
+ (* let extract_add s node = match SE.sem s with
+ * | S.Cst _
+ * | S.GZero _
+ * | S.Conflict _
+ * -> raise Impossible
+ * (\* cl1 = 1/q1*(SE.node s) - q2/q1*cl2 *\)
+ * | S.Add (q1,cl1,q2,cl2) when Node.equal node cl1 ->
+ * cl1, (Q.inv q1), SE.node s, Q.neg (Q.div q2 q1), cl2
+ * (\* cl2 = 1/q2*(SE.node s) - q1/q2*cl1 *\)
+ * | S.Add (q1,cl1,q2,cl2) when Node.equal node cl2 ->
+ * cl2, (Q.inv q2), SE.node s, Q.neg (Q.div q1 q2), cl1
+ * (\* SE.node s = q1*cl1 + q2*cl2 *\)
+ * | S.Add (q1,cl1,q2,cl2) ->
+ * SE.node s,q1,cl1,q2,cl2
+ *
+ * (\** the result must be physically one or the other *\)
+ * let best_bound_inf op1 op2 =
+ * match op1,op2 with
+ * | None, None -> None
+ * | None, (Some _ as p) | (Some _ as p), None -> p
+ * | Some p1, Some p2 ->
+ * let q1 = get_exp_conpoly p1 in
+ * let q2 = get_exp_conpoly p2 in
+ * if Interval.compare_bounds_inf (q1,p1.bound) (q2,p2.bound) < 0
+ * then op2 else op1
+ *
+ * (\** the result must be physically one or the other *\)
+ * let best_bound_sup op1 op2 =
+ * match op1,op2 with
+ * | None, None -> None
+ * | None, (Some _ as p) | (Some _ as p), None -> p
+ * | Some p1, Some p2 ->
+ * let q1 = get_exp_conpoly p1 in
+ * let q2 = get_exp_conpoly p2 in
+ * if Interval.compare_bounds_sup (q1,p1.bound) (q2,p2.bound) < 0
+ * then op1 else op2
+ *
+ * let best_bound p1 p2 =
+ * { mi = best_bound_inf p1.mi p2.mi;
+ * ma = best_bound_sup p1.ma p2.ma }
+ *
+ * (\**
+ * 0 <= x + P x + Q < 0
+ * implies
+ * 0 < x - x + P - Q ( -P <= x < -Q )
+ * there was an empty domain so that it was not verified. So for the proof
+ * we suppose that it is not verified
+ * 0 <= Q - P
+ * *\)
+ * let bound_distance_not_verified p1 =
+ * { mi =
+ * Opt.map2 (fun mi ma ->
+ * let p = x_p_cy_conpoly ma Q.minus_one mi in
+ * { p with bound = inv_bound p.bound }
+ * ) p1.mi p1.ma;
+ * ma = None }
+ *
+ * let get_pexp_or_add_def t pexp =
+ * match Conflict.Helpers.get_pexp_or_add t pexp condom with
+ * | None -> assert false
+ * | Some p -> p
+ *
+ * let get_dom t age node =
+ * (\* Look at all the modifications of the cls that are part of the
+ * equivalence class of this node, and keep the two with the best bounds
+ * *\)
+ * Debug.dprintf2 ~nobox:() debug "@,@[<v 3>@[[LRA] get_dom for %a@]" Node.pp node;
+ * let f t =
+ * let mod_doms = get_dom_before_last_dec t age node dom in
+ * let mi, ma =
+ * List.fold_left
+ * (fun (((mi,_) as miacc),((ma,_) as maacc))
+ * (mod_dom:Trail.mod_dom) ->
+ * (\** dom -> modcl *\)
+ * let p' = (get_pexp_or_add_def t mod_dom.modpexp) in
+ * let mi'' = best_bound_inf mi p'.mi in
+ * let ma'' = best_bound_sup ma p'.ma in
+ * (if mi'' == mi then miacc else (p'.mi,mod_dom.modcl)),
+ * (if ma'' == ma then maacc else (p'.ma,mod_dom.modcl)))
+ * ((None,(\* dumb *\) zero),(None,(\* dumb *\) zero))
+ * mod_doms in
+ * let f which = function
+ * | (None,_) ->
+ * Debug.dprintf0 debug "[LRA] Choose None";
+ * None
+ * | (d,modcl) ->
+ * (\** node -> modcl *\)
+ * Debug.dprintf4 debug "[LRA] Choose %a from %a" (Opt.pp pp_conpoly) d Node.pp modcl;
+ * Opt.map2 add_conpoly d (which (get_rlist_conpair t node modcl))
+ * in
+ * { mi = f (fun c -> c.mi) mi; ma = f (fun c -> c.ma) ma }
+ * in
+ * let p,deps = ComputeConflict.wrap_deps t f in
+ * let add_deps m = {m with deps = Deps.concat deps m.deps } in
+ * Debug.dprintf0 ~nobox:() debug "@]";
+ * { mi = Opt.map add_deps p.mi; ma = Opt.map add_deps p.ma }
+ *
+ *
+ * let analyse t age con = function
+ * | ExpCst(node,q) ->
+ * Conflict.return con condom
+ * (mk_conpair (Polynome.of_list (Q.neg q) [node,Q.one]))
+ * | ExpAdd (s,cls) -> begin
+ * match SE.sem s with
+ * | S.Add _->
+ * let cl0, q1, cl1, q2, cl2 = extract_add s cls in
+ * let d1 = get_dom t age cl1 in
+ * (\* Debug.dprintf2 debug "[LRA] d1=%a" pp_conpair d1; *\)
+ * let d2 = get_dom t age cl2 in
+ * (\* Debug.dprintf2 debug "[LRA] d2=%a" pp_conpair d2; *\)
+ * let semv = mk_conpair
+ * (Polynome.of_list Q.zero [cl0,Q.one;cl1,Q.neg q1;cl2,Q.neg q2]) in
+ * let d0 = add_conpair semv (cx_p_cy_conpair q1 d1 q2 d2) in
+ * (\* Debug.dprintf2 debug "[LRA] d0=%a" pp_conpair d0; *\)
+ * (\* Debug.dprintf10 debug *\)
+ * (\* "[LRA] cl0=%a q1=%a cl1=%a q2=%a cl2=%a" *\)
+ * (\* Node.pp cl0 Q.pp q1 Node.pp cl1 Q.pp q2 Node.pp cl2 ; *\)
+ * Conflict.return con condom d0
+ * | S.Conflict p ->
+ * let repr = Polynome.fold (fun acc node _ ->
+ * Node.M.add (Conflict.ComputeConflict.get_repr_at t age node) node acc)
+ * Node.M.empty p in
+ * let cl0 = SE.node s in
+ * let semv,p' = Polynome.fold (fun (semv,acc) node q ->
+ * let node' = Conflict.ComputeConflict.get_repr_at t age node in
+ * let node' = Node.M.find_exn Impossible node' repr in
+ * let semv = x_p_cy_conpair semv q (get_rlist_conpair t node' node) in
+ * semv,Polynome.add acc (Polynome.monome q node')
+ * )
+ * (mk_conpair p,Polynome.cst p.cst)
+ * p in
+ * let pcl0 = Polynome.monome Q.minus_one cl0 in
+ * let semv = add_conpair semv (mk_conpair pcl0) in
+ * let p' = Polynome.add p' pcl0 in
+ * Debug.dprintf2 debug "[LRA] p=%a" Polynome.pp p;
+ * Debug.dprintf2 debug "[LRA] semv=%a" pp_conpair semv;
+ * Debug.dprintf2 debug "[LRA] p'=%a" Polynome.pp p';
+ * let mi = match semv.mi with
+ * | None -> assert false
+ * | Some mi -> mi in
+ * assert (Polynome.equal p' mi.exp);
+ * let qcls = Node.M.find_exn Impossible cls (mi.exp).poly in
+ * let semv = cst_mult_conpair (Q.inv qcls) semv in
+ * let mi = match semv.mi with
+ * | None -> assert false
+ * | Some mi -> mi in
+ * let semv =
+ * Polynome.fold (fun semv node q ->
+ * if Node.equal node cls then semv
+ * else
+ * let d = get_dom t age node in
+ * x_p_cy_conpair semv (Q.neg q) d
+ * ) semv (mi.exp) in
+ * Conflict.return con condom semv
+ * | _ -> raise Impossible
+ * end
+ * | ExpGZeroDown (s,nonot) ->
+ * let node,b = match SE.sem s with
+ * | S.GZero (node,b) -> node,b
+ * | _ -> raise Impossible in
+ * let cl0 = SE.node s in
+ * ComputeConflict.unknown_con t conclause
+ * (Boolean.get_dom t age cl0 Node.M.empty);
+ * let p =
+ * let exp = Polynome.monome Q.one node in
+ * if nonot
+ * then
+ * {mi = Some
+ * { imp = exp; exp; bound=b;
+ * deps = Deps.empty};
+ * ma = None}
+ * else
+ * {ma = Some
+ * { imp = exp; exp;
+ * bound=inv_bound b;
+ * deps = Deps.empty};
+ * mi = None}
+ * in
+ * Conflict.return con condom p
+ * | ExpEmptyDomMerge (pexp,cl1,cl2) ->
+ * let d1 = get_dom t age cl1 in
+ * let d2 = get_dom t age cl2 in
+ * let eq,deps =
+ * Conflict.ComputeConflict.Equal.one_pexp t ~from:cl1 ~to_:cl2 condom
+ * zero_conpair Deps.empty pexp
+ * in
+ * Conflict.ComputeConflict.add_deps t deps;
+ * assert (conpair_is_an_equality eq);
+ * Debug.dprintf6 debug "d1=%a;@ d2=%a;@ eq=%a"
+ * pp_conpair d1 pp_conpair d2 pp_conpair eq;
+ * let d2 = add_conpair eq d2 in
+ * let r = best_bound d1 d2 in
+ * Debug.dprintf4 debug "d2=%a@ r=%a"
+ * pp_conpair d2 pp_conpair r;
+ * let r = bound_distance_not_verified r in
+ * assert (None <> r.mi);
+ * assert (match Polynome.is_cst (Opt.get r.mi).exp,
+ * (Opt.get r.mi).bound with
+ * | Some q, Strict -> Q.lt Q.zero q
+ * | Some q, Large -> Q.leq Q.zero q
+ * | None,_ -> false);
+ * return con condom r
+ * | ExpEmptyDomInter (pexp,cl1) ->
+ * let d1 = get_dom t age cl1 in
+ * Debug.dprintf2 debug "d1=%a" pp_conpair d1;
+ * let d2 = (get_pexp_or_add_def t pexp) in
+ * Debug.dprintf2 debug "d2=%a" pp_conpair d2;
+ * let r' = best_bound d1 d2 in
+ * let r = bound_distance_not_verified r' in
+ * Debug.dprintf4 debug "r'=%a r=%a@"
+ * pp_conpair r' pp_conpair r;
+ * assert (None <> r.mi);
+ * assert (match Polynome.is_cst (Opt.get r.mi).exp,
+ * (Opt.get r.mi).bound with
+ * | Some q, Strict -> Q.lt Q.zero q
+ * | Some q, Large -> Q.leq Q.zero q
+ * | None,_ -> false);
+ * return con condom r
+ * | ExpGZeroUp(s,nonot) ->
+ * let node,b = match SE.sem s with
+ * | S.GZero (node,b) -> node,b
+ * | _ -> raise Impossible in
+ * let d = get_dom t age node in
+ * Debug.dprintf6 debug "node=%a %a d=%a" Node.pp node pp_bound b pp_conpair d;
+ * if nonot then begin
+ * assert ( implies d {ma = None; mi = Some { (mk_conpoly (Polynome.monome Q.one node)) with bound = b}} );
+ * ComputeConflict.unknown_con t condom
+ * { d with ma = None }
+ * end else begin
+ * assert ( implies d {mi = None; ma = Some { (mk_conpoly (Polynome.monome Q.one node))
+ * with bound = inv_bound b}} );
+ * ComputeConflict.unknown_con t condom
+ * { d with mi = None }
+ * end;
+ * Conflict.return con conclause Node.M.empty
+ * | ExpDistIsZero s ->
+ * let cl0, q1, cl1, q2, cl2 = extract_add s (SE.node s) in
+ * let d0 = get_dom t age cl0 in
+ * let semv = mk_conpair
+ * (Polynome.of_list Q.zero [cl0,Q.minus_one;cl1,q1;cl2,q2]) in
+ * return con condom (add_conpair semv d0)
+ * | ExpIsSingleton(pexp,node,b,cst) ->
+ * let q = match SE.sem cst with | Cst q -> q | _ -> raise Impossible in
+ * let d1 = if b then get_dom t age node else {mi=None;ma=None} in
+ * let d2 = (get_pexp_or_add_def t pexp) in
+ * let r = best_bound d1 d2 in
+ * Debug.dprintf8
+ * debug
+ * "r=%a d1=%a d2=%a q=%a"
+ * pp_conpair r pp_conpair d1 pp_conpair d2 Q.pp q;
+ * Conflict.return con condom r
+ *
+ * let expdomlimit _t _age dom' node con v _ =
+ * let v = Opt.get_exn Impossible v in
+ * let v = Dom.Eq.coerce dom' dom v in
+ * let mk = function
+ * | None -> None
+ * | Some (v,bound) ->
+ * let p = Polynome.of_list (Q.neg v) [node,Q.one] in
+ * Some {imp = p; exp = p; bound; deps = Deps.empty} in
+ * let mi,ma = D.get_convexe_hull v in
+ * return con condom {mi=mk mi;ma=mk ma}
+ *
+ *
+ * let same_sem (type a) t age (sem':a sem) (v:a) con exp cl1 cl2 =
+ * let r1 = analyse t age condom exp in
+ * let p = match r1 with
+ * | GRequested p1 ->
+ * let p2 =
+ * match Sem.Eq.eq_type S.key sem' with
+ * | None -> raise Impossible (\* understand why that happend *\)
+ * | Some Types.Eq ->
+ * Polynome.x_p_cy (Polynome.monome Q.one cl2) Q.minus_one
+ * (to_poly v)
+ * in
+ * x_p_cy_conpair p1 Q.minus_one (mk_conpair p2)
+ * | GOther _ -> raise Impossible (\* not created by analyse *\)
+ * in
+ * Debug.dprintf6 debug_todo "@[same_sem cl1:%a cl2:%a = %a@]"
+ * Node.pp cl1 Node.pp cl2 pp_conpair p;
+ * assert (conpair_is_an_equality p);
+ * assert (Polynome.equal (Opt.get p.mi).exp (dist cl1 cl2));
+ * Conflict.return con condom p *)
+
+ let analyse _ = assert false
+ let from_contradiction _ = assert false
+
+end
+
+let () = Conflict.register_exp(module ExpEquality)
+
+
+module ChoLRA = struct
+ open Conflict
+
+ module OnWhat = Node
+
+ let make_decision node b env =
+ Debug.dprintf4 print_decision
+ "[LRA] decide %a on %a" Q.pp b Node.pp node;
+ let pexp = Egraph.mk_pexp env exp (ExpDec(node,b)) in
+ set_dom env pexp node (D.singleton b) false
+
+ let choose_decision env node =
+ let v = Opt.get_def D.reals (Egraph.get_dom env dom node) in
+ match D.is_singleton v with
+ | Some _ -> DecNo
+ | None -> DecTodo (make_decision node (D.choose v))
+ let key = choarith
+
+end
+
+let () = Conflict.register_cho(module ChoLRA)
+
+(** API *)
+
+let index x = SE.node (SE.index x Term._Real)
+
+let as_node node = index (S.Add (Q.one,node,Q.one,zero))
+
+let add' q1 cl1 q2 cl2 =
+ SE.node (add' q1 cl1 q2 cl2)
+
+let add cl1 cl2 =
+ add' Q.one cl1 Q.one cl2
+
+let sub cl1 cl2 =
+ index (S.Add(Q.one,cl1,Q.minus_one,cl2))
+
+let neg cl2 =
+ index (S.Add(Q.one,zero,Q.minus_one,cl2))
+
+let mult _cl1 _cl2 = raise (TODO "mult without constant")
+
+let mult_cst cst node =
+ add' cst node Q.one zero
+
+let gt_zero node =
+ SE.node (SE.index (GZero(node,Strict)) Boolean.ty)
+
+let ge_zero node =
+ SE.node (SE.index (GZero(node,Large)) Boolean.ty)
+
+let lt cl1 cl2 = gt_zero (sub cl2 cl1)
+let le cl1 cl2 = ge_zero (sub cl2 cl1)
+let gt cl1 cl2 = lt cl2 cl1
+let ge cl1 cl2 = le cl2 cl1
+
+(** {2 Initialization} *)
+let converter d f l =
+ let of_term t =
+ let n = SynTerm.node_of_term t in
+ Egraph.register d n;
+ n
+ in
+ let node = match f, l with
+ | f,[] when Term.is_const_real_term f ->
+ Some (cst (Term.get_const_real_term f))
+ | f,a::args when Term.is_add_real_term f ->
+ Some (List.fold_left add (of_term a) (List.map of_term args))
+ | f,[arg1;arg2] when Term.equal f Term.sub_real_term ->
+ Some (sub (of_term arg1) (of_term arg2))
+ | f,[arg] when Term.equal f Term.neg_real_term ->
+ Some (neg (of_term arg))
+ | f,args when Term.equal f Term.mul_real_term -> begin
+ let mult_cst c t =
+ Some (mult_cst (Term.get_const_real_term c) (of_term t))
+ in
+ match args with
+ | [arg1;arg2] when Term.is_const_real_term arg1 ->
+ mult_cst arg1 arg2
+ | [arg1;arg2] when Term.is_const_real_term arg2 ->
+ mult_cst arg2 arg1
+ | _ -> None
+ end
+ | f,[arg1;arg2] when Term.is_lt_real_term f ->
+ Some (lt (of_term arg1) (of_term arg2))
+ | f,[arg1;arg2] when Term.is_le_real_term f ->
+ Some (le (of_term arg1) (of_term arg2))
+ | _ -> None in
+ node
+
+let decvars n =
+ if Ty.equal (Node.ty n) Term._Real
+ then Some (make_dec n)
+ else None
+
+
+let th_register env =
+ RDaemonPropa.init env;
+ Demon.Fast.register_init_daemon
+ ~immediate:true
+ ~name:"LRA.DaemonInit"
+ (module SE)
+ DaemonPropa.init
+ env;
+ SynTerm.register_converter env converter;
+ SynTerm.register_decvars env decvars;
+ Demon.Fast.register_init_daemon_value
+ ~name:"RealValueToDom"
+ (module RealValue)
+ (fun d value ->
+ let v = RealValue.value value in
+ let s = D.singleton v in
+ let _pexp = Egraph.mk_pexp d exp (ExpCst value) in
+ (** something must be done with the pexp *)
+ Egraph.set_dom d dom (RealValue.node value) s
+ ) env;
+ ()
+
+(** {2 Interpretations} *)
+let () =
+ let gzero bound n =
+ let v = (match bound with | Strict -> Q.lt | Large -> Q.le) Q.zero n in
+ (if v then Boolean.values_true else Boolean.values_false)
+ in
+ let interp ~interp (t:S.t) =
+ let get_v n = RealValue.value (RealValue.coerce_nodevalue (interp n)) in
+ match t with
+ | Add(q1,n1,q2,n2) ->
+ let v = Q.( q1 * (get_v n1) + q2 * (get_v n2)) in
+ RealValue.nodevalue (RealValue.index v Term._Real)
+ | GZero(n,bound) ->
+ gzero bound (get_v n)
+ | Conflict (p,bound) ->
+ let v = Polynome.fold (fun acc n q -> Q.( acc + q * (get_v n))) Q.zero p in
+ gzero bound v
+ in
+ Interp.Register.thterm S.key interp
+
+let default_value = Q.zero
+
+let () =
+ Interp.Register.model Term._Real (fun d n ->
+ let v = Egraph.get_value d real n in
+ let v = Witan_popop_lib.Opt.get_def default_value v in
+ let v = RealValue.nodevalue (RealValue.index v Term._Real) in
+ v)
+
+let () =
+ Interp.Register.id (fun id args ->
+ let is builtin = Term.Id.equal id builtin in
+ let (!>) n = RealValue.value (RealValue.coerce_nodevalue n) in
+ let (!<) v = Some (RealValue.nodevalue (RealValue.index v Term._Real)) in
+ let (!<<) b = Some (if b then Boolean.values_true else Boolean.values_false) in
+ match args with
+ | [] when Term.is_const_real_id id ->
+ !< (Term.get_const_real_id id)
+ | args when Term.is_add_real_id id ->
+ !< (List.fold_left (fun acc a -> Q.add acc (!> a)) Q.zero args)
+ | [arg1;arg2] when is Term.sub_real_id ->
+ !< (Q.sub (!> arg1) (!> arg2))
+ | [arg] when is Term.neg_real_id ->
+ !< (Q.neg (!> arg))
+ | [arg1;arg2] when is Term.mul_real_id ->
+ !< (Q.mul (!> arg1) (!> arg2))
+ | [arg1;arg2] when Term.is_lt_real_id id ->
+ !<< (Q.lt (!> arg1) (!> arg2))
+ | [arg1;arg2] when Term.is_le_real_id id ->
+ !<< (Q.le (!> arg1) (!> arg2))
+ | _ -> None
+ )
diff --git a/src/theories/LRA/LRA.mli b/src/theories/LRA/LRA.mli
new file mode 100644
index 000000000..87fd5bf7d
--- /dev/null
+++ b/src/theories/LRA/LRA.mli
@@ -0,0 +1,39 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+val cst : Q.t -> Node.t
+val add' : Q.t -> Node.t -> Q.t -> Node.t -> Node.t
+val add : Node.t -> Node.t -> Node.t
+val sub : Node.t -> Node.t -> Node.t
+
+val mult_cst : Q.t -> Node.t -> Node.t
+
+
+val mult : Node.t -> Node.t -> Node.t
+
+val th_register : Egraph.t -> unit
+val zero: Node.t
+
+val gt_zero: Node.t -> Node.t
+val ge_zero: Node.t -> Node.t
+val lt: Node.t -> Node.t -> Node.t
+val le: Node.t -> Node.t -> Node.t
+val gt: Node.t -> Node.t -> Node.t
+val ge: Node.t -> Node.t -> Node.t
diff --git a/src/theories/LRA/dune b/src/theories/LRA/dune
new file mode 100644
index 000000000..5e065072a
--- /dev/null
+++ b/src/theories/LRA/dune
@@ -0,0 +1,13 @@
+(library
+ (name witan_theories_LRA)
+ (public_name witan.theories.LRA)
+ (synopsis "theories for witan")
+ (libraries containers ocamlgraph witan.stdlib witan.popop_lib
+ witan.core.structures witan.core witan.theories.bool)
+ (preprocess
+ (pps ppx_deriving.std))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always -open
+ Containers -open Witan_stdlib -open Std -open Witan_core -open
+ Witan_theories_bool)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/theories/LRA/interval.ml b/src/theories/LRA/interval.ml
new file mode 100644
index 000000000..9d6981004
--- /dev/null
+++ b/src/theories/LRA/interval.ml
@@ -0,0 +1,984 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Witan_stdlib.Std
+
+type bound = Interval_sig.bound = Strict | Large [@@deriving eq]
+
+let pp_bound fmt = function
+ | Strict -> Format.string fmt "<"
+ | Large -> Format.string fmt "≤"
+
+let compare_inf b1 b2 = match b1,b2 with
+ | Large, Strict -> -1
+ | Strict, Large -> 1
+ | Large, Large | Strict, Strict -> 0
+
+let compare_inf_sup b1 b2 = match b1,b2 with
+ | Large, Strict -> 1
+ | Strict, Large -> 1
+ | Large, Large -> 0
+ | Strict, Strict -> 1
+
+let compare_sup b1 b2 = - (compare_inf b1 b2)
+
+let compare_bounds_inf = Ord.pair Q.compare compare_inf
+let compare_bounds_sup = Ord.pair Q.compare compare_sup
+let compare_bounds_inf_sup = Ord.pair Q.compare compare_inf_sup
+
+module Convexe = struct
+
+ type t = { minb : bound; minv: Q.t; maxv: Q.t; maxb: bound }
+
+ let pp fmt t =
+ let print_bound_left fmt = function
+ | Large -> Format.fprintf fmt "["
+ | Strict -> Format.fprintf fmt "]" in
+ let print_bound_right fmt = function
+ | Large -> Format.fprintf fmt "]"
+ | Strict -> Format.fprintf fmt "[" in
+ match t.minb, t.maxb with
+ | Large, Large when Q.equal t.minv t.maxv
+ -> Format.fprintf fmt "{%a}" Q.pp t.minv
+ | _
+ -> Format.fprintf fmt "%a%a;%a%a"
+ print_bound_left t.minb
+ Q.pp t.minv
+ Q.pp t.maxv
+ print_bound_right t.maxb
+
+ let compare e1 e2 =
+ let compare_bound b1 b2 = match b1, b2 with
+ | Strict, Large -> 1
+ | Large, Strict -> -1
+ | _ -> 0
+ in
+ let c = Q.compare e1.minv e2.minv in
+ if c = 0 then c else
+ let c = compare_bound e1.minb e2.minb in
+ if c = 0 then c else
+ let c = Q.compare e1.maxv e2.maxv in
+ if c = 0 then c else
+ let c = compare_bound e1.maxb e2.maxb in
+ c
+
+ let equal e1 e2 =
+ Equal.physical e1.minb e2.minb && Equal.physical e1.maxb e2.maxb &&
+ Q.equal e1.minv e2.minv && Q.equal e1.maxv e2.maxv
+
+ let hash e =
+ let hash_bound = function
+ | Large -> 1
+ | Strict -> 3 in
+ Hashcons.combine3
+ (hash_bound e.minb) (hash_bound e.maxb)
+ (Hashtbl.hash e.minv) (Hashtbl.hash e.maxv)
+
+
+ include Popop_stdlib.MkDatatype(struct
+ type nonrec t = t
+ let equal = equal let compare = compare
+ let hash = hash let pp = pp
+ end)
+
+ let invariant e =
+ not (Q.equal e.minv Q.inf) &&
+ not (Q.equal e.maxv Q.minus_inf) &&
+ let c = Q.compare e.minv e.maxv in
+ if c = 0
+ then equal_bound e.minb Large && equal_bound e.maxb Large
+ else c < 0
+
+ let is_singleton = function
+ | {minv;maxv} when Q.equal minv maxv -> Some minv
+ | _ -> None
+
+ let singleton q =
+ let t = {minb=Large; minv = q; maxv = q; maxb= Large} in
+ assert (invariant t);
+ t
+
+ let except e x =
+ let is_min = Q.equal e.minv x in
+ let is_max = Q.equal e.maxv x in
+ if is_min && is_max then None
+ else if is_min
+ then Some {e with minb=Strict}
+ else if Q.equal e.maxv x
+ then Some {e with maxb=Strict}
+ else Some e
+
+ let lower_min_max e1 e2 =
+ let c = Q.compare e1.minv e2.minv in
+ match e1.minb, e2.minb with
+ | Strict, Large when c = 0 -> e2,e1, false
+ | _ when c <= 0 -> e1,e2, true
+ | _ -> e2,e1, false
+
+ let bigger_min_max e1 e2 =
+ let c = Q.compare e1.maxv e2.maxv in
+ match e1.maxb, e2.maxb with
+ | Strict, Large when c = 0 -> e1,e2, true
+ | _ when c >= 0 -> e2,e1, false
+ | _ -> e1,e2, true
+
+
+ let is_comparable e1 e2 =
+ (** x1 in e1, x2 in e2 *)
+ (** order by the minimum *)
+ let emin,emax,same = lower_min_max e1 e2 in (** emin.minv <= emax.minv *)
+ (** look for inclusion *)
+ let c = Q.compare emin.maxv emax.minv in
+ match emin.maxb, emax.minb with
+ (** emin.minv <? e1 <? emin.maxv < emax.minv <? e2 <? emax.maxv *)
+ | _ when c < 0 -> if same then `Lt else `Gt
+ (** emin.minv <? e1 < emin.maxv = emax.minv < e2 <? emax.maxv *)
+ (** emin.minv <? e1 < emin.maxv = emax.minv <= e2 <? emax.maxv *)
+ (** emin.minv <? e1 <= emin.maxv = emax.minv < e2 <? emax.maxv *)
+ | Strict, Strict | Strict, Large | Large, Strict
+ when c = 0 ->
+ if same then `Lt else `Gt
+ | _ -> `Uncomparable
+
+ let is_distinct e1 e2 =
+ match is_comparable e1 e2 with
+ | `Uncomparable -> false
+ | _ -> true
+
+ let is_included e1 e2 =
+ assert (invariant e1);
+ assert (invariant e2);
+ compare_bounds_inf (e2.minv,e2.minb) (e1.minv,e1.minb) <= 0 &&
+ compare_bounds_sup (e1.maxv,e1.maxb) (e2.maxv,e2.maxb) <= 0
+
+ let mem x e =
+ (match e.minb with
+ | Strict -> Q.lt e.minv x
+ | Large -> Q.le e.minv x)
+ &&
+ (match e.maxb with
+ | Strict -> Q.lt x e.maxv
+ | Large -> Q.le x e.maxv)
+
+ let mult_pos q e =
+ {e with minv = Q.mul e.minv q; maxv = Q.mul e.maxv q}
+
+ let mult_neg q e =
+ { minb = e.maxb; maxb = e.minb;
+ minv = Q.mul e.maxv q;
+ maxv = Q.mul e.minv q }
+
+ let mult_cst q e =
+ assert (Q.is_real q);
+ let c = Q.sign q in
+ if c = 0 then singleton Q.zero
+ else if c > 0 then mult_pos q e
+ else mult_neg q e
+
+ let add_cst q e =
+ {e with minv = Q.add e.minv q; maxv = Q.add e.maxv q}
+
+ let mult_bound b1 b2 =
+ match b1, b2 with
+ | Large , Large -> Large
+ | _ -> Strict
+
+ let add e1 e2 =
+ let t = {minb = mult_bound e1.minb e2.minb;
+ minv = Q.add e1.minv e2.minv;
+ maxv = Q.add e1.maxv e2.maxv;
+ maxb = mult_bound e1.maxb e2.maxb} in
+ assert (invariant t); t
+
+ let minus e1 e2 =
+ add e1 (mult_neg Q.minus_one e2)
+
+ let gt q =
+ let t = {minb=Strict; minv = q; maxv = Q.inf; maxb= Strict} in
+ assert (invariant t); t
+
+ let ge q =
+ let t = {minb=Large; minv = q; maxv = Q.inf; maxb= Strict} in
+ assert (invariant t); t
+
+ let lt q =
+ let t = {minb=Strict; minv = Q.minus_inf; maxv = q; maxb= Strict} in
+ assert (invariant t); t
+
+ let le q =
+ let t = {minb=Strict; minv = Q.minus_inf; maxv = q; maxb= Large} in
+ assert (invariant t); t
+
+ let union e1 e2 =
+ let emin,_,_ = lower_min_max e1 e2 in
+ let _,emax,_ = bigger_min_max e1 e2 in
+ {minb = emin.minb; minv = emin.minv;
+ maxv = emax.maxv; maxb = emax.maxb}
+
+ let inter e1 e2 =
+ let (minv,minb) as min =
+ if compare_bounds_inf (e1.minv,e1.minb) (e2.minv,e2.minb) < 0
+ then (e2.minv,e2.minb) else (e1.minv,e1.minb)
+ in
+ let (maxv,maxb) as max =
+ if compare_bounds_sup (e1.maxv,e1.maxb) (e2.maxv,e2.maxb) < 0
+ then (e1.maxv,e1.maxb) else (e2.maxv,e2.maxb)
+ in
+ if compare_bounds_inf_sup min max > 0
+ then None
+ else if Q.equal minv maxv && equal_bound minb Large && equal_bound maxb Large
+ then Some (singleton minv)
+ else Some {minv;minb;maxv;maxb}
+
+ let inter e1 e2 =
+ let r = inter e1 e2 in
+ assert (Opt.for_all invariant r);
+ r
+
+ (** intersection set.
+ if the two arguments are equals, return the second
+ *)
+
+ let zero = singleton Q.zero
+ let reals = {minb=Strict; minv=Q.minus_inf; maxb=Strict; maxv=Q.inf}
+ let () = assert (invariant reals)
+
+ let is_reals = function
+ | {minb=Strict; minv; maxb=Strict; maxv}
+ when Q.equal minv Q.minus_inf &&
+ Q.equal maxv Q.inf -> true
+ | _ -> false
+
+ let choose = function
+ | {minb=Large;minv} -> minv
+ | {maxb=Large;maxv} -> maxv
+ | {minv;maxv} when Q.equal Q.minus_inf minv && Q.equal Q.inf maxv ->
+ Q.zero
+ | {minv;maxv} when Q.equal Q.minus_inf minv ->
+ Q.make (Z.sub (Q.to_bigint maxv) Z.one) Z.one
+ | {minv;maxv} when Q.equal Q.inf maxv ->
+ Q.make (Z.add (Q.to_bigint minv) Z.one) Z.one
+ | {minv;maxv} ->
+ let q = Q.make (Z.add Z.one (Q.to_bigint minv)) Z.one in
+ if Q.lt q maxv then q
+ else Q.add maxv (Q.div_2exp (Q.sub minv maxv) 1)
+
+
+ let nb_incr = 100
+ let z_nb_incr = Z.of_int nb_incr
+ let choose_rnd rnd = function
+ | {minv;maxv} when Q.equal Q.minus_inf minv ->
+ Q.make (Z.sub (Z.of_int (rnd nb_incr)) (Q.to_bigint maxv)) Z.one
+ | {minv;maxv} when Q.equal Q.inf maxv ->
+ Q.make (Z.add (Z.of_int (rnd nb_incr)) (Q.to_bigint minv)) Z.one
+ | {minv;maxv} when Q.equal minv maxv -> minv
+ | {minv;maxv} ->
+ let d = Q.sub maxv minv in
+ let i = 1 + rnd (nb_incr - 2) in
+ let x = Q.make (Z.of_int i) (Z.of_int 100) in
+ let q = Q.add minv (Q.mul x d) in
+ assert (Q.lt minv q);
+ assert (Q.lt q maxv);
+ q
+
+ let get_convexe_hull e =
+ let mk v b =
+ match Q.classify v with
+ | Q.ZERO | Q.NZERO -> Some (v,b)
+ | Q.INF | Q.MINF -> None
+ | Q.UNDEF -> assert false in
+ mk e.minv e.minb, mk e.maxv e.maxb
+
+end
+
+module ConvexeWithExceptions = struct
+
+ type t = {con: Convexe.t; exc: Q.S.t}
+ [@@deriving eq, ord]
+
+ let pp fmt x =
+ if Q.S.is_empty x.exc then Convexe.pp fmt x.con
+ else
+ let aux fmt m = Q.S.elements m
+ |> Format.(list ~sep:(const char ',') Q.pp) fmt
+ in
+ Format.fprintf fmt "%a \ {%a}" Convexe.pp x.con aux x.exc
+
+ let invariant x =
+ Convexe.invariant x.con &&
+ ( Q.S.is_empty x.exc ||
+ ( Q.lt x.con.Convexe.minv (Q.S.min_elt x.exc) &&
+ Q.lt (Q.S.max_elt x.exc) x.con.Convexe.maxv ))
+
+ let hash e = 53 * (Convexe.hash e.con) +
+ 31 * (Q.S.fold_left (fun acc x -> 3*acc + Q.hash x) 5 e.exc)
+
+ include Popop_stdlib.MkDatatype(struct
+ type nonrec t = t
+ let equal = equal let compare = compare
+ let hash = hash let pp = pp
+ end)
+
+ let of_con con = {con;exc=Q.S.empty}
+ let reals = of_con Convexe.reals
+ let from_convexe f x = of_con (f x)
+ let singleton = from_convexe Convexe.singleton
+ let zero = singleton Q.zero
+ let le = from_convexe Convexe.le
+ let lt = from_convexe Convexe.lt
+ let ge = from_convexe Convexe.ge
+ let gt = from_convexe Convexe.gt
+ let is_singleton e = Convexe.is_singleton e.con
+ let is_reals e = Convexe.is_reals e.con && Q.S.is_empty e.exc
+ let mem x e = Convexe.mem x e.con && not (Q.S.mem x e.exc)
+
+ let except e x =
+ match Convexe.except e.con x with
+ | None -> None
+ | Some con ->
+ if Convexe.mem x con
+ then Some {con; exc = Q.S.add x e.exc}
+ else Some {e with con}
+
+ let union e1 e2 =
+ {con=Convexe.union e1.con e2.con;
+ exc=Q.S.inter e1.exc e2.exc}
+
+ let normalize {con;exc} =
+ match Convexe.is_singleton con with
+ | Some s -> if Q.S.mem s exc then None else Some (of_con con)
+ | None ->
+ let _,has_min,exc = Q.S.split con.Convexe.minv exc in
+ let _,has_max,exc = Q.S.split con.Convexe.maxv exc in
+ Some {exc; con = {con with minb = if has_min then Strict else con.minb;
+ maxb = if has_max then Strict else con.maxb }}
+ let inter e1 e2 =
+ match Convexe.inter e1.con e2.con with
+ | None -> None
+ | Some con ->
+ normalize { con; exc = Q.S.union e1.exc e2.exc }
+
+
+ let is_comparable e1 e2 =
+ Convexe.is_comparable e1.con e2.con (* ||
+ * not (Q.S.equal e1.exc e2.exc) *)
+
+ let is_distinct e1 e2 =
+ Convexe.is_distinct e1.con e2.con (* ||
+ * not (Q.S.equal e1.exc e2.exc) *)
+
+ let is_included e1 e2 =
+ Convexe.is_included e1.con e2.con ||
+ Q.S.subset e1.exc e2.exc
+
+ let add e1 e2 =
+ match Convexe.is_singleton e1.con, e1, Convexe.is_singleton e2.con, e2 with
+ | Some s1, _, Some s2, _ -> singleton (Q.add s1 s2)
+ | None, e, Some s, _ | Some s, _, None, e ->
+ {con=Convexe.add_cst s e.con; exc = Q.S.translate (Q.add s) e.exc}
+ | _ -> of_con (Convexe.add e1.con e2.con)
+
+ let add_cst s e =
+ {con = Convexe.add_cst s e.con; exc = Q.S.translate (Q.add s) e.exc}
+
+ let minus e1 e2 =
+ match Convexe.is_singleton e1.con, e1, Convexe.is_singleton e2.con, e2 with
+ | Some s1, _, Some s2, _ ->
+ singleton (Q.sub s1 s2)
+ | None, e, Some s, _ ->
+ { con = Convexe.add_cst (Q.neg s) e.con;
+ exc = Q.S.translate (fun x -> Q.sub x s) e.exc }
+ | Some s, _, None, e ->
+ { con = Convexe.add_cst s e.con;
+ exc =
+ Q.S.fold_left (fun acc exc -> Q.S.add (Q.sub s exc) acc)
+ Q.S.empty e.exc }
+ | _ -> of_con (Convexe.add e1.con e2.con)
+
+ let mult_cst s e =
+ {con = Convexe.mult_cst s e.con;
+ exc =
+ Q.S.fold_left (fun acc exc -> Q.S.add (Q.mul s exc) acc)
+ Q.S.empty e.exc }
+
+ let choose e =
+ let con = if Q.S.is_empty e.exc then e.con
+ else (** by the invariant the intersection must succeed *)
+ Opt.get_exn Impossible
+ (Convexe.inter e.con (Convexe.lt (Q.S.min_elt e.exc))) in
+ Convexe.choose con
+
+ let choose_rnd rnd e =
+ let con = if Q.S.is_empty e.exc then e.con
+ else (** by the invariant the intersection must succeed *)
+ Opt.get_exn Impossible
+ (Convexe.inter e.con (Convexe.lt (Q.S.min_elt e.exc))) in
+ Convexe.choose_rnd rnd con
+
+ let get_convexe_hull e = Convexe.get_convexe_hull e.con
+
+end
+
+module Union = struct
+
+ type t = Convexe.t list [@@ deriving ord]
+
+ (** all t returned to the outside should verify this invariant *)
+ let invariant = function
+ | [] -> false
+ | l ->
+ let rec aux minb' minv' (l:t) =
+ match minb', l with
+ | Large, [] when Q.equal minv' Q.inf -> false
+ | _ , [] -> true
+ | _ , {minb=Large ; minv}::_ when Q.compare minv minv' <= 0 -> false
+ | Large , {minb=Strict; minv}::_ when Q.compare minv minv' <= 0 -> false
+ | Strict, {minb=Strict; minv}::_ when Q.compare minv minv' < 0 -> false
+ | _, ({maxv;maxb} as e)::l ->
+ Convexe.invariant e && aux maxb maxv l
+ in
+ aux Strict Q.minus_inf l
+
+ let pp fmt l =
+ Format.list ~sep:Format.(const string "∪") Convexe.pp fmt l
+
+ let equal l1 l2 =
+ List.length l1 = List.length l2 &&
+ List.for_all2 Convexe.equal l1 l2
+
+ let is_singleton = function
+ | [r] -> Convexe.is_singleton r
+ | _ -> None
+
+
+ let is_comparable _t1 _t2 = assert false (** TODO : correctly *)
+ let is_distinct _t1 _t2 = assert false (** TODO : correctly *)
+ (* List.length t1 <> List.length t2 ||
+ * List.exists2 Convexe.is_distinct t1 t2 *)
+
+ let is_included _t1 _t2 =
+ raise (TODO "Interval.Union.is_included")
+
+ let mem x e = List.exists (fun e -> Convexe.mem x e) e
+
+ let lower_min_max e1 l1 t1 e2 l2 t2 =
+ let c = Q.compare e1.Convexe.minv e2.Convexe.minv in
+ match e1.Convexe.minb, e2.Convexe.minb with
+ | Strict, Large
+ when c = 0 -> e2,l2,t2,e1,l1,t1
+ | _
+ when c <= 0 -> e1,l1,t1,e2,l2,t2
+ | _ -> e2,l2,t2,e1,l1,t1
+
+ let rec union t1 t2 =
+ match t1,t2 with
+ | [], l | l, [] -> l
+ | e1::l1, e2::l2 ->
+ (** order by the minimum *)
+ let emin,lmin,_,emax,lmax,tmax =
+ lower_min_max e1 l1 t1 e2 l2 t2 in
+ (** look for an intersection *)
+ let c = Q.compare emin.maxv emax.minv in
+ match emin.maxb, emax.minb with
+ (** no intersection *)
+ | Strict, Strict
+ when c <= 0 -> emin::(union lmin tmax)
+ | Large,Large | Strict, Large | Large, Strict
+ when c < 0 -> emin::(union lmin tmax)
+ | _ ->
+ (** intersection *)
+ (** look for inclusion *)
+ let c = Q.compare emax.maxv emin.maxv in
+ match emax.maxb, emin.maxb with
+ (** max included in min *)
+ | Strict, Strict | Large, Large | Strict, Large
+ when c <= 0 -> emin::(union lmin lmax)
+ | Large, Strict
+ when c < 0 -> emin::(union lmin lmax)
+ (** merge the two *)
+ | _ ->
+ let e = {Convexe.minv = emin.minv; minb = emin.minb;
+ maxv = emax.maxv; maxb = emax.maxb} in
+ union lmin (e::lmax)
+
+ let union t1 t2 =
+ let r = union t1 t2 in
+ assert (invariant r);
+ r
+
+ let rec inter' t1 t2 =
+ match t1,t2 with
+ | [], _ | _, [] -> []
+ | e1::l1, e2::l2 ->
+ (** order by the minimum *)
+ let emin,lmin,tmin,emax,lmax,tmax = lower_min_max e1 l1 t1 e2 l2 t2 in
+ (** look for an intersection *)
+ let c = Q.compare emin.maxv emax.minv in
+ match emin.maxb, emax.minb with
+ (** no intersection *)
+ | Strict, Strict | Strict, Large | Large, Strict
+ when c <= 0 -> inter' lmin tmax
+ | Large,Large
+ when c < 0 -> inter' lmin tmax
+ | _ ->
+ (** intersection *)
+ (** look for inclusion *)
+ let c = Q.compare emax.maxv emin.maxv in
+ match emax.maxb, emin.maxb with
+ (** max included in min *)
+ | Strict, Strict | Large, Large | Strict, Large
+ when c <= 0 -> emax::(inter' tmin lmax)
+ | Large, Strict
+ when c < 0 -> emax::(inter' tmin lmax)
+ (** overlapping strictly *)
+ | _ ->
+ let e = {Convexe.minv = emax.minv; minb = emax.minb;
+ maxv = emin.maxv; maxb = emin.maxb } in
+ e::(inter' lmin tmax)
+
+ (* (\** special case if the two are equals, return the second *\) *)
+ (* let rec inter t1 t2 = *)
+ (* match t1, t2 with *)
+ (* | _ when t1 == t2 -> t2 *)
+ (* | [], _ | _, [] -> [] *)
+ (* | e1::l1, e2::l2 when equal_inter e1 e2 -> *)
+ (* let l = inter l1 l2 in *)
+ (* if l == l2 then t2 else e2::l2 *)
+ (* | _ -> inter' t1 t2 *)
+
+ let inter t1 t2 =
+ let r = inter' t1 t2 in
+ match r with
+ | [] -> None
+ | _ ->
+ assert (invariant r);
+ Some r
+
+ let except e x =
+ inter e [Convexe.lt x; Convexe.gt x]
+
+ let singleton q =
+ let t = [Convexe.singleton q] in
+ assert (invariant t);
+ t
+
+ let zero = singleton Q.zero
+
+ let reals = [Convexe.reals]
+ let is_reals = function
+ | [r] when Convexe.is_reals r -> true
+ | _ -> false
+
+ let gt q =
+ let t = [Convexe.gt q] in
+ assert (invariant t);
+ t
+
+ let ge q =
+ let t = [Convexe.ge q] in
+ assert (invariant t);
+ t
+
+ let lt q =
+ let t = [Convexe.lt q] in
+ assert (invariant t);
+ t
+
+ let le q =
+ let t = [Convexe.le q] in
+ assert (invariant t);
+ t
+
+ let add_cst q = List.map (Convexe.add_cst q)
+
+ let add_cst q t =
+ let r = add_cst q t in
+ assert (invariant r);
+ r
+
+ let mult_pos q = List.map (Convexe.mult_pos q)
+
+ let mult_neg q = List.rev_map (Convexe.mult_neg q)
+
+ let mult_cst q t =
+ assert (Q.is_real q);
+ let c = Q.sign q in
+ if c = 0 then singleton Q.zero
+ else if c > 0 then mult_pos q t
+ else mult_neg q t
+
+ let mult_cst q t =
+ let r = mult_cst q t in
+ assert (invariant r);
+ r
+
+ (** t is smaller than l but perhaps a merge is needed *)
+ let cons (t:Convexe.t) (l:t) =
+ match t.maxb, l with
+ | _,[] -> [t]
+ | Strict, ({minb=Strict} as e)::_ when Q.compare t.maxv e.minv <= 0 ->
+ t::l
+ | _, e::_ when Q.compare t.maxv e.minv < 0 ->
+ t::l
+ | _, e::l ->
+ assert (Q.compare t.minv e.minv < 0);
+ assert (Q.compare t.maxv e.maxv < 0);
+ {minb=t.minb; minv = t.maxv; maxv = e.maxv; maxb = e.maxb}::l
+
+ let rec add_intemaxval t = function
+ | [] -> []
+ | e::l ->
+ let e = Convexe.add t e in
+ cons e (add_intemaxval t l)
+
+ let add t1 t2 =
+ let res = match is_singleton t1, t1, is_singleton t2, t2 with
+ | None,_, None,_ ->
+ List.fold_left (fun acc t -> union acc (add_intemaxval t t2)) [] t1
+ | Some q, _, None, t
+ | None, t, Some q, _ when Q.equal Q.zero q -> t
+ | Some q, _, None, t
+ | None, t, Some q, _ ->
+ add_cst q t
+ | Some q1,_, Some q2,_ -> singleton (Q.add q1 q2)
+ in
+ assert ( invariant res );
+ res
+
+ let minus t1 t2 =
+ add t1 (mult_neg Q.minus_one t2)
+
+ (** TODO better heuristic *)
+ let choose = function
+ | [] -> assert false
+ | {Convexe.minb=Large;minv}::_ -> minv
+ | {maxb=Large;maxv}::_ -> maxv
+ | {minv;maxv}::_ when Q.equal Q.minus_inf minv ->
+ Q.make (Z.sub Z.one (Q.to_bigint maxv)) Z.one
+ | {minv;maxv}::_ when Q.equal Q.inf maxv ->
+ Q.make (Z.add Z.one (Q.to_bigint minv)) Z.one
+ | {minv;maxv}::_ -> Q.add maxv (Q.div_2exp (Q.sub minv maxv) 1)
+
+ let choose_rnd rnd l =
+ Convexe.choose_rnd rnd (List.nth l (rnd (List.length l)))
+
+ let get_convexe_hull e =
+ match e with
+ | [] -> assert false
+ | e1::l ->
+ let s,_ = Convexe.get_convexe_hull e1 in
+ let last = List.fold_left (fun _ e -> e) e1 l in
+ let _,l = Convexe.get_convexe_hull last in
+ s,l
+
+ let hash = List.fold_left (fun acc e -> 3*acc + 7*Convexe.hash e) 65553
+ include Popop_stdlib.MkDatatype(struct
+ type nonrec t = t
+ let equal = equal
+ let compare = compare
+ let hash = hash
+ let pp = pp
+ end)
+end
+
+module ConvexeInfo (Info: sig
+ include Popop_stdlib.Datatype
+ val nothing: t
+ end) = struct
+
+ type t = { minb : bound; minv: Q.t; mini: Info.t;
+ maxv: Q.t; maxb: bound; maxi: Info.t }
+
+ let get_info t = t.mini, t.maxi
+ let to_convexe t = { Convexe.minb = t.minb; minv = t.minv;
+ maxv = t.maxv; maxb = t.maxb }
+ let of_convexe (t:Convexe.t) ~info = { minb = t.minb; minv = t.minv;
+ maxv = t.maxv; maxb = t.maxb;
+ mini = info; maxi = info }
+
+ let pp fmt t =
+ let print_bound_left fmt = function
+ | Large -> Format.fprintf fmt "["
+ | Strict -> Format.fprintf fmt "]" in
+ let print_bound_right fmt = function
+ | Large -> Format.fprintf fmt "]"
+ | Strict -> Format.fprintf fmt "[" in
+ if equal_bound t.minb Large && equal_bound t.maxb Large && Q.equal t.minv t.maxv
+ then Format.fprintf fmt "{%a}" Q.pp t.minv
+ else
+ Format.fprintf fmt "%a%a;%a%a"
+ print_bound_left t.minb
+ Q.pp t.minv
+ Q.pp t.maxv
+ print_bound_right t.maxb
+
+ let compare e1 e2 =
+ let compare_bound b1 b2 = match b1, b2 with
+ | Strict, Large -> 1
+ | Large, Strict -> -1
+ | _ -> 0
+ in
+ let c = Q.compare e1.minv e2.minv in
+ if c = 0 then c else
+ let c = compare_bound e1.minb e2.minb in
+ if c = 0 then c else
+ let c = Q.compare e1.maxv e2.maxv in
+ if c = 0 then c else
+ let c = compare_bound e1.maxb e2.maxb in
+ if c = 0 then c else
+ let c = Info.compare e1.mini e2.mini in
+ if c = 0 then c else
+ let c = Info.compare e1.maxi e2.maxi in
+ c
+
+ let equal e1 e2 =
+ Equal.physical e1.minb e2.minb && Equal.physical e1.maxb e2.maxb &&
+ Q.equal e1.minv e2.minv && Q.equal e1.maxv e2.maxv &&
+ Info.equal e1.mini e2.mini && Info.equal e1.maxi e2.maxi
+
+ let hash e =
+ let hash_bound = function
+ | Large -> 1
+ | Strict -> 3 in
+ CCHash.combine6
+ (hash_bound e.minb) (hash_bound e.maxb)
+ (Hashtbl.hash e.minv) (Hashtbl.hash e.maxv)
+ (Info.hash e.mini) (Info.hash e.maxi)
+
+ include Popop_stdlib.MkDatatype(struct
+ type nonrec t = t
+ let equal = equal let compare = compare
+ let hash = hash let pp = pp
+ end)
+
+ let invariant e =
+ not (Q.equal e.minv Q.inf) &&
+ not (Q.equal e.maxv Q.minus_inf) &&
+ let c = Q.compare e.minv e.maxv in
+ if c = 0
+ then equal_bound e.minb Large && equal_bound e.maxb Large
+ else c < 0
+
+ let is_singleton = function
+ | {minv;maxv} when Q.equal minv maxv -> Some minv
+ | _ -> None
+
+ let singleton ~min_info ?(max_info=min_info) q =
+ let t = {minb=Large; minv = q; maxv = q; maxb= Large; mini = min_info; maxi = max_info} in
+ assert (invariant t);
+ t
+
+ let except e x =
+ let is_min = Q.equal e.minv x in
+ let is_max = Q.equal e.maxv x in
+ if is_min && is_max then None
+ else if is_min
+ then Some {e with minb=Strict}
+ else if Q.equal e.maxv x
+ then Some {e with maxb=Strict}
+ else Some e
+
+
+ let lower_min_max e1 e2 =
+ let c = Q.compare e1.minv e2.minv in
+ match e1.minb, e2.minb with
+ | Strict, Large when c = 0 -> e2,e1, false
+ | _ when c <= 0 -> e1,e2, true
+ | _ -> e2,e1, false
+
+ let bigger_min_max e1 e2 =
+ let c = Q.compare e1.maxv e2.maxv in
+ match e1.maxb, e2.maxb with
+ | Strict, Large when c = 0 -> e1,e2
+ | _ when c >= 0 -> e2,e1
+ | _ -> e1,e2
+
+ let is_comparable e1 e2 =
+ (** x1 in e1, x2 in e2 *)
+ (** order by the minimum *)
+ let emin,emax,same = lower_min_max e1 e2 in (** emin.minv <= emax.minv *)
+ (** look for inclusion *)
+ let c = Q.compare emin.maxv emax.minv in
+ match emin.maxb, emax.minb with
+ (** emin.minv <? e1 <? emin.maxv < emax.minv <? e2 <? emax.maxv *)
+ | _ when c < 0 -> if same then `Lt else `Gt
+ (** emin.minv <? e1 < emin.maxv = emax.minv < e2 <? emax.maxv *)
+ (** emin.minv <? e1 < emin.maxv = emax.minv <= e2 <? emax.maxv *)
+ (** emin.minv <? e1 <= emin.maxv = emax.minv < e2 <? emax.maxv *)
+ | Strict, Strict | Strict, Large | Large, Strict
+ when c = 0 ->
+ if same then `Lt else `Gt
+ | _ -> `Uncomparable
+
+ let is_distinct e1 e2 =
+ match is_comparable e1 e2 with
+ | `Uncomparable -> false
+ | _ -> true
+
+ let is_included e1 e2 =
+ assert (invariant e1);
+ assert (invariant e2);
+ compare_bounds_inf (e2.minv,e2.minb) (e1.minv,e1.minb) <= 0 &&
+ compare_bounds_sup (e1.maxv,e1.maxb) (e2.maxv,e2.maxb) <= 0
+
+ let mem x e =
+ (match e.minb with
+ | Strict -> Q.lt e.minv x
+ | Large -> Q.le e.minv x)
+ &&
+ (match e.maxb with
+ | Strict -> Q.lt x e.maxv
+ | Large -> Q.le x e.maxv)
+
+ let mult_pos q e =
+ {e with minv = Q.mul e.minv q; maxv = Q.mul e.maxv q}
+
+ let mult_neg q e =
+ { minb = e.maxb; maxb = e.minb;
+ minv = Q.mul e.maxv q;
+ maxv = Q.mul e.minv q;
+ mini= e.mini; maxi = e.maxi
+ }
+
+ let mult_cst q e =
+ assert (Q.is_real q);
+ let c = Q.sign q in
+ if c = 0 then invalid_arg "mult_cst q = 0"
+ else if c > 0 then mult_pos q e
+ else mult_neg q e
+
+ let add_cst q e =
+ {e with minv = Q.add e.minv q; maxv = Q.add e.maxv q}
+
+ let mult_bound b1 b2 =
+ match b1, b2 with
+ | Large , Large -> Large
+ | _ -> Strict
+
+ let add ~min_info ?(max_info=min_info) e1 e2 =
+ let t = {minb = mult_bound e1.minb e2.minb;
+ minv = Q.add e1.minv e2.minv;
+ maxv = Q.add e1.maxv e2.maxv;
+ maxb = mult_bound e1.maxb e2.maxb;
+ mini = min_info ; maxi = max_info} in
+ assert (invariant t); t
+
+ let minus ~min_info ?max_info e1 e2 =
+ add ~min_info ?max_info e1 (mult_neg Q.minus_one e2)
+
+ let gt ~min_info q =
+ let t = {minb=Strict; minv = q; mini = min_info; maxv = Q.inf; maxb= Strict; maxi = Info.nothing} in
+ assert (invariant t); t
+
+ let ge ~min_info q =
+ let t = {minb=Large; minv = q; mini = min_info; maxv = Q.inf; maxb= Strict; maxi = Info.nothing} in
+ assert (invariant t); t
+
+ let lt ~max_info q =
+ let t = {minb=Strict; minv = Q.minus_inf; mini = Info.nothing; maxv = q; maxb= Strict; maxi = max_info} in
+ assert (invariant t); t
+
+ let le ~max_info q =
+ let t = {minb=Strict; minv = Q.minus_inf; mini = Info.nothing; maxv = q; maxb= Large; maxi = max_info} in
+ assert (invariant t); t
+
+ let union e1 e2 =
+ let emin,_,_ = lower_min_max e1 e2 in
+ let _,emax = bigger_min_max e1 e2 in
+ {minb = emin.minb; minv = emin.minv; mini = emin.mini;
+ maxv = emax.maxv; maxb = emax.maxb; maxi = emin.maxi;}
+
+ let inter e1 e2 =
+ let ((minv,minb) as min,mini) =
+ if compare_bounds_inf (e1.minv,e1.minb) (e2.minv,e2.minb) < 0
+ then ((e2.minv,e2.minb),e2.mini) else ((e1.minv,e1.minb),e1.mini)
+ in
+ let ((maxv,maxb) as max,maxi) =
+ if compare_bounds_sup (e1.maxv,e1.maxb) (e2.maxv,e2.maxb) < 0
+ then ((e1.maxv,e1.maxb),e1.maxi) else ((e2.maxv,e2.maxb),e2.maxi)
+ in
+ if compare_bounds_inf_sup min max > 0
+ then None
+ else if Q.equal minv maxv && equal_bound minb Large && equal_bound maxb Large
+ then Some (singleton ~min_info:mini ~max_info:maxi minv)
+ else Some {minv;minb;mini;maxv;maxb;maxi}
+
+ let inter e1 e2 =
+ let r = inter e1 e2 in
+ assert (Opt.for_all invariant r);
+ r
+
+ (** intersection set.
+ if the two arguments are equals, return the second
+ *)
+
+ let zero ?max_info ~min_info = singleton ~min_info ?max_info Q.zero
+ let reals = {minb=Strict; minv=Q.minus_inf; mini=Info.nothing;
+ maxb=Strict; maxv=Q.inf; maxi=Info.nothing}
+ let () = assert (invariant reals)
+
+ let is_reals = function
+ | {minb=Strict; minv; maxb=Strict; maxv}
+ when Q.equal minv Q.minus_inf &&
+ Q.equal maxv Q.inf -> true
+ | _ -> false
+
+ let choose = function
+ | {minb=Large;minv} -> minv
+ | {maxb=Large;maxv} -> maxv
+ | {minv;maxv} when Q.equal Q.minus_inf minv && Q.equal Q.inf maxv ->
+ Q.zero
+ | {minv;maxv} when Q.equal Q.minus_inf minv ->
+ Q.make (Z.sub (Q.to_bigint maxv) Z.one) Z.one
+ | {minv;maxv} when Q.equal Q.inf maxv ->
+ Q.make (Z.add (Q.to_bigint minv) Z.one) Z.one
+ | {minv;maxv} ->
+ let q = Q.make (Z.add Z.one (Q.to_bigint minv)) Z.one in
+ if Q.lt q maxv then q
+ else Q.add maxv (Q.div_2exp (Q.sub minv maxv) 1)
+
+
+ let nb_incr = 100
+ let z_nb_incr = Z.of_int nb_incr
+ let choose_rnd rnd = function
+ | {minv;maxv} when Q.equal Q.minus_inf minv ->
+ Q.make (Z.sub (Z.of_int (rnd nb_incr)) (Q.to_bigint maxv)) Z.one
+ | {minv;maxv} when Q.equal Q.inf maxv ->
+ Q.make (Z.add (Z.of_int (rnd nb_incr)) (Q.to_bigint minv)) Z.one
+ | {minv;maxv} when Q.equal minv maxv -> minv
+ | {minv;maxv} ->
+ let d = Q.sub maxv minv in
+ let i = 1 + rnd (nb_incr - 2) in
+ let x = Q.make (Z.of_int i) (Z.of_int 100) in
+ let q = Q.add minv (Q.mul x d) in
+ assert (Q.lt minv q);
+ assert (Q.lt q maxv);
+ q
+
+ let get_convexe_hull e =
+ let mk v b =
+ match Q.classify v with
+ | Q.ZERO | Q.NZERO -> Some (v,b)
+ | Q.INF | Q.MINF -> None
+ | Q.UNDEF -> assert false in
+ mk e.minv e.minb, mk e.maxv e.maxb
+
+end
diff --git a/src/theories/LRA/interval.mli b/src/theories/LRA/interval.mli
new file mode 100644
index 000000000..c174fcf53
--- /dev/null
+++ b/src/theories/LRA/interval.mli
@@ -0,0 +1,95 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+
+type bound = Interval_sig.bound = Strict | Large
+
+val pp_bound: bound Format.printer
+
+val compare_bounds_inf: Q.t * bound -> Q.t * bound -> int
+val compare_bounds_sup: Q.t * bound -> Q.t * bound -> int
+val compare_bounds_inf_sup: Q.t * bound -> Q.t * bound -> int
+
+module Convexe: Interval_sig.S
+
+module ConvexeWithExceptions: Interval_sig.S
+
+module Union : Interval_sig.S
+
+module ConvexeInfo(Info: sig
+ include Popop_stdlib.Datatype
+ val nothing: t
+ end) : sig
+ include Popop_stdlib.Datatype
+
+ val get_info: t -> Info.t * Info.t
+ val to_convexe: t -> Convexe.t
+ val of_convexe: Convexe.t -> info:Info.t -> t
+
+ val invariant: t -> bool
+
+ val is_distinct: t -> t -> bool
+ val is_included: t -> t -> bool
+
+ val mult_cst: Q.t -> t -> t
+ val add_cst : Q.t -> t -> t
+ val add: min_info:Info.t -> ?max_info:Info.t -> t -> t -> t
+ val minus: min_info:Info.t -> ?max_info:Info.t -> t -> t -> t
+
+ val mem: Q.t -> t -> bool
+
+ (** from Q.t *)
+ val singleton: min_info:Info.t -> ?max_info:Info.t -> Q.t -> t
+ val is_singleton: t -> Q.t option
+
+ val except: t -> Q.t -> t option
+
+ val gt: min_info:Info.t -> Q.t -> t
+ val ge: min_info:Info.t -> Q.t -> t
+ val lt: max_info:Info.t -> Q.t -> t
+ val le: max_info:Info.t -> Q.t -> t
+ (** > q, >= q, < q, <= q *)
+
+ val union: t -> t -> t
+ (** union set *)
+
+ val inter: t -> t -> t option
+ (** intersection set.
+ if the two arguments are equals, return the second
+ *)
+
+
+ val zero: ?max_info:Info.t -> min_info:Info.t -> t
+ val reals: t
+ (** R *)
+ val is_reals: t -> bool
+
+ val choose: t -> Q.t
+ (** Nothing smart in this choosing *)
+
+
+ val choose_rnd : (int -> int) -> t -> Q.t
+ (** choose an element randomly (but non-uniformly), the given function is
+ the random generator *)
+
+ val get_convexe_hull: t -> (Q.t * bound) option * (Q.t * bound) option
+
+end
diff --git a/src/theories/LRA/interval_sig.ml b/src/theories/LRA/interval_sig.ml
new file mode 100644
index 000000000..2a5dbc342
--- /dev/null
+++ b/src/theories/LRA/interval_sig.ml
@@ -0,0 +1,77 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+
+type bound = Strict | Large
+
+module type S = sig
+ include Popop_stdlib.Datatype
+
+ val invariant: t -> bool
+
+ val is_distinct: t -> t -> bool
+ val is_comparable: t -> t -> [`Uncomparable | `Lt | `Gt]
+ val is_included: t -> t -> bool
+
+ val mult_cst: Q.t -> t -> t
+ val add_cst : Q.t -> t -> t
+ val add: t -> t -> t
+ val minus: t -> t -> t
+
+ val mem: Q.t -> t -> bool
+
+ (** from Q.t *)
+ val singleton: Q.t -> t
+ val is_singleton: t -> Q.t option
+
+ val except: t -> Q.t -> t option
+
+ val gt: Q.t -> t
+ val ge: Q.t -> t
+ val lt: Q.t -> t
+ val le: Q.t -> t
+ (** > q, >= q, < q, <= q *)
+
+ val union: t -> t -> t
+ (** union set *)
+
+ val inter: t -> t -> t option
+ (** intersection set.
+ if the two arguments are equals, return the second
+ *)
+
+
+ val zero: t
+ val reals: t
+ (** R *)
+ val is_reals: t -> bool
+
+ val choose: t -> Q.t
+ (** Nothing smart in this choosing *)
+
+
+ val choose_rnd : (int -> int) -> t -> Q.t
+ (** choose an element randomly (but non-uniformly), the given function is
+ the random generator *)
+
+ val get_convexe_hull: t -> (Q.t * bound) option * (Q.t * bound) option
+
+end
diff --git a/src/theories/LRA/polynome.ml b/src/theories/LRA/polynome.ml
new file mode 100644
index 000000000..c9ffe4ff5
--- /dev/null
+++ b/src/theories/LRA/polynome.ml
@@ -0,0 +1,207 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Witan_core
+
+module T = struct
+ type t = { cst : Q.t; poly : Q.t Node.M.t}
+
+ let equal n m = Q.equal n.cst m.cst && Node.M.equal Q.equal n.poly m.poly
+
+ let hash n = (** number au pif *)
+ Node.M.fold (fun k v acc ->
+ Node.hash k * 101 + Hashtbl.hash v * 107 + acc * 253)
+ n.poly (Hashtbl.hash n.cst * 27)
+
+ let compare n m =
+ let c = Q.compare n.cst m.cst in
+ if c <> 0 then c
+ else Node.M.compare Q.compare n.poly m.poly
+
+ let pp fmt v =
+ let print_not_1 first fmt q =
+ if not first && Q.compare q Q.zero >= 0
+ then Format.pp_print_string fmt "+";
+ if Q.equal q Q.zero then Format.pp_print_string fmt "!0!"
+ else if Q.equal Q.minus_one q then Format.pp_print_string fmt "-"
+ else if not (Q.equal Q.one q) then Q.pp fmt q
+ in
+ let print_not_0 first fmt q =
+ if first
+ then Q.pp fmt q
+ else
+ if not (Q.equal Q.zero q) then begin
+ if Q.compare q Q.zero > 0 then Format.pp_print_string fmt "+";
+ Q.pp fmt q
+ end
+ in
+ let print_mono k v (fmt,first) =
+ Format.fprintf fmt "@[%a%a@]@," (print_not_1 first) v Node.pp k;
+ (fmt,false)
+ in
+ Format.fprintf fmt "@[";
+ let _,first = Node.M.fold print_mono v.poly (fmt,true) in
+ Format.fprintf fmt "%a@]" (print_not_0 first) v.cst
+
+end
+
+include T
+include Popop_stdlib.MkDatatype(T)
+
+(** different invariant *)
+
+let invariant p =
+ Node.M.for_all (fun _ q -> not (Q.equal q Q.zero)) p.poly
+
+(** constructor *)
+let cst q = {cst = q; poly = Node.M.empty}
+let zero = cst Q.zero
+let is_cst p = if Node.M.is_empty p.poly then Some p.cst else None
+let is_zero p = Q.equal p.cst Q.zero && Node.M.is_empty p.poly
+
+type extract = Zero | Cst of Q.t | Var of Q.t * Node.t * t
+let extract p =
+ if Node.M.is_empty p.poly then
+ if Q.equal p.cst Q.zero then Zero
+ else Cst p.cst
+ else
+ let x,q = Shuffle.chooseb Node.M.choose Node.M.choose_rnd p.poly in
+ let p' = {p with poly = Node.M.remove x p.poly} in
+ Var(q,x,p')
+
+type kind = ZERO | CST | VAR
+let classify p =
+ if Node.M.is_empty p.poly then
+ if Q.equal p.cst Q.zero then ZERO
+ else CST
+ else
+ VAR
+
+
+let monome c x =
+ if Q.equal Q.zero c then cst Q.zero
+ else {cst = Q.zero; poly = Node.M.singleton x c}
+
+let is_one_node p = (** cst = 0 and one empty monome *)
+ if Q.equal Q.zero p.cst && Node.M.is_num_elt 1 p.poly then
+ let node,k = Node.M.choose p.poly in
+ if Q.equal Q.one k then Some node
+ else None
+ else None
+
+let sub_cst p q = {p with cst = Q.sub p.cst q}
+
+let mult_cst c p1 =
+ if Q.equal Q.one c then p1
+ else
+ let poly_mult c m = Node.M.map (fun c1 -> Q.mul c c1) m in
+ if Q.equal Q.zero c then cst Q.zero
+ else {cst = Q.mul c p1.cst; poly = poly_mult c p1.poly}
+
+
+let none_zero c = if Q.equal Q.zero c then None else Some c
+
+(** Warning Node.M.union can be used only for defining an operation [op]
+ that verifies [op 0 p = p] and [op p 0 = p] *)
+let add p1 p2 =
+ let poly_add m1 m2 =
+ Node.M.union (fun _ c1 c2 -> none_zero (Q.add c1 c2)) m1 m2
+ in
+ {cst = Q.add p1.cst p2.cst; poly = poly_add p1.poly p2.poly}
+
+let sub p1 p2 =
+ let poly_sub m1 m2 =
+ Node.M.union_merge (fun _ c1 c2 ->
+ match c1 with
+ | None -> Some (Q.neg c2)
+ | Some c1 -> none_zero (Q.sub c1 c2))
+ m1 m2 in
+ {cst = Q.sub p1.cst p2.cst; poly = poly_sub p1.poly p2.poly}
+
+let x_p_cy p1 c p2 =
+ assert (not (Q.equal c Q.zero));
+ let f a b = Q.add a (Q.mul c b) in
+ let poly m1 m2 =
+ Node.M.union_merge (fun _ c1 c2 ->
+ match c1 with
+ | None -> Some (Q.mul c c2)
+ | Some c1 -> none_zero (f c1 c2))
+ m1 m2 in
+ {cst = f p1.cst p2.cst; poly = poly p1.poly p2.poly}
+
+
+let cx_p_cy c1 p1 c2 p2 =
+ let c1_iszero = Q.equal c1 Q.zero in
+ let c2_iszero = Q.equal c2 Q.zero in
+ if c1_iszero && c2_iszero then zero
+ else if c1_iszero
+ then p2
+ else if c2_iszero
+ then p1
+ else
+ let f e1 e2 = Q.add (Q.mul c1 e1) (Q.mul c2 e2) in
+ let poly m1 m2 =
+ Node.M.merge (fun _ e1 e2 ->
+ match e1, e2 with
+ | None, None -> assert false
+ | None, Some e2 -> Some (Q.mul c2 e2)
+ | Some e1, None -> Some (Q.mul c1 e1)
+ | Some e1, Some e2 ->
+ none_zero (f e1 e2))
+ m1 m2 in
+ {cst = f p1.cst p2.cst; poly = poly p1.poly p2.poly}
+
+let subst_node p x y =
+ let poly,qo = Node.M.find_remove x p.poly in
+ match qo with
+ | None -> p, Q.zero
+ | Some q ->
+ let poly = Node.M.change (function
+ | None -> qo
+ | Some q' -> none_zero (Q.add q q')
+ ) y poly in
+ {p with poly}, q
+
+let subst p x s =
+ let poly,q = Node.M.find_remove x p.poly in
+ match q with
+ | None -> p, Q.zero
+ | Some q -> x_p_cy {p with poly} q s, q
+
+let fold f acc p = Node.M.fold_left f acc p.poly
+let iter f p = Node.M.iter f p.poly
+
+let of_list cst l =
+ let fold acc (node,q) = Node.M.change (function
+ | None -> Some q
+ | Some q' -> none_zero (Q.add q q')) node acc in
+ {cst;poly= List.fold_left fold Node.M.empty l}
+
+module ClM = Extmap.Make(Node)
+
+type 'a tree = 'a ClM.view =
+ | Empty
+ | Node of 'a tree * Node.t * 'a * 'a tree * int
+
+let get_tree p =
+ (ClM.view
+ (Node.M.fold_left (fun acc node q -> ClM.add node q acc) ClM.empty p.poly))
+, p.cst
diff --git a/src/arith/polynome.mli b/src/theories/LRA/polynome.mli
similarity index 55%
rename from src/arith/polynome.mli
rename to src/theories/LRA/polynome.mli
index db466c3fb..5f68c9980 100644
--- a/src/arith/polynome.mli
+++ b/src/theories/LRA/polynome.mli
@@ -1,30 +1,29 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Witan_core
(** Polynome *)
-include Stdlib.Datatype
+type t = private { cst : Q.t; poly : Q.t Node.M.t}
+include Popop_stdlib.Datatype with type t := t
val invariant: t -> bool
@@ -33,13 +32,13 @@ val is_zero: t -> bool
val cst: Q.t -> t
val is_cst: t -> Q.t option
-val monome: Q.t -> Cl.t -> t
-val is_one_cl: t -> Cl.t option
+val monome: Q.t -> Node.t -> t
+val is_one_node: t -> Node.t option
type extract =
| Zero (** p = 0 *)
| Cst of Q.t (** p = q *)
- | Var of Q.t * Cl.t * t (** p = qx + p' *)
+ | Var of Q.t * Node.t * t (** p = qx + p' *)
val extract : t -> extract
@@ -52,10 +51,20 @@ val mult_cst: Q.t -> t -> t
val add: t -> t -> t
val sub: t -> t -> t
+val of_list: Q.t -> (Node.t * Q.t) list -> t
+
val x_p_cy: t -> Q.t -> t -> t
-val subst: t -> Cl.t -> t -> t * Q.t
-val subst_cl: t -> Cl.t -> Cl.t -> t * Q.t
+val cx_p_cy: Q.t -> t -> Q.t -> t -> t
+
+val subst: t -> Node.t -> t -> t * Q.t
+val subst_node: t -> Node.t -> Node.t -> t * Q.t
+
+val fold: ('a -> Node.t -> Q.t -> 'a) -> 'a -> t -> 'a
+val iter: (Node.t -> Q.t -> unit) -> t -> unit
+
+type 'a tree =
+ | Empty
+ | Node of 'a tree * Node.t * 'a * 'a tree * int
-val fold: ('a -> Cl.t -> Q.t -> 'a) -> 'a -> t -> 'a
-val iter: (Cl.t -> Q.t -> unit) -> t -> unit
+val get_tree: t -> Q.t tree * Q.t
diff --git a/src/theories/bool/boolean.ml b/src/theories/bool/boolean.ml
new file mode 100644
index 000000000..9bf7e90d5
--- /dev/null
+++ b/src/theories/bool/boolean.ml
@@ -0,0 +1,719 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Popop_stdlib
+open Std
+open Witan_core
+
+let lazy_propagation = false
+
+let debug = Debug.register_info_flag
+ ~desc:"for the boolean theory"
+ "bool"
+
+let ty = Term._Prop
+let dom = ValueKind.create_key (module struct type t = bool let name = "bool" end)
+
+module BoolValue = ValueKind.Register(struct
+ include DBool
+ let key = dom
+ end)
+
+let value_true = BoolValue.index ~basename:"⊤" true ty
+let values_true = BoolValue.nodevalue value_true
+let node_true = BoolValue.node value_true
+
+let value_false = BoolValue.index ~basename:"⊥" false ty
+let values_false = BoolValue.nodevalue value_false
+let node_false = BoolValue.node value_false
+
+(* Function is not used. Don't know what the types of b1 and b2 are. *)
+(* let union_disjoint m1 m2 =
+ * Node.M.union (fun _ b1 b2 -> assert (Equal.physical b1 b2); Some b1) m1 m2 *)
+
+let index sem v = Node.index_sem sem v ty
+
+let is env node = Egraph.get_value env dom node
+let is_true env node = Node.equal node node_true
+ || Equal.option Equal.bool (is env node) (Some true)
+let is_false env node = Node.equal node node_false
+ || Equal.option Equal.bool (is env node) (Some false)
+let is_unknown env node = Equal.option Equal.bool (is env node) None
+
+let set_bool env pexp node b =
+ Egraph.merge env pexp node
+ (if b then node_true else node_false)
+
+type t =
+ { topnot: bool;
+ lits: (Node.t * bool) IArray.t;
+ }
+
+let sem = ThTermKind.create_key (module struct type nonrec t = t let name = "Prop" end)
+
+(* let iter f x = IArray.iter f x.lits *)
+
+let fold f acc x = IArray.fold f acc x.lits
+
+let find x n =
+ fold (fun acc (n1,b) -> if Node.equal n1 n then Some b else acc) None x
+
+let isnot v =
+ if IArray.length v.lits = 1 then
+ let node,sign = IArray.get v.lits 0 in
+ assert (v.topnot && not sign);
+ Some node
+ else
+ None
+
+let mulbool b1 b2 = not(Equal.bool b1 b2)
+
+let node_of_bool b =
+ if b then node_true else node_false
+
+module T = struct
+ type r = t
+ type t = r
+ let equal n1 n2 =
+ let clbool (cl1,b1) (cl2,b2) = Node.equal cl1 cl2 && DBool.equal b1 b2 in
+ Equal.bool n1.topnot n2.topnot &&
+ IArray.equal clbool n1.lits n2.lits
+
+ let hash n =
+ let clbool (node,b) = Hashcons.combine (Node.hash node) (DBool.hash b) in
+ Hashcons.combine (DBool.hash n.topnot) (IArray.hash clbool n.lits)
+
+ let compare n1 n2 =
+ let c = DBool.compare n1.topnot n2.topnot in
+ if c <> 0 then c else
+ let clbool (cl1,b1) (cl2,b2) =
+ let c = Node.compare cl1 cl2 in
+ if c <> 0 then c
+ else DBool.compare b1 b2 in
+ IArray.compare clbool n1.lits n2.lits
+
+
+ let print_cl fmt node b =
+ if b
+ then Format.fprintf fmt "¬ %a" Node.pp node
+ else Node.pp fmt node
+
+ let pp fmt x =
+ match isnot x with
+ | Some node ->
+ print_cl fmt node true
+ | None ->
+ let print_cl topnot fmt (node,b) = print_cl fmt node (mulbool topnot b) in
+ let aux b fmt m = IArray.fold (fun sofar e -> e::sofar) [] m
+ |> List.rev
+ |> Format.(list ~sep:(const char ',') (print_cl b) fmt)
+ in
+ if x.topnot
+ then Format.fprintf fmt "â‹€(%a)" (aux true) x.lits
+ else Format.fprintf fmt "â‹(%a)" (aux false) x.lits
+
+end
+
+module Th = struct
+ include T
+ include MkDatatype(T)
+
+ let key = sem
+
+ exception TopKnown of bool
+
+ exception Found of Node.t * bool
+ let find_not_known d l =
+ IArray.iter (fun (node,b) ->
+ match Egraph.get_value d dom node with
+ | Some _ -> ()
+ | None -> raise (Found (node,b))
+ ) l
+
+ let _bcp d l absorbent =
+ try
+ let res = IArray.fold (fun acc node ->
+ match Egraph.get_value d dom node, acc with
+ | Some b, _ when Equal.bool b absorbent -> raise (TopKnown absorbent)
+ | Some _, _ -> acc
+ | None, Some _ -> raise Exit
+ | None, None -> Some node)
+ None l in
+ match res with
+ | None -> raise (TopKnown (not absorbent))
+ | _ -> res
+ with Exit -> None
+
+end
+
+module ThE = ThTermKind.Register(Th)
+
+(** At least all the leaves except one are known and can be discarded *)
+type bcpkind =
+ | BCPOwnKnown (** Top is known and true modulo topnot, propagate true modulo sign to propa *)
+ | BCPLeavesKnown (** All leaves are known and false modulo sign, propagate false modulo topnot to own *)
+ | BCP (** Merge top with the remaining leave *)
+[@@deriving eq]
+
+type expprop =
+| ExpBCP of ThE.t (* own *) * Node.t (* propa *) * bcpkind
+| ExpUp of ThE.t (* own *) * Node.t (* one leaf to own *)
+| ExpDown of ThE.t (* own *) * Node.t (* leaf *)(* own to leaf *)
+| ExpNot of (Th.t * Node.t * Node.t) * bool (* what have been propagated *)
+| ExpDec of Node.t * bool
+
+let expprop = Exp.create_key (module struct type t = expprop let name = "Bool.prop" end)
+
+module DaemonPropaNot = struct
+
+ module Data = struct
+ type t = Th.t * Node.t * Node.t
+ let pp fmt (v,cl1,cl2) =
+ Format.fprintf fmt "%a,%a -> %a" Th.pp v Node.pp cl1 Node.pp cl2
+ end
+
+ let immediate = false
+ let key = Demon.Fast.create "Bool.DaemonPropaNot"
+ let throttle = 100
+ let wakeup d =
+ function
+ | Events.Fired.EventValue(_,dom',((_,node,ncl) as x)) ->
+ assert (ValueKind.equal dom dom');
+ begin match Egraph.get_value d dom node with
+ | None -> raise Impossible
+ | Some b ->
+ let pexp = Egraph.mk_pexp d expprop (ExpNot(x,not b)) in
+ set_bool d pexp ncl (not b)
+ end;
+ | _ -> raise UnwaitedEvent
+
+ let init d thterm node =
+ let v = ThE.sem thterm in
+ let own = ThE.node thterm in
+ match is d own with
+ | Some b ->
+ let pexp = Egraph.mk_pexp d expprop (ExpNot((v,own,node),not b)) in
+ set_bool d pexp node (not b)
+ | None ->
+ match is d node with
+ | Some b ->
+ let pexp = Egraph.mk_pexp d expprop
+ (ExpNot((v,node,own),not b)) in
+ set_bool d pexp own (not b)
+ | None ->
+ let events = [Demon.Create.EventValue(own,dom,(v,own,node));
+ Demon.Create.EventValue(node,dom,(v,node,own))] in
+ Demon.Fast.attach d key events
+
+end
+
+module RDaemonPropaNot = Demon.Fast.Register(DaemonPropaNot)
+
+module DaemonPropa = struct
+ type watcher = (int,int) Context.Ref2.t
+
+ type d =
+ | Lit of ThE.t (* prop *) * int (* watched *) * watcher
+ | All of ThE.t
+
+ let key = Demon.Fast.create "Bool.DaemonPropa"
+
+ module Data = struct
+ type t = d
+ let pp fmt = function
+ | Lit (thterm,i,w) ->
+ let w,n = Context.Ref2.get w in
+ Format.fprintf fmt "Lit(%a,%i(%i,%i),%a)" ThE.pp thterm i w n
+ Node.pp (ThE.node thterm)
+ | All thterm -> Format.fprintf fmt "All(%a)" ThE.pp thterm
+ end
+
+ let immediate = false
+ let throttle = 100
+
+ let wakeup_lit d thterm watched watcher =
+ let v = ThE.sem thterm in
+ let own = ThE.node thterm in
+ let pexp exp = Egraph.mk_pexp d expprop exp in
+ let set_dom_up_true d own leaf _ =
+ let b = (not v.topnot) in
+ match Egraph.get_value d dom own with
+ | Some b' when Equal.bool b' b -> ()
+ | _ -> set_bool d (pexp (ExpUp(thterm,leaf))) own b in
+ let merge_bcp node sign =
+ Debug.dprintf2 debug "[Bool] @[merge_bcp %a@]" Node.pp node;
+ match Egraph.get_value d dom own with
+ | Some b' ->
+ let pexp = if (mulbool b' v.topnot)
+ then pexp (ExpBCP(thterm,node,BCPOwnKnown))
+ else pexp (ExpDown(thterm,node))
+ in
+ let b = mulbool sign (mulbool b' v.topnot) in
+ set_bool d pexp node b
+ | None -> (** merge *)
+ match Egraph.get_value d dom node with
+ | Some b' ->
+ let pexp = if (mulbool b' sign)
+ then pexp (ExpUp(thterm,node))
+ else pexp (ExpBCP(thterm,node,BCPLeavesKnown))
+ in
+ let b = mulbool sign (mulbool b' v.topnot) in
+ set_bool d pexp own b
+ | None -> (** merge *)
+ if mulbool v.topnot sign
+ then DaemonPropaNot.init d thterm node
+ else Egraph.merge d (pexp (ExpBCP(thterm,node,BCP))) own node in
+ let rec find_watch dir pos bound =
+ assert (dir = 1 || dir = -1);
+ if pos = bound
+ then
+ let node,sign = IArray.get v.lits pos in
+ (merge_bcp node sign; raise Exit)
+ else
+ let node,sign = IArray.get v.lits pos in
+ match Egraph.get_value d dom node with
+ | None -> node,pos
+ | Some b when mulbool b sign (** true absorbent of or *) ->
+ set_dom_up_true d own node b; raise Exit
+ | Some _ (** false *) -> find_watch dir (dir+pos) bound
+ in
+ try
+ let w1, w2 = Context.Ref2.get watcher in
+ if w1 = -1 (** already done *)
+ then false
+ else begin
+ assert (watched = w1 || watched = w2);
+ assert (w1 < w2);
+ let dir,bound = if watched = w1 then 1,w2 else -1,w1 in
+ let clwatched, watched = find_watch dir watched bound in
+ if dir = 1
+ then Context.Ref2.set1 watcher watched
+ else Context.Ref2.set2 watcher watched;
+ Demon.Fast.attach d key
+ [Demon.Create.EventValue(clwatched,dom,
+ Lit(thterm,watched,watcher))] ;
+ true
+ end
+ with Exit ->
+ Context.Ref2.set watcher (-1) (-1);
+ false
+
+ let wakeup_own d thterm =
+ let v = ThE.sem thterm in
+ let own = ThE.node thterm in
+ let pexp exp = Egraph.mk_pexp d expprop exp in
+ begin match Egraph.get_value d dom own with
+ | None -> (* only during init *)
+ Demon.Fast.attach d key
+ [Demon.Create.EventValue(own, dom, All thterm)];
+ true
+ (** \/ c1 c2 = false ==> c1 = false /\ c2 = false *)
+ | Some b when not (mulbool v.topnot b) ->
+ let set_dom_down_false (node,sign) =
+ set_bool d (pexp (ExpDown(thterm,node))) node sign in
+ IArray.iter set_dom_down_false v.lits;
+ false
+ | Some _ -> true
+ end
+
+ (** return true if things should be propagated *)
+ let init d thterm =
+ let v = ThE.sem thterm in
+ wakeup_own d thterm &&
+ let last = IArray.length v.lits - 1 in
+ assert (last <> 0);
+ let watcher = Context.Ref2.create (Egraph.context d) 0 last in
+ wakeup_lit d thterm 0 watcher &&
+ wakeup_lit d thterm last watcher
+
+ let wakeup d = function
+ | Events.Fired.EventValue(_,dom',Lit(thterm,watched,next)) ->
+ assert( ValueKind.equal dom dom' );
+ ignore (wakeup_lit d thterm watched next)
+ | Events.Fired.EventValue(_ownr,dom',All thterm) ->
+ assert( ValueKind.equal dom dom' );
+ (** use this own because the other is the representant *)
+ ignore (wakeup_own d thterm)
+ | _ -> raise UnwaitedEvent
+
+
+end
+
+module RDaemonPropa = Demon.Fast.Register(DaemonPropa)
+
+module DaemonInit = struct
+ let key = Demon.Fast.create "Bool.DaemonInit"
+
+ module Data = DUnit
+
+ let immediate = false
+ let throttle = 100
+ let wakeup d = function
+ | Events.Fired.EventRegSem(thterm,()) ->
+ begin try
+ let thterm = ThE.coerce_thterm thterm in
+ let v = ThE.sem thterm in
+ match isnot v with
+ | Some node ->
+ Egraph.register d node;
+ DaemonPropaNot.init d thterm node
+ | None ->
+ assert (not lazy_propagation);
+ IArray.iter (fun (node,_) -> Egraph.register d node) v.lits;
+ if DaemonPropa.init d thterm then ()
+ (** we could register a decision here, if we want to do
+ decision on any boolean operations not only variable *)
+ with Exit -> ()
+ end
+ | _ -> raise UnwaitedEvent
+
+end
+
+module RDaemonInit = Demon.Fast.Register(DaemonInit)
+
+
+let _true = node_true
+let _not node =
+ index sem {topnot = true; lits = IArray.of_list [node,false]}
+
+
+let filter fold_left =
+ let m = fold_left (fun acc (e,b) ->
+ Node.M.add_change (fun b -> b)
+ (fun b1 b2 -> if Equal.bool b1 b2 then b1 else raise Exit) e b acc)
+ Node.M.empty in
+ Node.M.bindings m
+
+let gen topnot l =
+ try
+ let l = filter (fun f acc -> List.fold_left f acc l) in
+ match l with
+ | [] -> if topnot then node_true else node_false
+ | [node,b] when mulbool topnot b -> _not node
+ | [node,_] -> node
+ | l ->
+ index sem {topnot; lits = IArray.of_list l}
+ with Exit -> if topnot then node_false else node_true
+
+let _or_and b l =
+ try
+ let l = filter (fun f acc ->
+ List.fold_left (fun acc e -> f acc (e,b)) acc l) in
+ match l with
+ | [] -> if b then node_true else node_false
+ | [a,b'] -> assert (Equal.bool b b'); a
+ | l ->
+ index sem {topnot = b; lits = IArray.of_list l}
+ with Exit -> if b then node_false else node_true
+
+let _or = _or_and false
+let _and = _or_and true
+
+let mk_clause m =
+ if Node.M.is_empty m then node_false
+ else let len = Node.M.cardinal m in
+ if len = 1 then
+ let node,b = Node.M.choose m in
+ if b then _not node else node
+ else
+ index sem {topnot=false;
+ lits = IArray.of_iter len
+ (fun iter -> Node.M.iter (fun node b -> iter (node,b)) m)}
+
+let _false = node_false
+
+let set_true env pexp node = set_bool env pexp node true
+
+let () =
+ let gen_or l =
+ let l = List.map (function
+ | (n,Conflict.Pos) -> (n,false)
+ | (n,Conflict.Neg) -> (n,true)) l in
+ gen false l in
+ Conflict._or := gen_or;
+ Conflict._set_true := set_true;
+ Conflict._is_true := is_true
+
+let set_false env pexp node = set_bool env pexp node false
+
+let chobool = Trail.Cho.create_key (module struct type t = Node.t let name = "Bool.cho" end)
+let make_dec node = Trail.GCho(node,chobool,node)
+
+let converter d f l =
+ let of_term t =
+ let n = SynTerm.node_of_term t in
+ Egraph.register d n;
+ n
+ in
+ let node = match f, l with
+ | f,args when Term.is_or_term f ->
+ Some (_or (List.map of_term args))
+ | f,args when Term.is_and_term f ->
+ Some (_and (List.map of_term args))
+ | f,[arg1;arg2] when Term.equal f Term.imply_term ->
+ Some (gen false [of_term arg1,true;of_term arg2,false])
+ | f,[arg] when Term.equal f Term.not_term ->
+ Some (_not (of_term arg))
+ | f,[] when Term.equal f Term.true_term ->
+ Some _true
+ | f,[] when Term.equal f Term.false_term ->
+ Some _false
+ | _ -> None in
+ node
+
+let decvars n =
+ if Ty.equal (Node.ty n) ty
+ then Some (make_dec n)
+ else None
+
+let th_register env =
+ RDaemonPropaNot.init env;
+ RDaemonPropa.init env;
+ RDaemonInit.init env;
+ Demon.Fast.attach env
+ DaemonInit.key [Demon.Create.EventRegSem(sem,())];
+ Egraph.register env node_true;
+ Egraph.register env node_false;
+ SynTerm.register_converter env converter;
+ SynTerm.register_decvars env decvars;
+ ()
+
+(** {2 Choice on bool} *)
+
+module ChoBool = struct
+ open Conflict
+
+ module OnWhat = Node
+ module What = DBool
+
+ let make_decision env node b =
+ Debug.dprintf3 print_decision "[Bool] decide %b on %a" b Node.pp node;
+ let pexp = Egraph.mk_pexp env expprop (ExpDec(node,b)) in
+ set_bool env pexp node b
+
+ let choose_decision env node =
+ match Egraph.get_value env dom node with
+ | Some _ -> DecNo
+ | None -> DecTodo (fun env -> make_decision env node true) (** why not true? *)
+
+ let key = chobool
+
+end
+
+let () = Conflict.register_cho (module ChoBool)
+
+(** {2 Conflict} *)
+
+(** We could use instead directly EqHyp, but it gives an example of a
+ simple conflict other than EqHyp *)
+module HypProp = struct
+ type t = (Node.t * bool)
+
+ let pp fmt (n,b) =
+ if b
+ then Format.fprintf fmt "¬%a" Node.pp n
+ else Node.pp fmt n
+
+ let key = Trail.Hyp.create_key (module struct type nonrec t = t let name = "hypprop" end)
+
+ let apply_learnt (n,b) = (n,if b then Conflict.Neg else Conflict.Pos)
+
+ let node_of_sign b = (node_of_bool (mulbool true b))
+
+ let levels t (n,b) =
+ let levels = Conflict.Levels.empty in
+ let age = Conflict.Conflict.age_merge t n (node_of_sign b) in
+ Conflict.Levels.add t age levels
+
+ let useful_nodes (n,_) = Bag.elt n
+
+ let split t (n,b) a' b' =
+ let l', r' = Conflict.EqHyp.split t {l=n;r=node_of_sign b} a' b' in
+ (match l' with
+ | None -> []
+ | Some r -> [Trail.Phyp.phyp Conflict.EqHyp.key {l=n; r}])
+ @
+ (match r' with
+ | None -> []
+ | Some l -> [Trail.Phyp.phyp key (l,b)])
+
+end
+
+let () = Conflict.register_hyp (module HypProp)
+
+(** {2 Explanation} *)
+
+module ExpProp = struct
+ open Conflict
+ type t = expprop
+
+ let pp fmt = function
+ | ExpBCP (thterm,node,kind) ->
+ Format.fprintf fmt "Bcp(%a,%a = %a;%t)"
+ ThE.pp thterm Node.pp (ThE.node thterm) Node.pp node
+ (fun _ -> match kind with
+ | BCPOwnKnown -> Format.fprintf fmt "Own"
+ | BCPLeavesKnown -> Format.fprintf fmt "Leaves"
+ | BCP -> ())
+ | ExpUp (thterm,leaf) ->
+ Format.fprintf fmt "Up(%a,%a <- %a)"
+ ThE.pp thterm Node.pp (ThE.node thterm) Node.pp leaf
+ | ExpDown (thterm,node) ->
+ Format.fprintf fmt "Down(%a,%a,%a ->)"
+ ThE.pp thterm Node.pp (ThE.node thterm) Node.pp node
+ | ExpNot ((v,clf,clt),b) ->
+ Format.fprintf fmt "Not(%a,%a,%a,%b)"
+ Th.pp v Node.pp clf Node.pp clt b
+ | ExpDec (n,b) ->
+ Format.fprintf fmt "Dec(%a,%b)"
+ Node.pp n b
+
+ let eq_of_bool ?dec n b =
+ Trail.Phyp.phyp ?dec HypProp.key (n,not b)
+
+ let analyse_one_to_one ?dec t phyp to_ to_b from_ from_b =
+ (** we have
+ c: a = b
+ we propagated: to_ = to_b
+ because : from_ = from_b
+ *)
+ let to_not = node_of_bool to_b in
+ let eqs = Conflict.split t phyp to_ to_not in
+ let eq = eq_of_bool ?dec from_ from_b in
+ Debug.dprintf10 debug "clfrom:%a from_b:%b clto:%a to_b:%b eqs:%a eq:%a"
+ Node.pp from_
+ from_b
+ Node.pp to_
+ to_b
+ (Format.(list ~sep:(const char ',') pp_phyp))
+ eqs
+ pp_phyp eq;
+ (eq::eqs)
+
+ let analyse :
+ Conflict.t ->
+ t -> Trail.Phyp.t -> Trail.Phyp.t list =
+ fun t exp phyp ->
+ match exp with
+ | ExpBCP (thterm,_,_) when IArray.length (ThE.sem thterm).lits = 1 ->
+ raise Impossible
+ | ExpBCP (thterm,propa,kind) ->
+ let v = ThE.sem thterm in
+ let own = ThE.node thterm in
+ let eqs =
+ match kind with
+ | BCP -> Conflict.split t phyp own propa
+ | BCPOwnKnown ->
+ let propa_sign = mulbool true (Opt.get (find v propa)) in
+ Conflict.split t phyp propa (node_of_bool propa_sign)
+ | BCPLeavesKnown ->
+ let sign = mulbool false v.topnot in
+ Conflict.split t phyp propa (node_of_bool sign)
+ in
+ let eqs = if equal_bcpkind kind BCPOwnKnown then (eq_of_bool own (mulbool true v.topnot))::eqs else eqs in
+ fold (fun eqs (node,sign) ->
+ if (not(equal_bcpkind kind BCPLeavesKnown)) && (Node.equal node propa) then eqs
+ else (eq_of_bool node (mulbool false sign))::eqs) eqs v
+ | ExpUp (thterm,leaf) ->
+ let v = ThE.sem thterm in
+ let own = ThE.node thterm in
+ analyse_one_to_one t phyp
+ own (mulbool true v.topnot)
+ leaf (mulbool true (Opt.get (find v leaf)))
+ | ExpDown (thterm,leaf) ->
+ let v = ThE.sem thterm in
+ let own = ThE.node thterm in
+ analyse_one_to_one t phyp
+ leaf (mulbool false (Opt.get (find v leaf)))
+ own (mulbool false v.topnot)
+ | ExpNot ((_,clfrom,clto),b)->
+ analyse_one_to_one t phyp
+ clto b
+ clfrom (not b)
+ | ExpDec (cl,b) ->
+ analyse_one_to_one ~dec:() t phyp
+ cl b
+ cl b
+
+ let key = expprop
+
+ let from_contradiction _ _ =
+ assert false (** absurd: never used for contradiction *)
+end
+
+let () = Conflict.register_exp(module ExpProp)
+
+let () =
+ let parity_of_bool b = if b then Conflict.Neg else Conflict.Pos in
+ Conflict.EqHyp.register_apply_learnt ty
+ (fun {Conflict.EqHyp.l;r} ->
+ if Node.equal l node_false
+ then (r,parity_of_bool true)
+ else if Node.equal l node_true
+ then (r,parity_of_bool false)
+ else if Node.equal r node_false
+ then (l,parity_of_bool true)
+ else if Node.equal r node_true
+ then (l,parity_of_bool false)
+ else !Conflict._equality l r, Pos
+ )
+
+(** {2 Interpretations} *)
+let () =
+ let interp ~interp t =
+ let v =
+ IArray.fold (fun acc (n,b) ->
+ acc ||
+ let v = BoolValue.value (BoolValue.coerce_nodevalue (interp n)) in
+ if b then not v else v
+ ) false t.lits
+ in
+ let v = if t.topnot then not v else v in
+ BoolValue.nodevalue (if v then value_true else value_false)
+ in
+ Interp.Register.thterm sem interp
+
+let default_value = true
+
+let () =
+ Interp.Register.model ty (fun d n ->
+ let v = Egraph.get_value d dom n in
+ let v = Witan_popop_lib.Opt.get_def default_value v in
+ let v = if v then values_true else values_false in
+ v)
+
+
+
+
+let () =
+ Interp.Register.id (fun id args ->
+ let open Term in
+ let is builtin = Term.Id.equal id builtin in
+ let (!>) n = BoolValue.value (BoolValue.coerce_nodevalue n) in
+ let (!<) b = Some (if b then values_true else values_false) in
+ match args with
+ | [] when is true_id -> Some values_true
+ | [] when is false_id -> Some values_false
+ | [a] when is not_id -> !< (not (!> a))
+ | l when is_or_id id -> !< (List.fold_left (||) false (List.map (!>) l))
+ | l when is_and_id id -> !< (List.fold_left (&&) true (List.map (!>) l))
+ | _ -> None
+ )
diff --git a/src/theories/bool/boolean.mli b/src/theories/bool/boolean.mli
new file mode 100644
index 000000000..cf84af45a
--- /dev/null
+++ b/src/theories/bool/boolean.mli
@@ -0,0 +1,62 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_core_structures
+
+type t
+val sem: t ThTermKind.t
+val dom: bool ValueKind.t
+
+val _true : Node.t
+val _false : Node.t
+val _and : Node.t list -> Node.t
+val _or : Node.t list -> Node.t
+val _not : Node.t -> Node.t
+val gen : bool -> (Node.t * bool) list -> Node.t
+(** [gen d b0 [cl1,b1;cl2,c2]] is
+ not_b0 (or (not_b1 cl1,not_b2 cl2)) with not_x f = if x then not f else f
+*)
+
+val set_true : Egraph.t -> Trail.Pexp.t -> Node.t -> unit
+val set_false : Egraph.t -> Trail.Pexp.t -> Node.t -> unit
+
+val is : Egraph.t -> Node.t -> bool option
+val is_true : Egraph.t -> Node.t -> bool
+val is_false : Egraph.t -> Node.t -> bool
+(** is_true t node = false means the value is not constrained by the
+ current constraints or due to incompletness *)
+val is_unknown : Egraph.t -> Node.t -> bool
+
+(* val true_is_false : Egraph.d -> Node.t -> Trail.Pexp.t -> 'a *)
+
+val th_register: Egraph.t -> unit
+
+val chobool: Node.t Trail.Cho.t
+
+(* val make_dec: Variable.make_dec *)
+
+val ty: Ty.t
+
+module BoolValue : ValueKind.Registered with type s = bool
+
+val value_true : BoolValue.t
+val value_false: BoolValue.t
+val values_true : Value.t
+val values_false: Value.t
diff --git a/src/theories/bool/dune b/src/theories/bool/dune
new file mode 100644
index 000000000..9d88d4ee3
--- /dev/null
+++ b/src/theories/bool/dune
@@ -0,0 +1,13 @@
+(library
+ (name witan_theories_bool)
+ (public_name witan.theories.bool)
+ (synopsis "theories for witan")
+ (modules Boolean Equality Uninterp)
+ (libraries containers ocamlgraph witan.stdlib witan.popop_lib
+ witan.core.structures witan.core)
+ (preprocess
+ (pps ppx_deriving.std))
+ (flags :standard -w +a-4-42-44-48-50-58-32-60-40-9@8 -color always -open
+ Containers -open Witan_stdlib -open Std -open Witan_core)
+ (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures
+ -unbox-closures-factor 20))
diff --git a/src/theories/bool/equality.ml b/src/theories/bool/equality.ml
new file mode 100644
index 000000000..b673b8329
--- /dev/null
+++ b/src/theories/bool/equality.ml
@@ -0,0 +1,887 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Popop_stdlib
+open Witan_core
+
+let debug = Debug.register_info_flag
+ ~desc:"for the equality and disequality predicate"
+ "disequality"
+
+(** {2 theory term} *)
+
+type t = Node.S.t
+(** Is there two elements equal *)
+
+let sem = ThTermKind.create_key (module struct type nonrec t = t let name = "Eq" end)
+
+module Th = struct
+
+ let get_ty v = Node.ty (fst (Node.M.choose v))
+
+ let inv s = not (Node.M.is_empty s || Node.M.is_num_elt 1 s) &&
+ let ty = get_ty s in
+ (Node.M.for_all (fun e _ -> Ty.equal ty (Node.ty e)) s)
+
+ let only_two s =
+ assert (inv s);
+ if Node.M.is_num_elt 2 s then
+ let enum = Node.M.start_enum s in
+ let (cl1,()), enum = Opt.get (Node.M.val_enum enum), Node.M.next_enum enum in
+ let (cl2,()) = Opt.get (Node.M.val_enum enum) in
+ Some (cl1,cl2)
+ else None
+
+
+ module T : OrderedHashedType with type t = Node.S.t = struct
+ include Node.S
+
+ let hash s = Node.S.fold (fun e acc -> Hashcons.combine acc (Node.hash e)) s 29
+
+ let pp fmt s =
+ assert (inv s);
+ match only_two s with
+ | Some (cl1,cl2) ->
+ Format.fprintf fmt "%a=@,%a" Node.pp cl1 Node.pp cl2
+ | None ->
+ let aux fmt m = Node.S.elements m
+ |> Format.(list ~sep:(const char ',') Node.pp) fmt
+ in
+ Format.fprintf fmt "or=(%a)" aux s
+ end
+
+ include T
+ include MkDatatype(T)
+
+ let key = sem
+
+end
+
+module ThE = ThTermKind.Register(Th)
+
+(** {2 disequality domains} *)
+
+module Dis : sig
+ type t
+ type elt
+ val pp: t Format.printer
+ val empty: t
+ val of_node: ThE.t -> elt
+ val to_node: elt -> ThE.t
+ val test_disjoint: (elt -> Trail.Age.t -> unit) -> t -> t -> t
+ val disjoint : t -> t -> bool
+ val singleton : elt -> Trail.Age.t -> t
+ val inter : t -> t -> t
+ val is_empty : t -> bool
+ val choose : t -> elt * Trail.Age.t
+ val iter : (elt -> Trail.Age.t -> unit) -> t -> unit
+end = struct
+ type t = Trail.Age.t ThE.M.t
+ type elt = ThE.t
+ let empty = ThE.M.empty
+ let pp fmt s =
+ let aux fmt m =
+ ThE.M.bindings m
+ |> Format.(list ~sep:(const char ';')
+ (pair ~sep:(const char ',') ThE.pp Trail.Age.pp)) fmt
+ in
+ Format.fprintf fmt "{%a}" aux s
+ let of_node x = x
+ let to_node x = x
+ let test_disjoint f m1 m2 =
+ ThE.M.union (fun k v1 v2 -> assert (Trail.Age.equal v1 v2); f k v1; Some v1) m1 m2
+ let disjoint = ThE.M.set_disjoint
+ let singleton = ThE.M.singleton
+ let is_empty = ThE.M.is_empty
+ let inter m1 m2 = ThE.M.inter (fun _ v1 v2 -> assert (Trail.Age.equal v1 v2); Some v2) m1 m2
+ let choose m1 = ThE.M.choose m1
+ let iter = ThE.M.iter
+end
+
+let dom = DomKind.create_key (module struct type t = Dis.t let name = "dis" end)
+
+(** For each value key give the value *)
+module MValues = ValueKind.MkMap(struct type ('a, _) t = 'a end)
+
+type exp =
+ | Merge of Trail.Pexp.t * Node.t * Node.t * Dis.elt * Trail.Age.t
+ | SubstUpTrue of ThE.t * Node.t (* e1 *) * Node.t (* e2 *) * Node.t
+ | SubstUpFalse of ThE.t * (Node.t * (Dis.t option * unit MValues.t)) list
+ | SubstDownTrue of ThE.t
+ | SubstDownFalse of ThE.t * Dis.elt
+ | Dec of Node.t * Node.t
+
+let exp = Trail.Exp.create_key (module struct type t = exp let name = "Equality" end)
+
+module D = struct
+ type t = Dis.t
+
+ let merged (b1:t option) (b2 :t option) =
+ match b1,b2 with
+ | Some b1, Some b2 -> Equal.physical b1 b2 (** not Dis.equality *)
+ (* Really? Explanation needed...*)
+ | None, None -> true
+ | _ -> false
+
+ let merge d pexp (s1,cl1) (s2,cl2) _ =
+ match s1, s2 with
+ | None, None -> raise Impossible
+ | Some s, None ->
+ Egraph.set_dom d dom cl2 s
+ | None, Some s ->
+ Egraph.set_dom d dom cl1 s
+ | Some s1, Some s2 ->
+ let s = Dis.test_disjoint (fun i age ->
+ let pexp = Egraph.mk_pexp d exp (Merge(pexp,cl1,cl2,i,age)) in
+ Egraph.contradiction d pexp) s1 s2 in
+ Egraph.set_dom d dom cl1 s;
+ Egraph.set_dom d dom cl2 s
+
+
+ let pp fmt s = Dis.pp fmt s
+ let key = dom
+end
+
+let () = DomKind.register(module D)
+
+let set_dom d _pexp cl s =
+ let s = match Egraph.get_dom d dom cl with
+ | Some s' ->
+ Dis.test_disjoint (fun _ -> assert false) s' s
+ | None -> s in
+ Egraph.set_dom d dom cl s
+
+let check_sem v cl =
+ let own = ThE.node (ThE.index v Boolean.ty) in
+ Node.equal cl own
+
+(** API *)
+
+let equality cll =
+ try
+ let fold acc e = Node.S.add_new Exit e acc in
+ let s = List.fold_left fold Node.S.empty cll in
+ ThE.node (ThE.index s Boolean.ty)
+ with Exit ->
+ Boolean._true
+
+let disequality cll = Boolean._not (equality cll)
+
+let is_equal t cl1 cl2 = Egraph.is_equal t cl1 cl2
+let is_disequal t cl1 cl2 =
+ not (Egraph.is_equal t cl1 cl2) &&
+ let dom1 = Egraph.get_dom t dom cl1 in
+ let dom2 = Egraph.get_dom t dom cl2 in
+ match dom1, dom2 with
+ | Some s1, Some s2 -> not (Dis.disjoint s1 s2)
+ | _ -> false
+
+let new_tag n age =
+ let n = Dis.of_node n in
+ n, fun () -> Dis.singleton n age (** each instance of this tag must not be == *)
+
+exception Found of Node.t * Node.t
+
+let find_not_disequal d s =
+ let is_disequal (dis1,values1) (dis2,values2) =
+ (match dis1, dis2 with
+ | Some dis1, Some dis2 when not (Dis.disjoint dis1 dis2) -> true
+ | _ -> false) ||
+ (try
+ let fold2_inter (type a) (k:a ValueKind.t) v1 v2 () =
+ let (module V) = ValueKind.get k in
+ if not (V.equal v1 v2) then raise Exit
+ in
+ MValues.fold2_inter {fold2_inter} values1 values2 ();
+ false
+ with Exit -> true)
+ in
+ let get_dis_and_values cl =
+ Egraph.get_dom d dom cl,
+ ValueKind.fold {fold=(fun k acc ->
+ match Egraph.get_value d k cl with
+ | None -> acc
+ | Some v -> MValues.add k v acc)}
+ MValues.empty
+ in
+ assert (Th.inv s);
+ let rec inner_loop cl1 s1 enum2 =
+ match enum2, s1 with
+ | [],_ -> ()
+ | (_,d1)::enum2,d2 when is_disequal d1 d2 ->
+ inner_loop cl1 s1 enum2
+ | (cl2,_)::_,_ ->
+ raise (Found (cl1,cl2))
+ in
+ let rec outer_loop enum1 =
+ match enum1 with
+ | [] -> ()
+ | (cl1,s1)::enum1 ->
+ inner_loop cl1 s1 enum1;
+ outer_loop enum1 in
+ try
+ let s = Node.M.fold_left (fun acc cl () ->
+ (cl,get_dis_and_values cl)::acc) [] s in
+ outer_loop s;
+ (** Here we are keeping data because currently
+ we are not keeping data for domains globally *)
+ `AllDiff s
+ with Found (cl1,cl2) ->
+ `Found (cl1,cl2)
+
+let norm_set d the =
+ let v = ThE.sem the in
+ let own = ThE.node the in
+ try
+ ignore (Node.S.fold_left (fun acc e0 ->
+ let e = Egraph.find_def d e0 in
+ Node.M.add_change (fun _ -> e0)
+ (fun e0 e0' -> raise (Found(e0',e0)))
+ e e0 acc)
+ Node.M.empty v);
+ false
+ with Found (e1,e2) ->
+ (** TODO remove that and choose what to do. ex: int real *)
+ let pexp = Egraph.mk_pexp d exp (SubstUpTrue (the,e1,e2,own)) in
+ Boolean.set_true d pexp own;
+ true
+
+module ChoEquals = struct
+ open Conflict
+
+ module OnWhat = ThE
+
+ let key = Trail.Cho.create_key (module struct type t = ThE.t let name = "Equals.cho" end)
+
+ let make_decision the (cl1,cl2) d =
+ Debug.dprintf6 print_decision
+ "[Equality] @[decide on merge of %a and %a in %a@]"
+ Node.pp cl1 Node.pp cl2 ThE.pp the;
+ let pexp = Egraph.mk_pexp d exp (Dec(cl1,cl2)) in
+ Egraph.register d cl1;
+ Egraph.register d cl2;
+ Egraph.merge d pexp cl1 cl2
+
+ let choose_decision d the =
+ let v = ThE.sem the in
+ let own = ThE.node the in
+ Debug.dprintf4 debug "[Equality] @[dec on %a for %a@]"
+ Node.pp own ThE.pp the;
+ if norm_set d the
+ then DecNo
+ else
+ match find_not_disequal d v with
+ | `AllDiff al ->
+ let pexp = Egraph.mk_pexp d exp (SubstUpFalse(the,al)) in
+ Boolean.set_false d pexp own;
+ DecNo
+ | `Found (cl1,cl2) ->
+ DecTodo (make_decision the (cl1,cl2))
+
+end
+
+let () = Conflict.register_cho(module ChoEquals)
+
+let norm_dom d the =
+ let v = ThE.sem the in
+ let own = ThE.node the in
+ if norm_set d the
+ then Demon.AliveStopped
+ else begin
+ Debug.dprintf4 debug "[Equality] @[norm_dom %a %a@]"
+ Node.pp own Th.pp v;
+ match Boolean.is d own with
+ | Some false ->
+ let age = Trail.Age.succ (Egraph.current_age d) in
+ let dis, stag = new_tag the age in
+ let pexp =
+ Egraph.mk_pexp d exp (SubstDownFalse(the,dis)) in
+ Egraph.add_pexp d pexp;
+ Node.S.iter (fun cl -> set_dom d pexp cl (stag ())) v;
+ Demon.AliveStopped
+ | Some true ->
+ begin match Th.only_two v with
+ | Some (cl1,cl2) ->
+ let pexp = Egraph.mk_pexp d exp (SubstDownTrue(the)) in
+ Egraph.merge d pexp cl1 cl2; Demon.AliveStopped
+ | None ->
+ match find_not_disequal d v with
+ | `AllDiff al ->
+ let pexp = Egraph.mk_pexp d exp (SubstUpFalse(the,al)) in
+ Boolean.set_false d pexp own; (** contradiction *)
+ raise Impossible
+ | `Found _ ->
+ Demon.AliveStopped
+ end
+ | None ->
+ match find_not_disequal d v with
+ | `AllDiff al ->
+ let pexp = Egraph.mk_pexp d exp (SubstUpFalse(the,al)) in
+ Boolean.set_false d pexp own;
+ Demon.AliveStopped
+ | `Found _ -> (** they are still not proved disequal *)
+ Demon.AliveReattached
+ end
+
+(** Propagation *)
+
+module DaemonPropa = struct
+ let key = Demon.Key.create "Equality.DaemonPropa"
+
+ module Key = Th
+ module Data = DUnit
+ type info = unit let default = ()
+
+ let immediate = false
+ let wakeup d v _ev () =
+ norm_dom d (ThE.index v Boolean.ty)
+
+end
+
+module RDaemonPropa = Demon.Key.Register(DaemonPropa)
+
+module DaemonInit = struct
+ let key = Demon.Key.create "Equality.DaemonInit"
+
+ module Key = DUnit
+ module Data = DUnit
+ type info = unit let default = ()
+
+ let immediate = true
+ let wakeup d () ev () =
+ List.iter
+ (function Events.Fired.EventRegSem(clsem,()) ->
+ begin
+ let clsem = ThE.coerce_thterm clsem in
+ let v = ThE.sem clsem in
+ let own = ThE.node clsem in
+ Node.S.iter (Egraph.register d) v;
+ let r = norm_dom d clsem in
+ begin match r with
+ | Demon.AliveReattached ->
+ let events = Node.S.fold (fun cl acc ->
+ (Demon.Create.EventChange(cl,()))::
+ (Demon.Create.EventDom(cl,dom,()))::
+ (Demon.Create.EventAnyValue(cl,()))::
+ acc
+ ) v [] in
+ let events = Demon.Create.EventValue(own,Boolean.dom,())::events in
+ Demon.Key.attach d DaemonPropa.key v events;
+ if true (* GenEquality.dodec (Th.get_ty v) *) then begin
+ Debug.dprintf4 debug "[Equality] @[ask_dec on %a for %a@]"
+ Node.pp own Th.pp v;
+ Egraph.register_decision d (Trail.GCho(own,ChoEquals.key,clsem));
+ end
+ | _ -> ()
+ end
+ end
+ | _ -> raise UnwaitedEvent
+ ) ev;
+ Demon.AliveReattached
+
+end
+
+module RDaemonInit = Demon.Key.Register(DaemonInit)
+
+
+(** conflict *)
+module HypDis = struct
+ open Conflict
+
+ type t = {
+ l1 : Node.t;
+ l0 : Node.t;
+ r0 : Node.t;
+ r1 : Node.t;
+ disequality : Node.t;
+ age : Trail.Age.t;
+ }
+
+ let key = Trail.Hyp.create_key (module struct type nonrec t = t let name = "Diff" end)
+
+ let pp fmt c =
+ Format.fprintf fmt "%a=%a≠%a=%a"
+ Node.pp c.l1
+ Node.pp c.l0
+ Node.pp c.r0
+ Node.pp c.r1
+
+ let split t c cl1 cl2 =
+ if Equal.option Trail.Age.equal (Conflict.age_merge_opt t cl1 c.l1) None then
+ let cl1, cl2 = EqHyp.orient_split t {l=c.r0;r=c.r1} cl1 cl2 in
+ (Trail.Phyp.phyp key {c with r1 = cl1})::(EqHyp.create_eq cl2 c.r1)
+ else
+ let cl1, cl2 = EqHyp.orient_split t {l=c.l0;r=c.l1} cl1 cl2 in
+ (Trail.Phyp.phyp key {c with l1 = cl1})::(EqHyp.create_eq cl2 c.l1)
+
+
+ let useful_nodes c =
+ Bag.list [c.l1;c.l0;c.r1;c.r0]
+
+ let levels t c =
+ let l = Levels.empty in
+ let l = Levels.add t (Conflict.age_merge t c.l1 c.l0) l in
+ let l = Levels.add t (Conflict.age_merge t c.r1 c.r0) l in
+ let l = Levels.add t c.age l in
+ l
+
+ let apply_learnt c =
+ let n, par = EqHyp.apply_learnt {l=c.l1;r=c.r1} in
+ n, neg_parity par
+
+ let create_diff_far t cl1 cl2 i age =
+ let find_origin v cl =
+ Node.S.fold_left (fun acc cl0 ->
+ match acc with
+ | Some _ -> acc
+ | None ->
+ match Conflict.age_merge_opt t cl cl0 with
+ | Some _ -> Some cl0
+ | None -> None) None v
+ in
+ let the = Dis.to_node i in
+ let v = ThE.sem the in
+ let cl1_0 = Opt.get (find_origin v cl1) in
+ let cl2_0 = Opt.get (find_origin v cl2) in
+ let diff = Trail.Phyp.phyp key {l1=cl1;l0=cl1_0;r0=cl2_0;r1=cl2;disequality=ThE.node the; age} in
+ diff
+
+ let create_diff_near t cl1 cl2 i age =
+ let find_origin v cl =
+ Node.S.fold_left (fun acc cl0 ->
+ match acc with
+ | Some _ -> acc
+ | None ->
+ match Conflict.age_merge_opt t cl cl0 with
+ | Some _ -> Some cl0
+ | None -> None) None v
+ in
+ let the = Dis.to_node i in
+ let v = ThE.sem the in
+ let cl1_0 = Opt.get (find_origin v cl1) in
+ let cl2_0 = Opt.get (find_origin v cl2) in
+ let diff = Trail.Phyp.phyp key {l1=cl1_0;l0=cl1_0;r0=cl2_0;r1=cl2_0;disequality=ThE.node the; age} in
+ diff, (Trail.Phyp.phyp EqHyp.key {l=cl1_0;r=cl2_0})
+
+end
+
+let () = Conflict.register_hyp(module HypDis)
+
+module Exp = struct
+ open Conflict
+
+ type t = exp
+
+ let pp fmt = function
+ | Merge (pexp,cl1,cl2,i,_) ->
+ Format.fprintf fmt "Merge!(%a,%a,%a,%a)"
+ pp_pexp pexp Node.pp cl1 Node.pp cl2 ThE.pp (Dis.to_node i)
+ | SubstUpTrue (v,e1,e2,cl) -> (** two are equals *)
+ Format.fprintf fmt "SubstUpTrue(%a,%a,%a,%a)"
+ ThE.pp v Node.pp e1 Node.pp e2 Node.pp cl
+ | SubstUpFalse (the,_) ->
+ Format.fprintf fmt "SubstUpFalse(%a)" ThE.pp the
+ | SubstDownTrue (the) ->
+ Format.fprintf fmt "SubstDownTrue(%a)" ThE.pp the
+ | SubstDownFalse (v,i) ->
+ Format.fprintf fmt "SubstDownFalse(%a,%a)"
+ ThE.pp v ThE.pp (Dis.to_node i)
+ | Dec (n1,n2) ->
+ Format.fprintf fmt "Dec(%a,%a)"
+ Node.pp n1 Node.pp n2
+
+ let analyse t e phyp =
+ match e with
+ | SubstUpTrue (v,e1,e2,_) -> (** two are equals *)
+ let own = ThE.node v in
+ let lhyp = Conflict.split t phyp own Boolean._true in
+ let phyp = Trail.Phyp.phyp EqHyp.key {l=e1;r=e2} in
+ phyp::lhyp
+ | SubstUpFalse (v,al) ->
+ let own = ThE.node v in
+ let lhyp = Conflict.split t phyp own Boolean._false in
+ let al = CCList.diagonal al in
+ let fold lhyp ((e1,(dis1,val1)),(e2,(dis2,val2))) =
+ let diff_value () = (** different values *)
+ let fold2_inter (type a) (k:a ValueKind.t) v1 v2 acc =
+ let (module V) = ValueKind.get k in
+ if not (V.equal v1 v2) then
+ (EqHyp.create_eq e1 (Node.index_value k v1 (Node.ty e1))) @
+ (EqHyp.create_eq e2 (Node.index_value k v2 (Node.ty e2))) @
+ acc
+ else acc
+ in
+ let lhyp' = MValues.fold2_inter {fold2_inter} val1 val2 lhyp in
+ assert (not (Equal.physical lhyp lhyp')); (** One is different *)
+ lhyp'
+ in
+ match dis1, dis2 with
+ | Some dis1, Some dis2 ->
+ let dis = Dis.inter dis1 dis2 in
+ if Dis.is_empty dis
+ then diff_value ()
+ else
+ (** choose the oldest? *)
+ let d,age = Dis.choose dis in
+ let diff = HypDis.create_diff_far t e1 e2 d age in
+ diff::lhyp
+ | _ -> diff_value ()
+ in
+ List.fold_left fold lhyp al
+ | SubstDownTrue (the) -> begin
+ let v = ThE.sem the in
+ match Node.S.elements v with
+ | [a;b] ->
+ let lhyp = Conflict.split t phyp a b in
+ (EqHyp.create_eq (ThE.node the) Boolean._true)@lhyp
+ | _ -> raise Impossible
+ end
+ | SubstDownFalse (the,_) ->
+ let Trail.Phyp.Phyp(hyp,c,_) = phyp in
+ let c = Hyp.Eq.coerce hyp HypDis.key c in
+ let lhyp = [] in
+ let lhyp = (EqHyp.create_eq c.l1 c.l0)@lhyp in
+ let lhyp = (EqHyp.create_eq c.r1 c.r0)@lhyp in
+ let lhyp = (EqHyp.create_eq (ThE.node the) Boolean._false)@lhyp in
+ lhyp
+ | Dec(n1,n2) ->
+ let lhyp = Conflict.split t phyp n1 n2 in
+ let eq = EqHyp.create_eq ~dec:() n1 n2 in
+ eq@lhyp
+ | Merge(pexp,cl1,cl2,i,age) ->
+ assert (Equal.physical pexp (Trail.pexp_fact));
+ (** only for bool currently *)
+ let cl2' = if Node.equal cl2 Boolean._true then Boolean._false else Boolean._true in
+ let lhyp = Conflict.split t phyp cl1 cl2' in
+ let diff = HypDis.create_diff_far t cl1 cl2 i age in
+ diff::lhyp
+
+ let key = exp
+
+ let far_disequality = Debug.register_flag "far-disequality"
+ ~desc:"Instead of explaining conflict with distinct near the disequality, explain it far from it"
+
+ let from_contradiction t = function
+ | Merge(pexp,cl1,cl2,i,age) ->
+ if Debug.test_flag far_disequality then
+ let lhyp = Conflict.analyse t pexp (Trail.Phyp.phyp EqHyp.key {l=cl1;r=cl2}) in
+ let diff = HypDis.create_diff_far t cl1 cl2 i age in
+ diff::lhyp
+ else
+ let diff, eq = HypDis.create_diff_near t cl1 cl2 i age in
+ let lhyp = Conflict.analyse t pexp eq in
+ diff::lhyp
+ | _ -> raise Impossible
+
+end
+
+
+let () = Conflict.register_exp(module Exp)
+
+
+(** ITE *)
+type ite = {cond: Node.t; then_: Node.t; else_: Node.t}
+
+module ITE = struct
+
+ module TITE = struct
+ type t = ite
+ let equal x y = Node.equal x.cond y.cond &&
+ Node.equal x.then_ y.then_ &&
+ Node.equal x.else_ y.else_
+ let compare x y =
+ let c = Node.compare x.cond y.cond in
+ if c <> 0 then c
+ else let c = Node.compare x.then_ y.then_ in
+ if c <> 0 then c
+ else Node.compare x.else_ y.else_
+ let hash x =
+ Hashcons.combine2 (Node.hash x.cond) (Node.hash x.then_) (Node.hash x.else_)
+
+ let pp fmt x =
+ Format.fprintf fmt "ite(%a,%a,%a)"
+ Node.pp x.cond Node.pp x.then_ Node.pp x.else_
+ end
+
+ include TITE
+ include MkDatatype(TITE)
+
+ let key = ThTermKind.create_key (module struct type nonrec t = t let name = "ite" end)
+
+end
+
+module EITE = ThTermKind.Register(ITE)
+
+let ite cond then_ else_ =
+ let ty1 = Node.ty then_ in
+ let ty2 = Node.ty else_ in
+ assert (Ty.equal ty1 ty2);
+ Node.index_sem ITE.key { cond; then_; else_} ty1
+
+let expite =
+ Trail.Exp.create_key (module struct type nonrec t = EITE.t * bool let name = "Ite.exp" end)
+
+module DaemonPropaITE = struct
+ let key = Demon.Fast.create "ITE.propa"
+
+ module Data = EITE
+
+ let simplify d the b =
+ let v = EITE.sem the in
+ let own = EITE.node the in
+ let branch = if b then v.then_ else v.else_ in
+ let pexp = Egraph.mk_pexp d expite (the,b) in
+ Egraph.register d branch;
+ Egraph.merge d pexp own branch
+
+ let immediate = false
+ let throttle = 100
+ let wakeup d = function
+ | Events.Fired.EventValue(cond,dom,clsem) ->
+ assert (ValueKind.equal dom Boolean.dom);
+ let v = EITE.sem clsem in
+ assert (Egraph.is_equal d cond v.cond);
+ begin match Boolean.is d v.cond with
+ | None -> assert false
+ | Some b -> simplify d clsem b
+ end
+ | _ -> raise UnwaitedEvent
+
+end
+
+module RDaemonPropaITE = Demon.Fast.Register(DaemonPropaITE)
+
+module DaemonInitITE = struct
+ let key = Demon.Fast.create "ITE.init"
+
+ module Key = DUnit
+ module Data = DUnit
+
+ let immediate = false
+ let throttle = 100
+ let wakeup d = function
+ | Events.Fired.EventRegSem(clsem,()) ->
+ begin
+ let clsem = EITE.coerce_thterm clsem in
+ let v = EITE.sem clsem in
+ let own = EITE.node clsem in
+ match Boolean.is d v.cond with
+ | Some b ->
+ DaemonPropaITE.simplify d clsem b
+ | None ->
+ let clsem = EITE.index v (Node.ty own) in
+ assert (Node.equal (EITE.node clsem) own);
+ Egraph.register d v.cond;
+ Egraph.register d v.then_;
+ Egraph.register d v.else_;
+ Egraph.register_decision d (Trail.GCho(v.cond,Boolean.chobool,v.cond));
+ let events = [Demon.Create.EventValue(v.cond,Boolean.dom,clsem)] in
+ Demon.Fast.attach d DaemonPropaITE.key events
+ end
+ | _ -> raise UnwaitedEvent
+
+end
+
+module RDaemonInitITE = Demon.Fast.Register(DaemonInitITE)
+
+module ExpITE = struct
+ open Conflict
+
+ type t = EITE.t * bool
+ let key = expite
+
+ let pp fmt (ite,b) =
+ Format.fprintf fmt "(%a,%b)" EITE.pp ite b
+
+ let analyse :
+ Conflict.t ->
+ (* Trail.age -> *) t -> Trail.Phyp.t -> Trail.Phyp.t list =
+ fun t (the,b) hyp ->
+ let v = EITE.sem the in
+ let own = EITE.node the in
+ let lhyp = Conflict.split t hyp own (if b then v.then_ else v.else_) in
+ let phyp = EqHyp.create_eq v.cond (if b then Boolean._true else Boolean._false) in
+ phyp@lhyp
+
+ let from_contradiction _ _ = raise Impossible
+
+end
+
+let () = Conflict.register_exp(module ExpITE)
+
+(** {2 Link between diff and values} *)
+(** If can't be a value it they share a diff tag, are different *)
+
+(** Give for a node the values that are different *)
+let iter_on_value_different
+ (type a)
+ (type b)
+ ((module Val): (module Witan_core.ValueKind.Registered with type s = a and type t = b))
+ ~they_are_different
+ (d:Egraph.t)
+ (own:Node.t) =
+ let dis = Opt.get_def Dis.empty (Egraph.get_dom d dom own) in
+ let iter elt age =
+ let iter n =
+ if not (Egraph.is_equal d own n) then
+ match Egraph.get_value d Val.key n with
+ | None -> ()
+ | Some v ->
+ let pexp =
+ Egraph.mk_pexp d exp (Merge(Trail.pexp_fact,own,n,elt,age)) in
+ they_are_different pexp n v
+ in
+ Node.S.iter iter (ThE.sem (Dis.to_node elt))
+ in
+ Dis.iter iter dis
+
+(** Give for a value the nodes that are different *)
+let init_diff_to_value (type a) (type b)
+ ?(already_registered=([]: b list))
+ d0
+ ((module Val): (module Witan_core.ValueKind.Registered with type s = a and type t = b))
+ ~(they_are_different:(Egraph.t -> Trail.Pexp.t -> Node.t -> a -> unit)) =
+
+ let propagate_diff d v =
+ let own = Val.node v in
+ let dis = Opt.get_def Dis.empty (Egraph.get_dom d dom own) in
+ let iter elt age =
+ let iter n =
+ if not (Egraph.is_equal d own n) then
+ let pexp =
+ Egraph.mk_pexp d exp (Merge(Trail.pexp_fact,n,Val.node v,elt,age)) in
+ they_are_different d pexp n (Val.value v)
+ in
+ Node.S.iter iter (ThE.sem (Dis.to_node elt))
+ in
+ Dis.iter iter dis
+ in
+ let key = Demon.Fast.create (Format.asprintf "DiffToValue.%a" ValueKind.pp Val.key)
+ in
+ let module D = Demon.Fast.Register(struct
+ module Data = Val
+ let key = key
+ let throttle = 100
+ let immediate = false
+
+ let wakeup d = function
+ | Events.Fired.EventDom(_,_,v) ->
+ propagate_diff d v
+ | _ -> raise Impossible
+ end)
+ in
+
+ let init d (v:Val.t) =
+ propagate_diff d v;
+ Demon.Fast.attach d key [Demon.Create.EventDom(Val.node v,dom,v)]
+ in
+ D.init d0;
+ Demon.Fast.register_init_daemon_value
+ ~name:(Format.asprintf "DiffToValue.Init.%a" ValueKind.pp Val.key)
+ (module Val)
+ init
+ d0;
+ List.iter (init d0) already_registered
+
+(** {3 For booleans} *)
+(* Since the module Bool is linked before *)
+
+let bool_init_diff_to_value d =
+ init_diff_to_value
+ d (module Boolean.BoolValue)
+ ~they_are_different:(fun d pexp n b ->
+ if not b then Boolean.set_true d pexp n
+ else Boolean.set_false d pexp n
+ )
+ ~already_registered:[Boolean.value_true;Boolean.value_false]
+
+(** {2 Interpretations} *)
+let () =
+ let interp ~interp t =
+ try
+ let fold acc e = Value.S.add_new Exit (interp e) acc in
+ let _ = Node.S.fold_left fold Value.S.empty t in
+ Boolean.values_false
+ with Exit ->
+ Boolean.values_true
+ in
+ Interp.Register.thterm sem interp
+
+let () =
+ let interp ~interp (t:ITE.t) =
+ let c = Boolean.BoolValue.value (Boolean.BoolValue.coerce_nodevalue (interp t.cond)) in
+ if c then interp t.then_ else interp t.else_
+ in
+ Interp.Register.thterm ITE.key interp
+
+let () =
+ Interp.Register.id (fun id args ->
+ let open Term in
+ let is builtin = Term.Id.equal id builtin in
+ let (!>) n = Boolean.BoolValue.value (Boolean.BoolValue.coerce_nodevalue n) in
+ let (!<) b = Some (if b then Boolean.values_true else Boolean.values_false) in
+ match args with
+ | [a;b] when is equal_id || is equiv_id -> !< (Value.equal a b)
+ | [c;a;b] when is ite_id -> Some (if (!> c) then a else b)
+ | _ when is_distinct_id id -> begin
+ try
+ let fold acc v = Value.S.add_new Exit v acc in
+ let _ = List.fold_left fold Value.S.empty args in
+ Some Boolean.values_false
+ with Exit ->
+ Some Boolean.values_true
+ end
+ | _ -> None
+ )
+
+
+let converter d f l =
+ let of_term t =
+ let n = SynTerm.node_of_term t in
+ Egraph.register d n;
+ n
+ in
+ let node = match f, l with
+ | f,(_::([_;_] as args)) when Term.equal f Term.equal_term ||
+ Term.equal f Term.equiv_term ->
+ Some (equality (List.map of_term args))
+ | f,(_::args) when Term.is_distinct_term f ->
+ Some (disequality (List.map of_term args))
+ | f,[_;c;a;b] when Term.equal f Term.ite_term ->
+ Some (ite (of_term c) (of_term a) (of_term b))
+ | _, _ -> None in
+ node
+
+let () = Conflict._equality := (fun a b -> equality [a;b])
+
+
+let th_register env =
+ RDaemonPropa.init env;
+ RDaemonInit.init env;
+ RDaemonPropaITE.init env;
+ RDaemonInitITE.init env;
+ Demon.Key.attach env
+ DaemonInit.key () [Demon.Create.EventRegSem(sem,())];
+ Demon.Fast.attach env
+ DaemonInitITE.key [Demon.Create.EventRegSem(ITE.key,())];
+ SynTerm.register_converter env converter;
+ bool_init_diff_to_value env;
+ ()
diff --git a/src/inputlang/altergo/popop_of_altergo.mli b/src/theories/bool/equality.mli
similarity index 50%
rename from src/inputlang/altergo/popop_of_altergo.mli
rename to src/theories/bool/equality.mli
index 9005ccdcf..84faf48a9 100644
--- a/src/inputlang/altergo/popop_of_altergo.mli
+++ b/src/theories/bool/equality.mli
@@ -1,37 +1,35 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
-exception Not_supported of Loc.position
+val equality : Node.t list -> Node.t
+val disequality : Node.t list -> Node.t
-val read_file: string -> Why_ptree.file
-val read_split: string -> (string * Loc.position * Why_ptree.file) list
+val is_equal : Egraph.t -> Node.t -> Node.t -> bool
+val is_disequal : Egraph.t -> Node.t -> Node.t -> bool
+val ite : Node.t -> Node.t -> Node.t -> Node.t
-type result =
-| Valid
-| Idontknow
-| Sat
+val iter_on_value_different:
+ (module ValueKind.Registered with type s = 'a and type t = 'b) ->
+ they_are_different:(Trail.Pexp.t -> Node.t -> 'a -> unit) ->
+ Egraph.t -> Node.t -> unit
-val check_goal: Why_ptree.file -> result
-(** true: goal verified
- false: goal not verified
-*)
+
+val th_register : Egraph.t -> unit
diff --git a/src/theories/bool/uninterp.ml b/src/theories/bool/uninterp.ml
new file mode 100644
index 000000000..7b666cee8
--- /dev/null
+++ b/src/theories/bool/uninterp.ml
@@ -0,0 +1,246 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_popop_lib
+open Popop_stdlib
+open Std
+open Witan_core
+
+let debug = Debug.register_info_flag
+ ~desc:"for the uninterpreted function theory"
+ "uninterp"
+
+type t = App of Node.t * Node.t
+
+let sem = ThTermKind.create_key (module struct type nonrec t = t let name = "UF" end)
+
+module Th = struct
+ module T = struct
+ type r = t
+ type t = r
+ let equal n m =
+ match n, m with
+ | App (g1,f1), App(g2,f2) -> Node.equal g1 g2 && Node.equal f1 f2
+
+ let hash n =
+ match n with
+ | App(g,f) -> 3 * (Node.hash g) + 5 * (Node.hash f)
+
+ let compare n m =
+ match n, m with
+ | App(g1,f1), App(g2,f2) ->
+ let c = Node.compare g1 g2 in
+ if c <> 0 then c
+ else Node.compare f1 f2
+
+ let pp fmt v =
+ match v with
+ | App (f,g) -> Format.fprintf fmt "(@[%a@],@,@[%a@])"
+ Node.pp f Node.pp g
+
+ end
+
+ include T
+ include MkDatatype(T)
+
+ let key = sem
+
+end
+
+let pp = Th.pp
+
+module ThE = ThTermKind.Register(Th)
+
+let app f g ty = Node.index_sem sem (App(f,g)) ty
+
+let appl f l =
+ let rec aux acc ty = function
+ | [] -> acc
+ | a::l ->
+ let _,ty = Term.extract_fun_ty ty in
+ aux (app acc a ty) ty l
+ in
+ aux f (Node.ty f) l
+
+(* let result_of_sort = Ty.H.create 20
+ *
+ * let register_sort ?dec ty =
+ * Ty.H.add result_of_sort ty dec
+ *
+ * (\** Bool can't register itself it is linked before uninterp *\)
+ * let () = register_sort Bool.ty ~dec:Bool.make_dec *)
+
+(* let result_to_dec = Node.H.create 20
+ *
+ * let app_fun node args =
+ * let (sort,arity) = Node.H.find_exn result_to_dec Impossible node in
+ * assert (List.length args = arity);
+ * let appnode = appl node args sort in
+ * appnode
+ *
+ * let fun1 ty s =
+ * let f = fresh_fun ~result:ty ~arity:1 s in
+ * (fun x -> app_fun f [x])
+ *
+ * let fun2 ty s =
+ * let f = fresh_fun ~result:ty ~arity:2 s in
+ * (fun x1 x2 -> app_fun f [x1;x2])
+ *
+ * let fun3 ty s =
+ * let f = fresh_fun ~result:ty ~arity:3 s in
+ * (fun x1 x2 x3 -> app_fun f [x1;x2;x3])
+ *
+ * let fun4 ty s =
+ * let f = fresh_fun ~result:ty ~arity:4 s in
+ * (fun x1 x2 x3 x4 -> app_fun f [x1;x2;x3;x4])
+ *
+ * let fun5 ty s =
+ * let f = fresh_fun ~result:ty ~arity:5 s in
+ * (fun x1 x2 x3 x4 x5 -> app_fun f [x1;x2;x3;x4;x5]) *)
+
+
+type expsubst = {from:ThE.t; to_:ThE.t}
+let expsubst = Trail.Exp.create_key (module struct type t = expsubst let name = "Uninterp" end)
+
+module DaemonPropa = struct
+ type k = ThE.t
+ let key = Demon.Key.create "Uninterp.DaemonPropa"
+
+ module Key = ThE
+ module Data = DUnit
+ type info = unit let default = ()
+
+ let is_unborn d v =
+ let open Demon.Key in
+ match is_attached d key v with
+ | SDead | SRedirected _ | SAlive () -> false
+ | SUnborn -> true
+
+ let attach d f g v =
+ let open Demon.Create in
+ assert (is_unborn d v);
+ Demon.Key.attach d key v
+ [EventChange(f,()); EventChange(g,())]
+
+ let immediate = true (** can be false *)
+ let wakeup d (nodesem:k) _ev () =
+ match ThE.sem nodesem with
+ | App(f,g) as v ->
+ Debug.dprintf4 debug "[Uninterp] @[wakeup own %a v:%a@]"
+ Node.pp (ThE.node nodesem) Th.pp v;
+ let v' = App(Egraph.find d f, Egraph.find d g) in
+ assert (not (Th.equal v v'));
+ let nodesem' = ThE.index v' (ThE.ty nodesem) in
+ let pexp = Egraph.mk_pexp d expsubst {from=nodesem;to_=nodesem'} in
+ Egraph.set_thterm d pexp (ThE.node nodesem) (ThE.thterm nodesem');
+ Demon.AliveRedirected nodesem'
+end
+
+module RDaemonPropa = Demon.Key.Register(DaemonPropa)
+
+module DaemonInit = struct
+ let key = Demon.Key.create "Uninterp.DaemonInit"
+
+ module Key = DUnit
+ module Data = DUnit
+ type info = unit let default = ()
+
+ let immediate = false
+
+ let wakeup d () ev () =
+ List.iter
+ (function Events.Fired.EventRegSem(nodesem,()) ->
+ begin
+ let nodesem = ThE.coerce_thterm nodesem in
+ let v = ThE.sem nodesem in
+ let own = ThE.node nodesem in
+ Debug.dprintf2 debug "[Uninterp] @[init %a@]" Th.pp v;
+ if DaemonPropa.is_unborn d nodesem then
+ match v with
+ | App(f,g) ->
+ Egraph.register d f; Egraph.register d g;
+ let f' = Egraph.find d f in
+ let g' = Egraph.find d g in
+ if Node.equal f' f && Node.equal g' g then
+ DaemonPropa.attach d f g nodesem
+ else
+ let v' = App(f',g') in
+ let nodesem' = ThE.index v' (Node.ty own) in
+ let pexp = Egraph.mk_pexp d expsubst {from=nodesem;to_=nodesem'} in
+ Egraph.set_thterm d pexp own (ThE.thterm nodesem')
+ end
+ | _ -> raise UnwaitedEvent
+ ) ev;
+ Demon.AliveReattached
+
+
+end
+
+module RDaemonInit = Demon.Key.Register(DaemonInit)
+
+module ExpSubst = struct
+ open Conflict
+
+ type t = expsubst
+ let key = expsubst
+
+ let pp fmt c =
+ match ThE.sem c.from, ThE.sem c.to_ with
+ | App(f,g), App(f',g') ->
+ Format.fprintf fmt "Subst(%a,%a -> %a,%a)"
+ Node.pp f Node.pp g Node.pp f' Node.pp g'
+
+ let analyse t {from;to_} phyp =
+ match ThE.sem from, ThE.sem to_ with
+ | App(f,g), App(f',g') ->
+ let lhyp = Conflict.split t phyp (ThE.node from) (ThE.node to_) in
+ let lhyp' = if Node.equal f f' then [] else EqHyp.create_eq f f' in
+ let lhyp'' = if Node.equal g g' then [] else EqHyp.create_eq g g' in
+ lhyp'@lhyp''@lhyp
+
+ let from_contradiction _ _ = raise Impossible
+
+end
+
+let () = Conflict.register_exp(module ExpSubst)
+
+
+let converter d f l =
+ let of_term t =
+ let n = SynTerm.node_of_term t in
+ Egraph.register d n;
+ n
+ in
+ let node = match f with
+ | {Term.term=Id id} when not (Term.is_defined id) ->
+ let f = of_term f in
+ let l = List.map of_term l in
+ Some (appl f l)
+ | _ -> None
+ in
+ node
+
+let th_register env =
+ RDaemonPropa.init env;
+ RDaemonInit.init env;
+ Demon.Key.attach env
+ DaemonInit.key () [Demon.Create.EventRegSem(sem,())];
+ SynTerm.register_converter env converter;
+ ()
diff --git a/src/theories/bool/uninterp.mli b/src/theories/bool/uninterp.mli
new file mode 100644
index 000000000..ee1bd8152
--- /dev/null
+++ b/src/theories/bool/uninterp.mli
@@ -0,0 +1,48 @@
+(*************************************************************************)
+(* This file is part of Colibrics. *)
+(* *)
+(* Copyright (C) 2017 *)
+(* CEA (Commissariat à l'énergie atomique et aux énergies *)
+(* alternatives) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It 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 Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(*************************************************************************)
+
+open Witan_core
+
+type t = App of Node.t * Node.t
+val pp: t Format.printer
+
+val sem: t ThTermKind.t
+
+(* val fun1 :
+ * Ty.t -> string ->
+ * (Node.t -> Node.t)
+ * val fun2 :
+ * Ty.t -> string ->
+ * (Node.t -> Node.t -> Node.t)
+ * val fun3 :
+ * Ty.t -> string ->
+ * (Node.t -> Node.t -> Node.t -> Node.t)
+ * val fun4 :
+ * Ty.t -> string ->
+ * (Node.t -> Node.t -> Node.t -> Node.t -> Node.t)
+ * val fun5 :
+ * Ty.t -> string ->
+ * (Node.t -> Node.t -> Node.t -> Node.t -> Node.t -> Node.t)
+ *
+ * val fresh_fun: result:Ty.t -> arity:int -> string -> Node.t *)
+
+(* val app_fun: Node.t -> Node.t list -> Node.t *)
+
+val th_register : Egraph.t -> unit
diff --git a/src/uninterp.ml b/src/uninterp.ml
deleted file mode 100644
index 5329da6a3..000000000
--- a/src/uninterp.ml
+++ /dev/null
@@ -1,263 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Stdlib
-open Types
-open Solver
-
-let debug = Debug.register_info_flag
- ~desc:"for the uninterpreted function theory"
- "uninterp"
-
-type t = App of Cl.t * Cl.t
-
-let sem : t sem = Sem.create_key "UF"
-
-module Th = struct
- module T = struct
- type r = t
- type t = r
- let equal n m =
- match n, m with
- | App (g1,f1), App(g2,f2) -> Cl.equal g1 g2 && Cl.equal f1 f2
-
- let hash n =
- match n with
- | App(g,f) -> 3 * (Cl.hash g) + 5 * (Cl.hash f)
-
- let compare n m =
- match n, m with
- | App(g1,f1), App(g2,f2) ->
- let c = Cl.compare g1 g2 in
- if c <> 0 then c
- else Cl.compare f1 f2
-
- let print fmt v =
- match v with
- | App (f,g) -> Format.fprintf fmt "(@[%a@],@,@[%a@])"
- Cl.print f Cl.print g
-
- end
-
- include MkDatatype(T)
-
- let key = sem
-
- (* let norm d s = *)
- (* Delayed.propagate d (Delayed.index d sem s) *)
-
- (* let propagate ~propagate s = *)
- (* match s with *)
- (* | App(f,g) -> propagate f; propagate g *)
-
-end
-
-let print = Th.print
-
-module ThE = RegisterSem(Th)
-
-let funty_ctr = Ty.Constr.create "Fun"
-let funty = Ty.ctr funty_ctr
-
-let partty_ctr = Ty.Constr.create "PartialFun"
-let partty = Ty.ctr partty_ctr
-
-let app f g ty = Cl.index sem (App(f,g)) ty
-
-let appl f l ty =
- let rec aux = function
- | [] -> assert false
- | [a] -> a
- | a::l -> app a (aux l) partty in
- let l = aux l in
- app f l ty
-
-let result_of_sort = Ty.H.create 20
-
-let register_sort ?dec ty =
- Ty.H.add result_of_sort ty dec
-
-(** Bool can't register itself it is linked before uninterp *)
-let () = register_sort Bool.ty ~dec:Bool.make_dec
-
-let result_to_dec = Cl.H.create 20
-
-let fresh_fun ~result ~arity name =
- assert (arity > 0);
- let cl = Cl.fresh name funty in
- Cl.H.add result_to_dec cl (result,arity);
- cl
-
-let app_fun cl args =
- let (sort,arity) = Cl.H.find_exn result_to_dec Impossible cl in
- assert (List.length args = arity);
- let appcl = appl cl args sort in
- appcl
-
-let fun1 ty s =
- let f = fresh_fun ~result:ty ~arity:1 s in
- (fun x -> app_fun f [x])
-
-let fun2 ty s =
- let f = fresh_fun ~result:ty ~arity:2 s in
- (fun x1 x2 -> app_fun f [x1;x2])
-
-let fun3 ty s =
- let f = fresh_fun ~result:ty ~arity:3 s in
- (fun x1 x2 x3 -> app_fun f [x1;x2;x3])
-
-let fun4 ty s =
- let f = fresh_fun ~result:ty ~arity:4 s in
- (fun x1 x2 x3 x4 -> app_fun f [x1;x2;x3;x4])
-
-let fun5 ty s =
- let f = fresh_fun ~result:ty ~arity:5 s in
- (fun x1 x2 x3 x4 x5 -> app_fun f [x1;x2;x3;x4;x5])
-
-
-type expsubst = ThE.t
-let expsubst : expsubst Explanation.exp =
- Explanation.Exp.create_key "Uninterp"
-
-module DaemonPropa = struct
- type k = ThE.t
- let key = Demon.Key.create "Uninterp.DaemonPropa"
-
- module Key = ThE
- module Data = DUnit
- type info = unit let default = ()
-
- let is_unborn d v =
- let open Demon.Key in
- match is_attached d key v with
- | SDead | SRedirected _ | SAlive () -> false
- | SUnborn -> true
-
- let attach d f g v =
- let open Demon.Create in
- assert (is_unborn d v);
- Demon.Key.attach d key v
- [EventChange(f,()); EventChange(g,())]
-
- let immediate = true (** can be false *)
- let wakeup d (clsem:k) _ev () =
- match ThE.sem clsem with
- | App(f,g) as v ->
- Debug.dprintf4 debug "[Uninterp] @[wakeup own %a v:%a@]@\n"
- Cl.print (ThE.cl clsem) Th.print v;
- let v' = App(Delayed.find d f, Delayed.find d g) in
- assert (not (Th.equal v v'));
- let pexp = Delayed.mk_pexp d expsubst clsem in
- let clsem' = ThE.index v' (ThE.ty clsem) in
- Delayed.set_sem d pexp (ThE.cl clsem) (ThE.clsem clsem');
- Demon.AliveRedirected clsem'
-end
-
-module RDaemonPropa = Demon.Key.Register(DaemonPropa)
-
-module DaemonInit = struct
- let key = Demon.Key.create "Uninterp.DaemonInit"
-
- module Key = DUnit
- module Data = DUnit
- type info = unit let default = ()
-
- let immediate = false
-
- let wakeup d () ev () =
- List.iter
- (function Events.Fired.EventRegSem(clsem,()) ->
- begin
- let clsem = ThE.coerce_clsem clsem in
- let v = ThE.sem clsem in
- let own = ThE.cl clsem in
- Debug.dprintf2 debug "[Uninterp] @[init %a@]@\n" Th.print v;
- let dec = Ty.H.find_def result_of_sort None (Cl.ty own) in
- Opt.iter (fun dec -> Variable.add_dec ~dec d own) dec;
- if DaemonPropa.is_unborn d clsem then
- match v with
- | App(f,g) ->
- Delayed.register d f; Delayed.register d g;
- let f' = Delayed.find d f in
- let g' = Delayed.find d g in
- if Cl.equal f' f && Cl.equal g' g then
- DaemonPropa.attach d f g clsem
- else
- let v' = App(f',g') in
- let pexp = Delayed.mk_pexp d expsubst clsem in
- let clsem = ThE.clsem (ThE.index v' (Cl.ty own)) in
- Delayed.set_sem d pexp own clsem
- end
- | _ -> raise UnwaitedEvent
- ) ev;
- Demon.AliveReattached
-
-
-end
-
-module RDaemonInit = Demon.Key.Register(DaemonInit)
-
-let th_register env =
- RDaemonPropa.init env;
- RDaemonInit.init env;
- Demon.Key.attach env
- DaemonInit.key () [Demon.Create.EventRegSem(sem,())];
-
-module ExpSubst = struct
- open Conflict
- (* open IterExp *)
- open ComputeConflict
-
- type t = expsubst
-
- let print fmt clsem =
- match ThE.sem clsem with
- | App(f,g) ->
- Format.fprintf fmt "Subst(%a,%a)" Cl.print f Cl.print g
-
-(*
- let iterexp t age = function
- | App(f,g) ->
- need_sem t age sem (App(f,g));
- need_cl_repr t age f;
- need_cl_repr t age g
-*)
- let analyse :
- type a. Conflict.ComputeConflict.t ->
- Explanation.age -> a Explanation.con -> t -> a Conflict.rescon =
- fun t age con clsem ->
- begin match ThE.sem clsem with
- | App(f,g) ->
- let fty = Cl.ty f in
- let gty = Cl.ty g in
- Equality.GenEquality.equality t age f (get_repr_at t age f) fty;
- Equality.GenEquality.equality t age g (get_repr_at t age g) gty
- end;
- return_nothing con
-
- let expdom _ _ _ _ _ _ = raise Impossible (** don't propa dom *)
-
- let key = expsubst
-
-end
-
-module EExpSubst = Conflict.RegisterExp(ExpSubst)
diff --git a/src/uninterp.mli b/src/uninterp.mli
deleted file mode 100644
index e719f7739..000000000
--- a/src/uninterp.mli
+++ /dev/null
@@ -1,54 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Types
-
-type t = App of Cl.t * Cl.t
-val print: t Pp.printer
-
-val sem: t sem
-
-val fun1 :
- Ty.t -> string ->
- (Cl.t -> Cl.t)
-val fun2 :
- Ty.t -> string ->
- (Cl.t -> Cl.t -> Cl.t)
-val fun3 :
- Ty.t -> string ->
- (Cl.t -> Cl.t -> Cl.t -> Cl.t)
-val fun4 :
- Ty.t -> string ->
- (Cl.t -> Cl.t -> Cl.t -> Cl.t -> Cl.t)
-val fun5 :
- Ty.t -> string ->
- (Cl.t -> Cl.t -> Cl.t -> Cl.t -> Cl.t -> Cl.t)
-
-val register_sort: ?dec:Variable.make_dec -> Ty.t -> unit
-
-val fresh_fun: result:Ty.t -> arity:int -> string -> Cl.t
-
-val app_fun: Cl.t -> Cl.t list -> Cl.t
-
-
-val th_register : Solver.Delayed.t -> unit
diff --git a/src/util/config.ml b/src/util/config.ml
deleted file mode 100644
index 9890b03c7..000000000
--- a/src/util/config.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-
-let version = "0.80+git"
-let builddate = "Mon Jan 7 17:00:21 CET 2013"
-
-let libdir = "/home/bobot/Sources/why3/lib"
-let datadir = "/home/bobot/Sources/why3/share"
-let localdir = Some "/home/bobot/Sources/why3"
-
diff --git a/src/util/extmap.ml b/src/util/extmap.ml
deleted file mode 100644
index 08db29f6b..000000000
--- a/src/util/extmap.ml
+++ /dev/null
@@ -1,640 +0,0 @@
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* This file originates from the OCaml v 3.12 Standard Library.
- It was extended and modified for the needs of the Why3 project.
- It is distributed under the terms of its initial license, which
- is provided in the file OCAML-LICENSE. *)
-
-module type S = Map_intf.Map with type 'a data = 'a
-
- module Make(Ord: Map_intf.OrderedType) = struct
- type key = Ord.t
- type 'a data = 'a
- type 'a t =
- Empty
- | Node of 'a t * key * 'a * 'a t * int
-
- let height = function
- Empty -> 0
- | Node(_,_,_,_,h) -> h
-
- let create l x d r =
- let hl = height l and hr = height r in
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let singleton x d = Node(Empty, x, d, Empty, 1)
-
- let bal l x d r =
- let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
- let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
- if hl > hr + 2 then begin
- match l with
- Empty -> invalid_arg "Map.bal"
- | Node(ll, lv, ld, lr, _) ->
- if height ll >= height lr then
- create ll lv ld (create lr x d r)
- else begin
- match lr with
- Empty -> invalid_arg "Map.bal"
- | Node(lrl, lrv, lrd, lrr, _)->
- create (create ll lv ld lrl) lrv lrd (create lrr x d r)
- end
- end else if hr > hl + 2 then begin
- match r with
- Empty -> invalid_arg "Map.bal"
- | Node(rl, rv, rd, rr, _) ->
- if height rr >= height rl then
- create (create l x d rl) rv rd rr
- else begin
- match rl with
- Empty -> invalid_arg "Map.bal"
- | Node(rll, rlv, rld, rlr, _) ->
- create (create l x d rll) rlv rld (create rlr rv rd rr)
- end
- end else
- Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
-
- let empty = Empty
-
- let is_empty = function Empty -> true | _ -> false
-
- let rec add x data = function
- Empty ->
- Node(Empty, x, data, Empty, 1)
- | Node(l, v, d, r, h) ->
- let c = Ord.compare x v in
- if c = 0 then
- Node(l, x, data, r, h)
- else if c < 0 then
- bal (add x data l) v d r
- else
- bal l v d (add x data r)
-
- let rec find x = function
- Empty ->
- raise Not_found
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then d
- else find x (if c < 0 then l else r)
-
- let rec mem x = function
- Empty ->
- false
- | Node(l, v, _d, r, _) ->
- let c = Ord.compare x v in
- c = 0 || mem x (if c < 0 then l else r)
-
- let rec min_binding = function
- Empty -> raise Not_found
- | Node(Empty, x, d, _r, _) -> (x, d)
- | Node(l, _x, _d, _r, _) -> min_binding l
-
- let rec max_binding = function
- Empty -> raise Not_found
- | Node(_l, x, d, Empty, _) -> (x, d)
- | Node(_l, _x, _d, r, _) -> max_binding r
-
- let rec remove_min_binding = function
- Empty -> invalid_arg "Map.remove_min_elt"
- | Node(Empty, _x, _d, r, _) -> r
- | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
-
- let merge t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- bal t1 x d (remove_min_binding t2)
-
- let merge_bal = merge
-
- let rec remove x = function
- Empty ->
- Empty
- | Node(l, v, d, r, _h) ->
- let c = Ord.compare x v in
- if c = 0 then
- merge l r
- else if c < 0 then
- bal (remove x l) v d r
- else
- bal l v d (remove x r)
-
- let rec iter f = function
- Empty -> ()
- | Node(l, v, d, r, _) ->
- iter f l; f v d; iter f r
-
- let rec map f = function
- Empty ->
- Empty
- | Node(l, v, d, r, h) ->
- let l' = map f l in
- let d' = f d in
- let r' = map f r in
- Node(l', v, d', r', h)
-
- let rec mapi f = function
- Empty ->
- Empty
- | Node(l, v, d, r, h) ->
- let l' = mapi f l in
- let d' = f v d in
- let r' = mapi f r in
- Node(l', v, d', r', h)
-
- let rec fold f m accu =
- match m with
- Empty -> accu
- | Node(l, v, d, r, _) ->
- fold f r (f v d (fold f l accu))
-
- let rec for_all p = function
- Empty -> true
- | Node(l, v, d, r, _) -> p v d && for_all p l && for_all p r
-
- let rec exists p = function
- Empty -> false
- | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
-
- let filter p s =
- let rec filt accu = function
- | Empty -> accu
- | Node(l, v, d, r, _) ->
- filt (filt (if p v d then add v d accu else accu) l) r in
- filt Empty s
-
- let partition p s =
- let rec part (t, f as accu) = function
- | Empty -> accu
- | Node(l, v, d, r, _) ->
- part (part (if p v d then (add v d t, f)
- else (t, add v d f)) l) r in
- part (Empty, Empty) s
-
- (* Same as create and bal, but no assumptions are made on the
- relative heights of l and r. *)
-
- let rec join l v d r =
- match (l, r) with
- (Empty, _) -> add v d r
- | (_, Empty) -> add v d l
- | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
- if lh > rh + 2 then bal ll lv ld (join lr v d r) else
- if rh > lh + 2 then bal (join l v d rl) rv rd rr else
- create l v d r
-
- (* Merge two trees l and r into one.
- All elements of l must precede the elements of r.
- No assumption on the heights of l and r. *)
-
- let concat t1 t2 =
- match (t1, t2) with
- (Empty, t) -> t
- | (t, Empty) -> t
- | (_, _) ->
- let (x, d) = min_binding t2 in
- join t1 x d (remove_min_binding t2)
-
- let concat_or_join t1 v d t2 =
- match d with
- | Some d -> join t1 v d t2
- | None -> concat t1 t2
-
- let rec split x = function
- Empty ->
- (Empty, None, Empty)
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then (l, Some d, r)
- else if c < 0 then
- let (ll, pres, rl) = split x l in (ll, pres, join rl v d r)
- else
- let (lr, pres, rr) = split x r in (join l v d lr, pres, rr)
-
- let rec merge f s1 s2 =
- match (s1, s2) with
- (Empty, Empty) -> Empty
- | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
- let (l2, d2, r2) = split v1 s2 in
- concat_or_join (merge f l1 l2) v1 (f v1 (Some d1) d2) (merge f r1 r2)
- | (_, Node (l2, v2, d2, r2, _h2)) ->
- let (l1, d1, r1) = split v2 s1 in
- concat_or_join (merge f l1 l2) v2 (f v2 d1 (Some d2)) (merge f r1 r2)
- | _ ->
- assert false
-
- type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
-
- let rec cons_enum m e =
- match m with
- Empty -> e
- | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e))
-
- let compare cmp m1 m2 =
- let rec compare_aux e1 e2 =
- match (e1, e2) with
- (End, End) -> 0
- | (End, _) -> -1
- | (_, End) -> 1
- | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- let c = Ord.compare v1 v2 in
- if c <> 0 then c else
- let c = cmp d1 d2 in
- if c <> 0 then c else
- compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
- in compare_aux (cons_enum m1 End) (cons_enum m2 End)
-
- let equal cmp m1 m2 =
- let rec equal_aux e1 e2 =
- match (e1, e2) with
- (End, End) -> true
- | (End, _) -> false
- | (_, End) -> false
- | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- Ord.compare v1 v2 = 0 && cmp d1 d2 &&
- equal_aux (cons_enum r1 e1) (cons_enum r2 e2)
- in equal_aux (cons_enum m1 End) (cons_enum m2 End)
-
- let rec cardinal = function
- Empty -> 0
- | Node(l, _, _, r, _) -> cardinal l + 1 + cardinal r
-
- let rec keys_aux accu = function
- Empty -> accu
- | Node(l, v, _, r, _) -> keys_aux (v :: keys_aux accu r) l
-
- let keys s =
- keys_aux [] s
-
- let rec bindings_aux accu = function
- Empty -> accu
- | Node(l, v, d, r, _) -> bindings_aux ((v, d) :: bindings_aux accu r) l
-
- let bindings s =
- bindings_aux [] s
-
- let rec values_aux accu = function
- Empty -> accu
- | Node(l, _, v, r, _) -> values_aux (v :: values_aux accu r) l
-
- let values s =
- values_aux [] s
-
- let choose = min_binding
-
- (** Added into why stdlib version *)
-
- let rec change f x = function
- | Empty ->
- begin match f None with
- | None -> Empty
- | Some d -> Node(Empty, x, d, Empty, 1)
- end
- | Node(l, v, d, r, h) ->
- let c = Ord.compare x v in
- if c = 0 then
- (* concat or bal *)
- match f (Some d) with
- | None -> merge_bal l r
- | Some d -> Node(l, x, d, r, h)
- else if c < 0 then
- bal (change f x l) v d r
- else
- bal l v d (change f x r)
-
- let rec add_change empty add x b = function
- | Empty -> Node(Empty, x, empty b, Empty, 1)
- | Node(l, v, d, r, h) ->
- let c = Ord.compare x v in
- if c = 0 then
- Node(l, x, add b d, r, h)
- else if c < 0 then
- bal (add_change empty add x b l) v d r
- else
- bal l v d (add_change empty add x b r)
-
- let rec union f s1 s2 =
- match (s1, s2) with
- (Empty, t2) -> t2
- | (t1, Empty) -> t1
- | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
- if h1 >= h2 then
- if h2 = 1 then
- change (function None -> Some d2 | Some d1 -> f v2 d1 d2) v2 s1
- else begin
- let (l2, d2, r2) = split v1 s2 in
- match d2 with
- | None -> join (union f l1 l2) v1 d1 (union f r1 r2)
- | Some d2 ->
- concat_or_join (union f l1 l2) v1 (f v1 d1 d2)
- (union f r1 r2)
- end
- else
- if h1 = 1 then
- change (function None -> Some d1 | Some d2 -> f v1 d1 d2) v1 s2
- else begin
- let (l1, d1, r1) = split v2 s1 in
- match d1 with
- | None -> join (union f l1 l2) v2 d2 (union f r1 r2)
- | Some d1 ->
- concat_or_join (union f l1 l2) v2 (f v2 d1 d2)
- (union f r1 r2)
- end
-
- let rec union_merge f s1 s2 =
- match (s1, s2) with
- (Empty, Empty) -> Empty
- | (t1,Empty) -> t1
- | (Node (l1, v1, d1, r1, h1), _) when h1 >= height s2 ->
- let (l2, d2, r2) = split v1 s2 in
- begin match d2 with
- | None -> join (union_merge f l1 l2) v1 d1 (union_merge f r1 r2)
- | Some d2 ->
- concat_or_join (union_merge f l1 l2) v1 (f v1 (Some d1) d2)
- (union_merge f r1 r2)
- end
- | (_, Node (l2, v2, d2, r2, _h2)) ->
- let (l1, d1, r1) = split v2 s1 in
- concat_or_join (union_merge f l1 l2) v2 (f v2 d1 d2)
- (union_merge f r1 r2)
-
- let rec inter f s1 s2 =
- match (s1, s2) with
- | (Empty, _) | (_, Empty) -> Empty
- | (Node(l1, v1, d1, r1, _), t2) ->
- match split v1 t2 with
- (l2, None, r2) ->
- concat (inter f l1 l2) (inter f r1 r2)
- | (l2, Some d2, r2) ->
- concat_or_join (inter f l1 l2) v1 (f v1 d1 d2) (inter f r1 r2)
-
-
- let rec diff f s1 s2 =
- match (s1, s2) with
- (Empty, _t2) -> Empty
- | (t1, Empty) -> t1
- | (Node(l1, v1, d1, r1, _), t2) ->
- match split v1 t2 with
- | (l2, None, r2) -> join (diff f l1 l2) v1 d1 (diff f r1 r2)
- | (l2, Some d2, r2) ->
- concat_or_join (diff f l1 l2) v1 (f v1 d1 d2) (diff f r1 r2)
-
-
- let rec submap pr s1 s2 =
- match (s1, s2) with
- | Empty, _ -> true
- | _, Empty -> false
- | Node (l1, v1, d1, r1, _), (Node (l2, v2, d2, r2, _) as t2) ->
- let c = Ord.compare v1 v2 in
- if c = 0 then
- pr v1 d1 d2 && submap pr l1 l2 && submap pr r1 r2
- else if c < 0 then
- submap pr (Node (l1, v1, d1, Empty, 0)) l2 && submap pr r1 t2
- else
- submap pr (Node (Empty, v1, d1, r1, 0)) r2 && submap pr l1 t2
-
-
- let rec disjoint pr s1 s2 =
- match (s1, s2) with
- | Empty, _ -> true
- | _, Empty -> true
- | Node (l1, v1, d1, r1, _), (Node (l2, v2, d2, r2, _) as t2) ->
- let c = Ord.compare v1 v2 in
- if c = 0 then
- pr v1 d1 d2 && disjoint pr l1 l2 && disjoint pr r1 r2
- else if c < 0 then
- disjoint pr (Node (l1, v1, d1, Empty, 0)) l2 && disjoint pr r1 t2
- else
- disjoint pr (Node (Empty, v1, d1, r1, 0)) r2 && disjoint pr l1 t2
-
- let set_union m1 m2 = union (fun _ x _ -> Some x) m1 m2
- let set_inter m1 m2 = inter (fun _ x _ -> Some x) m1 m2
- let set_diff m1 m2 = diff (fun _ _ _ -> None) m1 m2
- let set_submap m1 m2 = submap (fun _ _ _ -> true) m1 m2
- let set_disjoint m1 m2 = disjoint (fun _ _ _ -> false) m1 m2
- let set_compare m1 m2 = compare (fun _ _ -> 0) m1 m2
- let set_equal m1 m2 = equal (fun _ _ -> true) m1 m2
-
- let rec find_def def x = function
- Empty -> def
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then d
- else find_def def x (if c < 0 then l else r)
-
- let rec find_opt x = function
- Empty -> None
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then Some d
- else find_opt x (if c < 0 then l else r)
-
- let rec find_exn exn x = function
- Empty -> raise exn
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then d
- else find_exn exn x (if c < 0 then l else r)
-
- let rec find_remove x = function
- Empty ->
- Empty, None
- | Node(l, v, d, r, _h) ->
- let c = Ord.compare x v in
- if c = 0 then
- merge_bal l r, Some d
- else if c < 0 then
- let l,f = find_remove x l in
- bal l v d r,f
- else
- let r,f = find_remove x r in
- bal l v d r,f
-
- let rec find_smaller_opt cand x = function
- | Empty -> cand
- | Node(l, v, d, r, _) ->
- let c = Ord.compare x v in
- if c = 0 then Some(x,d)
- else if c < 0 then
- find_smaller_opt cand x l
- else
- find_smaller_opt (Some(x,d)) x r
-
- let find_smaller_opt x t = find_smaller_opt None x t
-
- let rec map_filter f = function
- Empty -> Empty
- | Node(l, v, d, r, _h) ->
- concat_or_join (map_filter f l) v (f d) (map_filter f r)
-
- let rec mapi_filter f = function
- Empty -> Empty
- | Node(l, v, d, r, _h) ->
- concat_or_join (mapi_filter f l) v (f v d) (mapi_filter f r)
-
- let rec mapi_fold f m acc =
- match m with
- Empty -> acc, Empty
- | Node(l, v, d, r, h) ->
- let acc,l' = mapi_fold f l acc in
- let acc,d' = f v d acc in
- let acc,r' = mapi_fold f r acc in
- acc,Node(l', v, d', r', h)
-
- let fold2_inter f m1 m2 acc =
- let rec aux acc e1_0 e2_0 =
- match (e1_0, e2_0) with
- (End, End) -> acc
- | (End, _) -> acc
- | (_, End) -> acc
- | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- let c = Ord.compare v1 v2 in
- if c = 0 then
- aux (f v1 d1 d2 acc) (cons_enum r1 e1) (cons_enum r2 e2)
- else if c < 0 then
- aux acc (cons_enum r1 e1) e2_0
- else
- aux acc e1_0 (cons_enum r2 e2)
- in aux acc (cons_enum m1 End) (cons_enum m2 End)
-
- let fold2_union f m1 m2 acc =
- let rec aux acc e1_0 e2_0 =
- match (e1_0, e2_0) with
- (End, End) -> acc
- | (End, More(v2, d2, r2, e2)) ->
- aux (f v2 None (Some d2) acc) End (cons_enum r2 e2)
- | (More(v1, d1, r1, e1), End) ->
- aux (f v1 (Some d1) None acc) (cons_enum r1 e1) End
- | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) ->
- let c = Ord.compare v1 v2 in
- if c = 0 then
- aux (f v1 (Some d1) (Some d2) acc)
- (cons_enum r1 e1) (cons_enum r2 e2)
- else if c < 0 then
- aux (f v1 (Some d1) None acc) (cons_enum r1 e1) e2_0
- else
- aux (f v2 None (Some d2) acc) e1_0 (cons_enum r2 e2)
- in aux acc (cons_enum m1 End) (cons_enum m2 End)
-
- let translate f m =
- let rec aux last = function
- | Empty -> Empty,last
- | Node(l, v, d, r, h) ->
- let l,last = aux last l in
- let v = f v in
- begin match last with
- | None -> ()
- | Some last ->
- if Ord.compare last v >= 0
- then invalid_arg "Map.translate : given function incorrect"
- end;
- let r,last = aux (Some v) r in
- Node(l,v,d,r,h),last in
- let m,_ = aux None m in m
-
- let rec mapi_filter_fold f m acc =
- match m with
- Empty -> acc, Empty
- | Node(l, v, d, r, _h) ->
- let acc,l' = mapi_filter_fold f l acc in
- let acc,d' = f v d acc in
- let acc,r' = mapi_filter_fold f r acc in
- acc, concat_or_join l' v d' r'
-
- let add_new e x v m = change (function
- | Some _ -> raise e
- | None -> Some v) x m
-
- let is_num_elt n m =
- try
- fold (fun _ _ n -> if n < 0 then raise Exit else n-1) m n = 0
- with Exit -> false
-
- (** the goal is to choose randomly but often the same than [choose] *)
- let choose_rnd f m =
- let rec aux f m ret =
- match m with
- | Empty -> ()
- | Node(l, v, d, r, _) ->
- aux f l ret;
- if f () then (ret := (v,d); raise Exit) else aux f r ret
- in
- let ret = ref (Obj.magic 0) in
- try
- aux f m ret;
- choose m
- with Exit -> !ret
-
- let start_enum s = cons_enum s End
-
- let val_enum = function
- | End -> None
- | More (v,d,_,_) -> Some (v,d)
-
- let next_enum = function
- | End -> End
- | More(_,_,r,e) -> cons_enum r e
-
- let rec cons_ge_enum k m e =
- match m with
- Empty -> e
- | Node(l, v, d, r, _) ->
- let c = Ord.compare k v in
- if c = 0 then More(v,d,r,e)
- else if c < 0 then cons_ge_enum k l (More(v, d, r, e))
- else (* c > 0 *) cons_ge_enum k r e
-
- let start_ge_enum k m = cons_ge_enum k m End
-
- let rec next_ge_enum k l0 = function
- | End -> start_ge_enum k l0
- | More(v,_,r,e) as e0 ->
- let c = Ord.compare k v in
- if c = 0 then e0
- else if c < 0 then cons_ge_enum k l0 e0
- else (* c > 0 *) next_ge_enum k r e
-
- let next_ge_enum k e = next_ge_enum k Empty e
-
- let rec fold_left f accu m =
- match m with
- Empty -> accu
- | Node(l, v, d, r, _) ->
- fold_left f (f (fold_left f accu l) v d) r
-
- let of_list l =
- List.fold_left (fun acc (k,d) -> add k d acc) empty l
-
- let add_opt x o m =
- match o with
- | None -> remove x m
- | Some y -> add x y m
-
- let check_invariant m =
- let rec aux = function
- | Empty -> 0, true
- | Node(l,_,_,r,h) ->
- let h1,b1 = aux l in
- let h2,b2 = aux r in
- if b1 && b2
- then
- let h' = (if h1 >= h2 then h1 + 1 else h2 + 1) in
- h', h' = h
- else -1,false in
- snd (aux m)
-
- end
diff --git a/src/util/intmap.ml b/src/util/intmap.ml
deleted file mode 100644
index 1a6a30a24..000000000
--- a/src/util/intmap.ml
+++ /dev/null
@@ -1,1711 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of WP plug-in of Frama-C. *)
-(* *)
-(* Copyright (C) 2007-2013 *)
-(* CEA (Commissariat a l'energie atomique et aux energies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-(* -------------------------------------------------------------------------- *)
-(* --- Bit library --- *)
-(* -------------------------------------------------------------------------- *)
-
-let hsb =
- let hsb p = if p land 2 != 0 then 1 else 0
- in let hsb p = let n = p lsr 2 in if n != 0 then 2 + hsb n else hsb p
- in let hsb p = let n = p lsr 4 in if n != 0 then 4 + hsb n else hsb p
- in let hsb = Array.init 256 hsb
- in let hsb p = let n = p lsr 8 in if n != 0 then 8 + hsb.(n) else hsb.(p)
- in let hsb p = let n = p lsr 16 in if n != 0 then 16 + hsb n else hsb p
- in match Sys.word_size with
- | 32 -> hsb
- | 64 -> (function p -> let n = p lsr 32 in
- if n != 0 then 32 + hsb n else hsb p)
- | _ -> assert false (** absurd: No other possible achitecture supported *)
-
-let highest_bit x = 1 lsl (hsb x)
-let lowest_bit x = x land (-x)
-
-(* -------------------------------------------------------------------------- *)
-(* --- Bit utilities --- *)
-(* -------------------------------------------------------------------------- *)
-let decode_mask p = lowest_bit (lnot p)
-
-let branching_bit p0 p1 = highest_bit (p0 lxor p1)
-let mask p m = (p lor (m-1)) land (lnot m)
-
-let zero_bit_int k m = (k land m) == 0
-let zero_bit k p = zero_bit_int k (decode_mask p)
-
-let match_prefix_int k p m = (mask k m) == p
-let match_prefix k p = match_prefix_int k p (decode_mask p)
-
-let included_mask_int m n =
- (* m mask is strictly included into n *)
- (* can not use (m < n) when n is (1 lsl 62) = min_int < 0 *)
- (* must use (0 < (n-m) instead *)
- 0 > n - m
-(* let included_mask p q = included_mask_int (decode_mask p) (decode_mask q) *)
-
-let included_prefix p q =
- let m = decode_mask p in
- let n = decode_mask q in
- included_mask_int m n && match_prefix_int q p m
-
-
-(* -------------------------------------------------------------------------- *)
-(* --- Debug --- *)
-(* -------------------------------------------------------------------------- *)
-
-let pp_mask m fmt p =
- begin
- let bits = Array.make 63 false in
- let last = ref 0 in
- for i = 0 to 62 do
- let u = 1 lsl i in
- if u land p <> 0 then
- bits.(i) <- true ;
- if u == m then last := i ;
- done ;
- Format.pp_print_char fmt '*' ;
- for i = !last - 1 downto 0 do
- Format.pp_print_char fmt (if bits.(i) then '1' else '0') ;
- done ;
- end
-
-let pp_bits fmt k =
- begin
- let bits = Array.make 63 false in
- let last = ref 0 in
- for i = 0 to 62 do
- if (1 lsl i) land k <> 0 then
- ( bits.(i) <- true ;
- if i > !last then last := i ) ;
- done ;
- for i = !last downto 0 do
- Format.pp_print_char fmt (if bits.(i) then '1' else '0') ;
- done ;
- end
-
-(* ---------------------------------------------------------------------- *)
-(* --- Patricia Trees By L. Correnson & P. Baudin & F. Bobot --- *)
-(* ---------------------------------------------------------------------- *)
-
-module Make(K:Map_intf.TaggedEqualType) :
- Map_intf.Gen_Map_hashcons with type NT.key = K.t = struct
-
-module Gen(G:sig
- type (+'a) t
- type 'a data
- type 'a view = private
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a t * 'a t
- val view: 'a data t -> 'a data view
- val mk_Empty: 'a data t
- val mk_Lf: K.t -> 'a data -> 'a data t
- val mk_Br: int -> 'a data t -> 'a data t -> 'a data t
- val ktag : 'a data t -> int
- end)
- = struct
- open G
-
- type key = K.t
- type 'a data = 'a G.data
- type 'a t = 'a G.t
-
-(* -------------------------------------------------------------------------- *)
-(* --- Smart Constructors --- *)
-(* -------------------------------------------------------------------------- *)
-
- let empty = mk_Empty
- let singleton = mk_Lf
-
-let br p t0 t1 = match view t0 , view t1 with
- | Empty,_ -> t1
- | _,Empty -> t0
- | _ -> mk_Br p t0 t1
-
-let lf k = function None -> mk_Empty | Some x -> mk_Lf k x
-
-(* good sharing *)
-let lf0 k x' t' = function
- | None -> mk_Empty
- | Some x -> if x == x' then t' else mk_Lf k x
-
-(* good sharing *)
-let br0 p t0' t1' t' t0 = match view t0 with
- | Empty -> t1'
- | _ -> if t0' == t0 then t' else mk_Br p t0 t1'
-
-(* good sharing *)
-let br1 p t0' t1' t' t1 = match view t1 with
- | Empty -> t0'
- | _ -> if t1' == t1 then t' else mk_Br p t0' t1
-
-let join p t0 q t1 =
- let m = branching_bit p q in
- let r = mask p m in
- if zero_bit p r
- then mk_Br r t0 t1
- else mk_Br r t1 t0
-
-let side p q = (* true this side, false inverse *)
- let m = branching_bit p q in
- let r = mask p m in
- zero_bit p r
-
-(* t0 and t1 has different prefix, but best common prefix is unknown *)
-let glue t0 t1 =
- match view t0 , view t1 with
- | Empty,_ -> t1
- | _,Empty -> t0
- | _,_ -> join (ktag t0) t0 (ktag t1) t1
-
-
-let glue' ~old ~cur ~other ~all =
- if old == cur then all else glue cur other
-
-let glue0 t0 t0' t1' t' =
- if t0 == t0' then t' else glue t0 t1'
-
-let glue1 t1 t0' t1' t' =
- if t1 == t1' then t' else glue t0' t1
-
-let glue01 t0 t1 t0' t1' t' =
- if t0 == t0' && t1 == t1' then t' else glue t0 t1
-
-let glue2 t0 t1 t0' t1' t' s0' s1' s' =
- if t0 == s0' && t1 == s1' then s' else
- if t0 == t0' && t1 == t1' then t' else glue t0 t1
-
-(* -------------------------------------------------------------------------- *)
-(* --- Access API --- *)
-(* -------------------------------------------------------------------------- *)
-
-let is_empty x = match view x with
- | Empty -> true
- | Lf _ | Br _ -> false
-
-let size t =
- let rec walk n t = match view t with
- | Empty -> n
- | Lf _ -> succ n
- | Br(_,a,b) -> walk (walk n a) b
- in walk 0 t
-
-let cardinal = size
-
-let rec mem k t = match view t with
- | Empty -> false
- | Lf(i,_) -> K.equal i k
- | Br(p,t0,t1) ->
- match_prefix (K.tag k) p &&
- mem k (if zero_bit (K.tag k) p then t0 else t1)
-
-let rec findq k t = match view t with
- | Empty -> raise Not_found
- | Lf(i,x) -> if K.equal k i then (x,t) else raise Not_found
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- findq k (if zero_bit (K.tag k) p then t0 else t1)
- else
- raise Not_found
-
-let rec find_exn exn k t = match view t with
- | Empty -> raise exn
- | Lf(i,x) -> if K.equal k i then x else raise exn
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- find_exn exn k (if zero_bit (K.tag k) p then t0 else t1)
- else
- raise exn
-
-let find k m = find_exn Not_found k m
-
-let rec find_opt k t = match view t with
- | Empty -> None
- | Lf(i,x) -> if K.equal k i then Some x else None
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- find_opt k (if zero_bit (K.tag k) p then t0 else t1)
- else
- None
-
-let rec find_def def k t = match view t with
- | Empty -> def
- | Lf(i,x) -> if K.equal k i then x else def
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- find_def def k (if zero_bit (K.tag k) p then t0 else t1)
- else
- def
-
-(* good sharing *)
-let rec find_remove k t = match view t with
- | Empty -> mk_Empty, None
- | Lf(i,y) ->
- if K.equal i k then
- mk_Empty, Some y
- else
- t, None
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- (* k belongs to tree *)
- if zero_bit (K.tag k) p
- then let t0', r = find_remove k t0 in
- br0 p t0 t1 t t0', r (* k is in t0 *)
- else let t1', r = find_remove k t1 in
- br1 p t0 t1 t t1', r (* k is in t1 *)
- else
- (* k is disjoint from tree *)
- t, None
-
-(** shouldn't be used at top *)
-let rec max_binding_opt t = match view t with
- | Empty -> None
- | Lf(k,x) -> Some(k,x)
- | Br(_,_,t1) -> max_binding_opt t1
-
-let rec find_smaller_opt' cand k t = match view t with
- | Empty -> assert false
- | Lf(i,y) ->
- let c = Pervasives.compare (K.tag i) (K.tag k) in
- if c <= 0 then Some(i,y)
- else (* c > 0 *) max_binding_opt cand
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- (* k belongs to tree *)
- if zero_bit (K.tag k) p
- then find_smaller_opt' cand k t0
- else find_smaller_opt' t0 k t1
- else
- (* k is disjoint from tree *)
- if side (K.tag k) p
- then (* k p *) max_binding_opt cand
- else (* p k *) max_binding_opt t1
-
-let find_smaller_opt k t = match view t with
- | Empty -> None
- | Br(p,t0,t1) when p = max_int ->
- (* k belongs to tree *)
- if zero_bit (K.tag k) p
- then find_smaller_opt' t1 k t0
- else find_smaller_opt' mk_Empty k t1
- | _ ->
- find_smaller_opt' mk_Empty k t
-
-(* -------------------------------------------------------------------------- *)
-(* --- Comparison --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec compare cmp s t =
- if (Obj.magic s) == t then 0 else
- match view s , view t with
- | Empty , Empty -> 0
- | Empty , _ -> (-1)
- | _ , Empty -> 1
- | Lf(i,x) , Lf(j,y) ->
- let ck = Pervasives.compare (K.tag i) (K.tag j) in
- if ck = 0 then cmp x y else ck
- | Lf _ , _ -> (-1)
- | _ , Lf _ -> 1
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- let cp = Pervasives.compare p q in
- if cp <> 0 then cp else
- let c0 = compare cmp s0 t0 in
- if c0 <> 0 then c0 else
- compare cmp s1 t1
-
-let rec equal eq s t =
- if (Obj.magic s) == t then true else
- match view s , view t with
- | Empty , Empty -> true
- | Lf(i,x) , Lf(j,y) -> K.equal i j && eq x y
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- p==q && equal eq s0 t0 && equal eq s1 t1
- | _ -> false
-
-(* -------------------------------------------------------------------------- *)
-(* --- Addition, Insert, Change, Remove --- *)
-(* -------------------------------------------------------------------------- *)
-
-(* good sharing *)
-let rec change phi k x t = match view t with
- | Empty -> (match phi k x None with
- | None -> t
- | Some w -> mk_Lf k w)
- | Lf(i,y) ->
- if K.equal i k then
- lf0 k y t (phi k x (Some y))
- else
- (match phi k x None with
- | None -> t
- | Some w -> let s = mk_Lf k w in
- join (K.tag k) s (K.tag i) t)
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- (* k belongs to tree *)
- if zero_bit (K.tag k) p
- then br0 p t0 t1 t (change phi k x t0) (* k is in t0 *)
- else br1 p t0 t1 t (change phi k x t1) (* k is in t1 *)
- else
- (* k is disjoint from tree *)
- (match phi k x None with
- | None -> t
- | Some w -> let s = mk_Lf k w in
- join (K.tag k) s p t)
-
-(* good sharing *)
-let insert f k x = change (fun _k x -> function
- | None -> Some x
- | Some old -> Some (f k x old)) k x
-
-(* good sharing *)
-let add k x m = change (fun _k x _old -> Some x) k x m
-
-(* good sharing *)
-let remove k m = change (fun _k () _old -> None) k () m
-
-(* good sharing *)
-let add_new e x v m = change (fun _k (e,v) -> function
- | Some _ -> raise e
- | None -> Some v) x (e,v) m
-
-(* good sharing *)
-let rec add_change empty add k b t = match view t with
- | Empty -> mk_Lf k (empty b)
- | Lf(i,y) ->
- if K.equal i k then
- let y' = (add b y) in
- if y == y' then t else mk_Lf i y'
- else
- let s = mk_Lf k (empty b) in
- join (K.tag k) s (K.tag i) t
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- (* k belongs to tree *)
- if zero_bit (K.tag k) p
- then mk_Br p (add_change empty add k b t0) t1 (* k is in t0 *)
- else mk_Br p t0 (add_change empty add k b t1) (* k is in t1 *)
- else
- (* k is disjoint from tree *)
- let s = mk_Lf k (empty b) in
- join (K.tag k) s p t
-
-(* -------------------------------------------------------------------------- *)
-(* --- Map --- *)
-(* -------------------------------------------------------------------------- *)
-
-let mapi phi t =
- let rec mapi phi t = match view t with
- | Empty -> mk_Empty
- | Lf(k,x) -> mk_Lf k (phi k x)
- | Br(p,t0,t1) ->
- let t0 = mapi phi t0 in
- let t1 = mapi phi t1 in
- mk_Br p t0 t1
- in match view t with (* in order to be sorted *)
- | Empty -> mk_Empty
- | Lf(k,x) -> mk_Lf k (phi k x)
- | Br(p,t0,t1) when p = max_int -> let t1 = mapi phi t1 in
- let t0 = mapi phi t0 in mk_Br p t0 t1
- | Br(p,t0,t1) -> let t0 = mapi phi t0 in
- let t1 = mapi phi t1 in mk_Br p t0 t1
-let map phi = mapi (fun _ x -> phi x)
-
-let mapf phi t =
- let rec mapf phi t = match view t with
- | Empty -> mk_Empty
- | Lf(k,x) -> lf k (phi k x)
- | Br(_,t0,t1) -> glue (mapf phi t0) (mapf phi t1)
- in match view t with (* in order to be sorted *)
- | Empty -> mk_Empty
- | Lf(k,x) -> lf k (phi k x)
- | Br(p,t0,t1) when p = max_int -> let t1 = mapf phi t1 in
- let t0 = mapf phi t0 in glue t0 t1
- | Br(_,t0,t1) -> let t0 = mapf phi t0 in
- let t1 = mapf phi t1 in glue t0 t1
-
-(* good sharing *)
-let mapq phi t =
- let rec mapq phi t = match view t with
- | Empty -> t
- | Lf(k,x) -> lf0 k x t (phi k x)
- | Br(_,t0,t1) ->
- let t0' = mapq phi t0 in
- let t1' = mapq phi t1 in
- glue01 t0' t1' t0 t1 t
- in match view t with (* to be sorted *)
- | Empty -> t
- | Lf(k,x) -> lf0 k x t (phi k x)
- | Br(p,t0,t1) when p = max_int ->
- let t1' = mapq phi t1 in
- let t0' = mapq phi t0 in
- glue01 t0' t1' t0 t1 t
- | Br(_,t0,t1) ->
- let t0' = mapq phi t0 in
- let t1' = mapq phi t1 in
- glue01 t0' t1' t0 t1 t
-
-(** bad sharing but polymorph *)
-let mapq' :
- type a b. (key -> a data -> b data option) -> a data t -> b data t=
- fun phi t ->
- let rec aux phi t = match view t with
- | Empty -> mk_Empty
- | Lf(k,x) -> lf k (phi k x)
- | Br(_,t0,t1) ->
- let t0' = aux phi t0 in
- let t1' = aux phi t1 in
- glue t0' t1'
- in match view t with (* to be sorted *)
- | Empty -> mk_Empty
- | Lf(k,x) -> lf k (phi k x)
- | Br(p,t0,t1) when p = max_int ->
- let t1' = aux phi t1 in
- let t0' = aux phi t0 in
- glue t0' t1'
- | Br(_,t0,t1) ->
- let t0' = aux phi t0 in
- let t1' = aux phi t1 in
- glue t0' t1'
-
-let filter f m = mapq' (fun k v -> if f k v then Some v else None) m
-let mapi_filter = mapq'
-let map_filter f m = mapq' (fun _ v -> f v) m
-
-(**bad sharing because the input type can be differente of the output type
- it is possible but currently too many Obj.magic are needed in lf0 and glue01
-*)
-let mapi_filter_fold:
- type a b acc. (key -> a data -> acc -> acc * b data option) ->
- a data t -> acc -> acc * b data t
- = fun phi t acc ->
- let rec aux phi t acc = match view t with
- | Empty -> acc, mk_Empty
- | Lf(k,x) -> let acc,x = (phi k x acc) in acc, lf k x
- | Br(_,t0,t1) ->
- let acc, t0' = aux phi t0 acc in
- let acc, t1' = aux phi t1 acc in
- acc, glue t0' t1'
- in match view t with (* to be sorted *)
- | Empty -> acc, mk_Empty
- | Lf(k,x) -> let acc,x = (phi k x acc) in acc, lf k x
- | Br(p,t0,t1) when p = max_int ->
- let acc, t1' = aux phi t1 acc in
- let acc, t0' = aux phi t0 acc in
- acc, glue t0' t1'
- | Br(_,t0,t1) ->
- let acc, t0' = aux phi t0 acc in
- let acc, t1' = aux phi t1 acc in
- acc, glue t0' t1'
-
-let mapi_fold phi t acc =
- mapi_filter_fold (fun k v acc ->
- let acc, v' = phi k v acc in
- acc, Some v') t acc
-
-(* good sharing *)
-let rec partition p t = match view t with
- | Empty -> (t,t)
- | Lf(k,x) -> if p k x then t,mk_Empty else mk_Empty,t
- | Br(_,t0,t1) ->
- let (t0',u0') = partition p t0 in
- let (t1',u1') = partition p t1 in
- if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
- else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
- else (glue t0' t1'),(glue u0' u1')
-
-(* good sharing *)
-let split k t =
- let rec aux k t = match view t with
- | Empty -> assert false (** absurd: only at top *)
- | Lf(k',x) -> let c = Pervasives.compare (K.tag k) (K.tag k') in
- if c = 0 then (mk_Empty,Some x,mk_Empty)
- else if c < 0 then (mk_Empty, None, t)
- else (* c > 0 *) (t, None, mk_Empty)
- | Br(p,t0,t1) ->
- if match_prefix (K.tag k) p then
- if zero_bit (K.tag k) p
- then
- let (t0',r,t1') = aux k t0 in
- (t0',r,glue' ~old:t0 ~cur:t1' ~other:t1 ~all:t )
- else
- let (t0',r,t1') = aux k t1 in
- (glue' ~old:t1 ~cur:t0' ~other:t0 ~all:t,r,t1')
- else
- if side (K.tag k) p
- then (* k p *) (mk_Empty, None, t)
- else (* p k *) (t, None, mk_Empty)
- in match view t with
- | Empty -> mk_Empty, None, mk_Empty
- | Br(p,t0,t1) when p = max_int -> (** inverted *)
- if zero_bit (K.tag k) p
- then
- let (t0',r,t1') = aux k t0 in
- (glue' ~old:t0 ~cur:t0' ~other:t1 ~all:t,r,t1' )
- else
- let (t0',r,t1') = aux k t1 in
- (t0',r,glue' ~old:t1 ~cur:t1' ~other:t0 ~all:t)
- | _ -> aux k t
-
-(* good sharing *)
-let rec partition_split p t = match view t with
- | Empty -> (t,t)
- | Lf(k,x) -> let u,v = p k x in (lf0 k x t u), (lf0 k x t v)
- | Br(_,t0,t1) ->
- let t0',u0' = partition_split p t0 in
- let t1',u1' = partition_split p t1 in
- if t0'==t0 && t1'==t1 then (t, u0') (* u0' and u1' are empty *)
- else if u0'==t0 && u1'==t1 then (t0', t) (* t0' and t1' are empty *)
- else (glue t0' t1'),(glue u0' u1')
-
-(* -------------------------------------------------------------------------- *)
-(* --- Iter --- *)
-(* -------------------------------------------------------------------------- *)
-
-let iteri phi t =
- let rec aux t = match view t with
- | Empty -> ()
- | Lf(k,x) -> phi k x
- | Br(_,t0,t1) -> aux t0 ; aux t1
- in match view t with (* in order to be sorted *)
- | Empty -> ()
- | Lf(k,x) -> phi k x
- | Br(p,t0,t1) when p = max_int -> aux t1 ; aux t0
- | Br(_,t0,t1) -> aux t0 ; aux t1
-
-let iter = iteri
-
-let foldi phi t e = (* increasing order *)
- let rec aux t e = match view t with
- | Empty -> e
- | Lf(i,x) -> phi i x e
- | Br(_,t0,t1) -> aux t1 (aux t0 e)
- in match view t with (* to be sorted *)
- | Empty -> e
- | Lf(i,x) -> phi i x e
- | Br(p,t0,t1) when p = max_int -> aux t0 (aux t1 e)
- | Br(_,t0,t1) -> aux t1 (aux t0 e)
-
-let fold = foldi
-
-let fold_left phi e t = (* increasing order *)
- let rec aux t e = match view t with
- | Empty -> e
- | Lf(k,x) -> phi e k x
- | Br(_,t0,t1) -> aux t1 (aux t0 e)
- in match view t with (* to be sorted *)
- | Empty -> e
- | Lf(k,x) -> phi e k x
- | Br(p,t0,t1) when p = max_int -> aux t0 (aux t1 e)
- | Br(_,t0,t1) -> aux t1 (aux t0 e)
-
-let foldd phi t e = (* decreasing order *)
- let rec aux t e = match view t with
- | Empty -> e
- | Lf(i,x) -> phi i x e
- | Br(_,t0,t1) -> aux t0 (aux t1 e)
- in match view t with (* to be sorted *)
- | Empty -> e
- | Lf(i,x) -> phi i x e
- | Br(p,t0,t1) when p = max_int -> aux t1 (aux t0 e)
- | Br(_,t0,t1) -> aux t0 (aux t1 e)
-
-(* decreasing order on f to have the list in increasing order *)
-let mapl f m = foldd (fun k v a -> (f k v)::a) m []
-let bindings m = mapl (fun k v -> (k,v)) m
-let values m = mapl (fun _ v -> v) m
-let keys m = mapl (fun k _ -> k) m
-
-let for_all phi t = (* increasing order *)
- let rec aux t = match view t with
- | Empty -> true
- | Lf(k,x) -> phi k x
- | Br(_,t0,t1) -> aux t0 && aux t1
- in match view t with (* in order to be sorted *)
- | Empty -> true
- | Lf(k,x) -> phi k x
- | Br(p,t0,t1) when p = max_int -> aux t1 && aux t0
- | Br(_,t0,t1) -> aux t0 && aux t1
-
-let exists phi t = (* increasing order *)
- let rec aux t = match view t with
- | Empty -> false
- | Lf(k,x) -> phi k x
- | Br(_,t0,t1) -> aux t0 || aux t1
- in match view t with (* in order to be sorted *)
- | Empty -> false
- | Lf(k,x) -> phi k x
- | Br(p,t0,t1) when p = max_int -> aux t1 || aux t0
- | Br(_,t0,t1) -> aux t0 || aux t1
-
-
-let min_binding t = (* increasing order *)
- let rec aux t = match view t with
- | Empty -> assert false (** absurd: only at top *)
- | Lf(k,x) -> (k,x)
- | Br(_,t0,_) -> aux t0
- in match view t with (* in order to be sorted *)
- | Empty -> raise Not_found
- | Lf(k,x) -> (k,x)
- | Br(p,_,t1) when p = max_int -> aux t1
- | Br(_,t0,_) -> aux t0
-
-let max_binding t = (* increasing order *)
- let rec aux t = match view t with
- | Empty -> assert false (** absurd: only at top *)
- | Lf(k,x) -> (k,x)
- | Br(_,_,t1) -> aux t1
- in match view t with (* in order to be sorted *)
- | Empty -> raise Not_found
- | Lf(k,x) -> (k,x)
- | Br(p,t0,_) when p = max_int -> aux t0
- | Br(_,_,t1) -> aux t1
-
-let choose = min_binding
-
-(* -------------------------------------------------------------------------- *)
-(* --- Inter --- *)
-(* -------------------------------------------------------------------------- *)
-
-let occur i t = try Some (find i t) with Not_found -> None
-
-let rec interi lf_phi s t =
- match view s , view t with
- | Empty , _ -> mk_Empty
- | _ , Empty -> mk_Empty
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then lf_phi i x y
- else mk_Empty
- | Lf(i,x) , Br _ ->
- (match occur i t with None -> mk_Empty | Some y -> lf_phi i x y)
- | Br _ , Lf(j,y) ->
- (match occur j s with None -> mk_Empty | Some x -> lf_phi j x y)
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue (interi lf_phi s0 t0) (interi lf_phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then interi lf_phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else interi lf_phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then interi lf_phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else interi lf_phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- mk_Empty
-
-let interf phi = interi (fun i x y -> mk_Lf i (phi i x y))
-let inter phi = interi (fun i x y -> lf i (phi i x y))
-
-(* good sharing with s *)
-let lfq phi i x y s t =
- match phi i x y with
- | None -> mk_Empty
- | Some w -> if w == x then s else if w == y then t else mk_Lf i w
-let occur0 phi i x s t =
- try let (y,t) = findq i t in lfq phi i x y s t
- with Not_found -> mk_Empty
-let occur1 phi j y s t =
- try let (x,s) = findq j s in lfq phi j x y s t
- with Not_found -> mk_Empty
-
-(* good sharing with s *)
-let rec interq phi s t =
- match view s , view t with
- | Empty , _ -> s
- | _ , Empty -> t
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then lfq phi i x y s t
- else mk_Empty
- | Lf(i,x) , Br _ -> occur0 phi i x s t
- | Br _ , Lf(j,y) -> occur1 phi j y s t
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue2 (interq phi s0 t0) (interq phi s1 t1) s0 s1 s t0 t1 t
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then interq phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else interq phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then interq phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else interq phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- mk_Empty
-
-(* -------------------------------------------------------------------------- *)
-(* --- Union --- *)
-(* -------------------------------------------------------------------------- *)
-
-(* good sharing with s *)
-let br2u p s0' s1' s' t0' t1' t' t0 t1=
- if s0'==t0 && s1'== t1 then s' else
- if t0'==t0 && t1'== t1 then t' else
- mk_Br p t0 t1
-
-(* good sharing with s *)
-let br0u p t0' t1' t' t0 = if t0'==t0 then t' else mk_Br p t0 t1'
-let br1u p t0' t1' t' t1 = if t1'==t1 then t' else mk_Br p t0' t1
-
-(* good sharing with s *)
-let rec unionf phi s t =
- match view s , view t with
- | Empty , _ -> t
- | _ , Empty -> s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then let w = phi i x y in
- if w == x then s else if w == y then t else mk_Lf i w
- else join (K.tag i) s (K.tag j) t
- | Lf(i,x) , Br _ -> insert phi i x t
- | Br _ , Lf(j,y) -> insert (fun j y x -> phi j x y) j y s
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- br2u p s0 s1 s t0 t1 t (unionf phi s0 t0) (unionf phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then
- (* t has bit m = 0 => t is inside s0 *)
- br0u p s0 s1 s (unionf phi s0 t)
- else
- (* t has bit m = 1 => t is inside s1 *)
- br1u p s0 s1 s (unionf phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then
- (* s has bit n = 0 => s is inside t0 *)
- br0u q t0 t1 t (unionf phi s t0)
- else
- (* t has bit n = 1 => s is inside t1 *)
- br1u q t0 t1 t (unionf phi s t1)
- else
- (* prefix disagree *)
- join p s q t
-
-(* good sharing with s *)
-let rec union phi s t =
- match view s , view t with
- | Empty , _ -> t
- | _ , Empty -> s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then match phi i x y with
- | Some w when w == x -> s
- | Some w when w == y -> t
- | Some w -> mk_Lf i w
- | None -> mk_Empty
- else join (K.tag i) s (K.tag j) t
- | Lf(i,x) , Br _ ->
- change (fun i x -> function | None -> Some x
- | Some old -> (phi i x old)) i x t
- | Br _ , Lf(j,y) ->
- change (fun j y -> function | None -> Some y
- | Some old -> (phi j old y)) j y s
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue2 (union phi s0 t0) (union phi s1 t1) s0 s1 s t0 t1 t
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then
- (* t has bit m = 0 => t is inside s0 *)
- br0 p s0 s1 s (union phi s0 t)
- else
- (* t has bit m = 1 => t is inside s1 *)
- br1 p s0 s1 s (union phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then
- (* s has bit n = 0 => s is inside t0 *)
- br0 q t0 t1 t (union phi s t0)
- else
- (* t has bit n = 1 => s is inside t1 *)
- br1 q t0 t1 t (union phi s t1)
- else
- (* prefix disagree *)
- join p s q t
-
-(* -------------------------------------------------------------------------- *)
-(* --- Merge --- *)
-(* -------------------------------------------------------------------------- *)
-
-let map1 phi s = mapf (fun i x -> phi i (Some x) None) s
-let map2 phi t = mapf (fun j y -> phi j None (Some y)) t
-
-let rec merge phi s t =
- match view s , view t with
- | Empty , _ -> map2 phi t
- | _ , Empty -> map1 phi s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j then lf i (phi i (Some x) (Some y))
- else
- let a = lf i (phi i (Some x) None) in
- let b = lf j (phi j None (Some y)) in
- glue a b
-
- | Lf(i,x) , Br(q,t0,t1) ->
- if match_prefix (K.tag i) q then
- (* leaf i is in tree t *)
- if zero_bit (K.tag i) q
- then glue (merge phi s t0) (map2 phi t1) (* s=i is in t0 *)
- else glue (map2 phi t0) (merge phi s t1) (* s=i is in t1 *)
- else
- (* leaf i does not appear in t *)
- glue (lf i (phi i (Some x) None)) (map2 phi t)
-
- | Br(p,s0,s1) , Lf(j,y) ->
- if match_prefix (K.tag j) p then
- (* leaf j is in tree s *)
- if zero_bit (K.tag j) p
- then glue (merge phi s0 t) (map1 phi s1) (* t=j is in s0 *)
- else glue (map1 phi s0) (merge phi s1 t) (* t=j is in s1 *)
- else
- (* leaf j does not appear in s *)
- glue (map1 phi s) (lf j (phi j None (Some y)))
-
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue (merge phi s0 t0) (merge phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- glue (merge phi s0 t) (map1 phi s1)
- else (* t has bit m = 1 => t is inside s1 *)
- glue (map1 phi s0) (merge phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then (* s has bit n = 0 => s is inside t0 *)
- glue (merge phi s t0) (map2 phi t1)
- else (* s has bit n = 1 => s is inside t1 *)
- glue (map2 phi t0) (merge phi s t1)
- else
- glue (map1 phi s) (map2 phi t)
-
-let map2 phi t = mapf (fun j y -> phi j None y) t
-let rec union_merge phi s t =
- match view s , view t with
- | Empty , _ -> map2 phi t
- | _ , Empty -> s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j then lf i (phi i (Some x) y)
- else
- let b = lf j (phi j None y) in
- glue s b
-
- | Lf(i,x) , Br(q,t0,t1) ->
- if match_prefix (K.tag i) q then
- (* leaf i is in tree t *)
- if zero_bit (K.tag i) q
- then glue (union_merge phi s t0) (map2 phi t1) (* s=i is in t0 *)
- else glue (map2 phi t0) (union_merge phi s t1) (* s=i is in t1 *)
- else
- (* leaf i does not appear in t *)
- glue s (map2 phi t)
-
- | Br(p,s0,s1) , Lf(j,y) ->
- if match_prefix (K.tag j) p then
- (* leaf j is in tree s *)
- if zero_bit (K.tag j) p
- then glue (union_merge phi s0 t) s1 (* t=j is in s0 *)
- else glue s0 (union_merge phi s1 t) (* t=j is in s1 *)
- else
- (* leaf j does not appear in s *)
- glue s (lf j (phi j None y))
-
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue (union_merge phi s0 t0) (union_merge phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- glue (union_merge phi s0 t) s1
- else (* t has bit m = 1 => t is inside s1 *)
- glue s0 (union_merge phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then (* s has bit n = 0 => s is inside t0 *)
- glue (union_merge phi s t0) (map2 phi t1)
- else (* s has bit n = 1 => s is inside t1 *)
- glue (map2 phi t0) (union_merge phi s t1)
- else
- glue s (map2 phi t)
-
-
-
-(* good sharing with s *)
-let rec diffq phi s t =
- match view s , view t with
- | Empty , _ -> s
- | _ , Empty -> s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then lfq phi i x y s t
- else s
- | Lf(i,x) , Br _ ->
- (match occur i t with None -> s | Some y -> lfq phi i x y s t)
- | Br _ , Lf(j,y) -> change (fun j y x -> match x with
- | None -> None
- | Some x -> phi j x y) j y s
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- let t0' = (diffq phi s0 t0) in
- let t1' = (diffq phi s1 t1) in
- glue01 t0' t1' s0 s1 s
- else if included_prefix p q then
- (* q contains p. *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- let s0' = (diffq phi s0 t) in
- glue0 s0' s0 s1 s
- else (* t has bit m = 1 => t is inside s1 *)
- let s1' = (diffq phi s1 t) in
- glue1 s1' s0 s1 s
- else if included_prefix q p then
- (* p contains q. *)
- if zero_bit p q
- then diffq phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else diffq phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- s
-
-(* good sharing with s *)
-let rec diff :
- type a b. (key -> a data -> b data -> a data option) ->
- a data t -> b data t -> a data t
- = fun phi s t ->
- match view s , view t with
- | Empty , _ -> s
- | _ , Empty -> s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then lf0 i x s (phi i x y)
- else s
- | Lf(i,x) , Br _ ->
- (match occur i t with None -> s | Some y -> lf0 i x s (phi i x y))
- | Br _ , Lf(j,y) -> change (fun j y x -> match x with
- | None -> None
- | Some x -> phi j x y) j y s
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- let t0' = (diff phi s0 t0) in
- let t1' = (diff phi s1 t1) in
- glue01 t0' t1' s0 s1 s
- else if included_prefix p q then
- (* q contains p. *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- let s0' = (diff phi s0 t) in
- glue0 s0' s0 s1 s
- else (* t has bit m = 1 => t is inside s1 *)
- let s1' = (diff phi s1 t) in
- glue1 s1' s0 s1 s
- else if included_prefix q p then
- (* p contains q. *)
- if zero_bit p q
- then diff phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else diff phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- s
-
-(* -------------------------------------------------------------------------- *)
-(* --- Iter Kernel --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec iterk phi s t =
- match view s , view t with
- | Empty , _ | _ , Empty -> ()
- | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y
- | Lf(i,x) , Br _ ->
- (match occur i t with None -> () | Some y -> phi i x y)
- | Br _ , Lf(j,y) ->
- (match occur j s with None -> () | Some x -> phi j x y)
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (iterk phi s0 t0 ; iterk phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then iterk phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else iterk phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then iterk phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else iterk phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- ()
-
-(* -------------------------------------------------------------------------- *)
-(* --- Iter2 --- *)
-(* -------------------------------------------------------------------------- *)
-
-let iter21 phi s = iteri (fun i x -> phi i (Some x) None) s
-let iter22 phi t = iteri (fun j y -> phi j None (Some y)) t
-
-let rec iter2 phi s t =
- match view s , view t with
- | Empty , _ -> iter22 phi t
- | _ , Empty -> iter21 phi s
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j then phi i (Some x) (Some y)
- else ( phi i (Some x) None ; phi j None (Some y) )
-
- | Lf(i,x) , Br(q,t0,t1) ->
- if match_prefix (K.tag i) q then
- (* leaf i is in tree t *)
- if zero_bit (K.tag i) q
- then (iter2 phi s t0 ; iter22 phi t1) (* s=i is in t0 *)
- else (iter22 phi t0 ; iter2 phi s t1) (* s=i is in t1 *)
- else
- (* leaf i does not appear in t *)
- (phi i (Some x) None ; iter22 phi t)
-
- | Br(p,s0,s1) , Lf(j,y) ->
- if match_prefix (K.tag j) p then
- (* leaf j is in tree s *)
- if zero_bit (K.tag j) p
- then (iter2 phi s0 t ; iter21 phi s1) (* t=j is in s0 *)
- else (iter21 phi s0 ; iter2 phi s1 t) (* t=j is in s1 *)
- else
- (* leaf j does not appear in s *)
- (iter21 phi s ; phi j None (Some y))
-
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (iter2 phi s0 t0 ; iter2 phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then (* t has bit m = 0 => t is inside s0 *)
- (iter2 phi s0 t ; iter21 phi s1)
- else (* t has bit m = 1 => t is inside s1 *)
- (iter21 phi s0 ; iter2 phi s1 t)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then (* s has bit n = 0 => s is inside t0 *)
- (iter2 phi s t0 ; iter22 phi t1)
- else (* s has bit n = 1 => s is inside t1 *)
- (iter22 phi t0 ; iter2 phi s t1)
- else
- (iter21 phi s ; iter22 phi t)
-
-(* -------------------------------------------------------------------------- *)
-(* --- Intersects --- *)
-(* -------------------------------------------------------------------------- *)
-
-(** TODO seems wrong *)
-let rec intersectf phi s t =
- match view s , view t with
- | Empty , _ -> false
- | _ , Empty -> false
- | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y else false
- | Lf(i,x) , Br _ -> (match occur i t with None -> false
- | Some y -> phi i x y)
- | Br _ , Lf(j,y) -> (match occur j s with None -> false
- | Some x -> phi j x y)
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (intersectf phi s0 t0) || (intersectf phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then intersectf phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else intersectf phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then intersectf phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else intersectf phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- false
-
-let rec disjoint phi s t =
- match view s , view t with
- | Empty , _ -> true
- | _ , Empty -> true
- | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y else true
- | Lf(i,x) , Br _ -> (match occur i t with None -> true
- | Some y -> phi i x y)
- | Br _ , Lf(j,y) -> (match occur j s with None -> true
- | Some x -> phi j x y)
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (disjoint phi s0 t0) && (disjoint phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then disjoint phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else disjoint phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then disjoint phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else disjoint phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- true
-
-(** fold2 *)
-let fold21 phi m acc = fold (fun i x acc -> phi i (Some x) None acc) m acc
-let fold22 phi m acc = fold (fun j y acc -> phi j None (Some y) acc) m acc
-
-(* good sharing with s *)
-let rec fold2_union:
- type a b c.
- (key -> a data option -> b data option -> c -> c) ->
- a data t -> b data t -> c -> c
- = fun phi s t acc ->
- match view s , view t with
- | Empty , _ -> fold22 phi t acc
- | _ , Empty -> fold21 phi s acc
- | Lf(i,x) , Lf(j,y) ->
- let c = Pervasives.compare (K.tag i) (K.tag j) in
- if c = 0
- then phi i (Some x) (Some y) acc
- else if c < 0 then phi j None (Some y) (phi i (Some x) None acc)
- else (* c > 0 *) phi i (Some x) None (phi j None (Some y) acc)
- | Lf(k,x) , Br(p,t1,t2) ->
- if match_prefix (K.tag k) p then
- if zero_bit (K.tag k) p
- then fold22 phi t2 (fold2_union phi s t1 acc)
- else fold2_union phi s t2 (fold22 phi t1 acc)
- else
- if side (K.tag k) p
- then (* k p *) fold22 phi t (phi k (Some x) None acc)
- else (* p k *) phi k (Some x) None (fold22 phi t acc)
- | Br(p,s1,s2) , Lf(k,y) ->
- if match_prefix (K.tag k) p then
- if zero_bit (K.tag k) p
- then fold21 phi s2 (fold2_union phi s1 t acc)
- else fold2_union phi s2 t (fold21 phi s1 acc)
- else
- if side (K.tag k) p
- then (* k p *) fold21 phi s (phi k None (Some y) acc)
- else (* p k *) phi k None (Some y) (fold21 phi s acc)
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- fold2_union phi s1 t1 (fold2_union phi s0 t0 acc)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then
- (* t has bit m = 0 => t is inside s0 *)
- fold21 phi s1 (fold2_union phi s0 t acc)
- else
- (* t has bit m = 1 => t is inside s1 *)
- fold2_union phi s1 t (fold21 phi s0 acc)
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then
- (* s has bit n = 0 => s is inside t0 *)
- fold22 phi t1 (fold2_union phi s t0 acc)
- else
- (* t has bit n = 1 => s is inside t1 *)
- fold2_union phi s t1 (fold22 phi t0 acc)
- else
- (* prefix disagree *)
- if side p q
- then (* p q *) fold22 phi t (fold21 phi s acc)
- else (* q p *) fold21 phi s (fold22 phi t acc)
-
-(* good sharing with s *)
-let rec fold2_inter phi s t acc =
- match view s , view t with
- | Empty , _ -> acc
- | _ , Empty -> acc
- | Lf(i,x) , Lf(j,y) ->
- if K.equal i j
- then phi i x y acc
- else acc
- | Lf(k,x) , Br _ ->
- begin match find_opt k t with
- | Some y -> phi k x y acc
- | None -> acc
- end
- | Br _ , Lf(k,y) ->
- begin match find_opt k s with
- | Some x -> phi k x y acc
- | None -> acc
- end
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- fold2_inter phi s1 t1 (fold2_inter phi s0 t0 acc)
- else if included_prefix p q then
- (* q contains p. Merge t with a subtree of s *)
- if zero_bit q p
- then
- (* t has bit m = 0 => t is inside s0 *)
- fold2_inter phi s0 t acc
- else
- (* t has bit m = 1 => t is inside s1 *)
- fold2_inter phi s1 t acc
- else if included_prefix q p then
- (* p contains q. Merge s with a subtree of t *)
- if zero_bit p q
- then
- (* s has bit n = 0 => s is inside t0 *)
- fold2_inter phi s t0 acc
- else
- (* t has bit n = 1 => s is inside t1 *)
- fold2_inter phi s t1 acc
- else
- (* prefix disagree *)
- acc
-
-(* -------------------------------------------------------------------------- *)
-(* --- Subset --- *)
-(* -------------------------------------------------------------------------- *)
-
-let rec subsetf phi s t =
- match view s , view t with
- | Empty , _ -> true
- | _ , Empty -> false
- | Lf(i,x) , Lf(j,y) -> if K.equal i j then phi i x y else false
- | Lf(i,x) , Br _ ->
- (match occur i t with None -> false | Some y -> phi i x y)
- | Br _ , Lf _ -> false
- | Br(p,s0,s1) , Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- (subsetf phi s0 t0 && subsetf phi s1 t1)
- else if included_prefix p q then
- (* q contains p: t is included in a (strict) subtree of s *)
- false
- else if included_prefix q p then
- (* p contains q: s is included in a subtree of t *)
- if zero_bit p q
- then subsetf phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else subsetf phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- false
-
-let subset = subsetf
-let subsetk s t = subsetf (fun _i _x _y -> true) s t
-let submap = subsetf
-
-(* -------------------------------------------------------------------------- *)
-
-let rec _pp_tree tab fmt t =
- match view t with
- | Empty -> ()
- | Lf(k,_) ->
- let k = K.tag k in
- Format.fprintf fmt "%sL%a=%d@\n" tab pp_bits k k
- | Br(p,l,r) ->
- let next = tab ^ " " in
- _pp_tree next fmt l ;
- Format.fprintf fmt "%s@@%a@\n" tab (pp_mask (decode_mask p)) p ;
- _pp_tree next fmt r
-
-
-let is_num_elt n m =
- try
- fold (fun _ _ n -> if n < 0 then raise Exit else n-1) m n = 0
- with Exit -> false
-
-let of_list l =
- List.fold_left (fun acc (k,d) -> add k d acc) empty l
-
-let translate f m =
- fold (fun k v acc -> add (f k) v acc) m empty
-
-(** set_* *)
-
-let set_union m1 m2 = unionf (fun _ x _ -> x) m1 m2
-let set_inter m1 m2 = interf (fun _ x _ -> x) m1 m2
-let set_diff m1 m2 = diff (fun _ _ _ -> None) m1 m2
-let set_submap m1 m2 = submap (fun _ _ _ -> true) m1 m2
-let set_disjoint m1 m2 = disjoint (fun _ _ _ -> false) m1 m2
-let set_compare m1 m2 = compare (fun _ _ -> 0) m1 m2
-let set_equal m1 m2 = equal (fun _ _ -> true) m1 m2
-
-(** the goal is to choose randomly but often the same than [choose] *)
-let choose_rnd f m =
- let rec aux f m ret =
- match view m with
- | Empty -> ()
- | Lf(k,v) -> if f () then (ret := (k,v); raise Exit)
- | Br(_,t1,t2) ->
- aux f t1 ret; aux f t2 ret
- in
- let ret = ref (Obj.magic 0) in
- try
- begin match view m with (* in order to be sorted *)
- | Empty -> raise Not_found
- | Br(p,_,t1) when p = max_int -> aux f t1 ret
- | _ -> aux f m ret
- end;
- choose m
- with Exit -> !ret
-
-(** Enumeration *)
-type 'a enumeration =
-| EEmpty
-| ELf of K.t * 'a * 'a enum2
-
-and 'a enum2 =
-| End
-| EBr of 'a t * 'a enum2
-
-let rec cons_enum m e =
- match view m with
- | Empty -> assert false (** absurd: Empty can appear only a toplevel *)
- | Lf(i,x) -> ELf(i,x,e)
- | Br(_,t1,t2) -> cons_enum t1 (EBr(t2,e))
-
-let start_enum m = (* in order to be sorted *)
- match view m with
- | Empty -> EEmpty
- | Lf(i,x) -> ELf(i,x,End)
- | Br(p,t1,t2) when p = max_int -> cons_enum t2 (EBr(t1, End))
- | Br(_,t1,t2) -> cons_enum t1 (EBr(t2, End))
-
-let val_enum = function
- | EEmpty -> None
- | ELf(i,x,_) -> Some (i,x)
-
-let next_enum_br = function
- | End -> EEmpty
- | EBr(t2,e) -> cons_enum t2 e
-
-let next_enum = function
- | EEmpty -> EEmpty
- | ELf(_,_,e) -> next_enum_br e
-
-let rec cons_ge_enum k m e =
- match view m with
- | Empty -> assert false (** absurd: Empty can appear only a toplevel *)
- | Lf(i,x) ->
- if side (K.tag i) (K.tag k)
- then (* i k *) next_enum_br e
- else (* k i *) ELf(i,x,e)
- | Br(p,t1,t2) ->
- if match_prefix (K.tag k) p then
- if zero_bit (K.tag k) p
- then cons_ge_enum k t1 (EBr(t2,e))
- else cons_ge_enum k t2 e
- else
- if side (K.tag k) p
- then (* k p *) cons_enum t1 (EBr(t2,e))
- else (* p k *) next_enum_br e
-
-let start_ge_enum k m =
- match view m with
- | Empty -> EEmpty
- | Br(p,t1,t2) when p = max_int ->
- if zero_bit (K.tag k) p
- then cons_ge_enum k t1 End
- else cons_ge_enum k t2 (EBr(t1,End))
- | _ -> cons_ge_enum k m End
-
-let rec next_ge_enum_br k = function
- | End -> EEmpty
- | EBr(t,e) -> match view t with
- | Empty -> assert false (** absurd: Empty only at top *)
- | Lf(i,d) when (K.tag k) <= (K.tag i) -> ELf(i,d,e)
- | Lf(_,_) -> next_ge_enum_br k e
- | Br(p,t1,t2) ->
- if match_prefix (K.tag k) p then
- if zero_bit (K.tag k) p
- then cons_ge_enum k t1 (EBr(t2,e))
- else cons_ge_enum k t2 e
- else
- if side (K.tag k) p
- then (* k p *) cons_enum t1 (EBr(t2,e))
- else (* p k *) next_ge_enum_br k e
-
-let next_ge_enum k = function
- | EEmpty -> EEmpty
- | ELf(i,_,_) as e when (K.tag k) <= (K.tag i)-> e
- | ELf(_,_,e) -> next_ge_enum_br k e
-
-let change f k m = change (fun _ () v -> f v) k () m
-
-let add_opt x o m =
- match o with
- | None -> remove x m
- | Some y -> add x y m
-
-(** TODO more checks? *)
-let check_invariant m =
- match view m with
- | Empty -> true
- | _ ->
- let rec aux m =
- match view m with
- | Empty -> false
- | Lf _ -> true
- | Br (_,t1,t2) -> aux t1 && aux t2 in
- aux m
-
-end
-
-module Def = struct
- type 'a t =
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a t * 'a t
-end
-
-module NT = struct
-
- module M : sig
- type 'a t = 'a Def.t
- type 'a data = 'a
- type 'a view = private
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a t * 'a t
- val view: 'a data t -> 'a data view
- val ktag : 'a data t -> int
- val mk_Empty: 'a data t
- val mk_Lf: K.t -> 'a data -> 'a data t
- val mk_Br: int -> 'a data t -> 'a data t -> 'a data t
- end = struct
- type 'a t = 'a Def.t
- type 'a data = 'a
-
- let ktag = function
- | Def.Empty -> assert false (** absurd: precondition: not Empty *)
- | Def.Lf(i,_) -> K.tag i
- | Def.Br(i,_,_) -> i
- let mk_Empty = Def.Empty
- let mk_Lf k d = Def.Lf(k,d)
- let mk_Br i t1 t2 =
- (* assert (t1 != Def.Empty && t2 != Def.Empty); *)
- Def.Br(i,t1,t2)
-
- type 'a view = 'a Def.t =
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a t * 'a t
-
- let view x = x
-
- end
-
- include Gen(M)
-
-end
-
-module Make(Data: Map_intf.HashType) :
- Map_intf.Map_hashcons with type 'a data = Data.t
- and type 'a poly := 'a NT.t
- and type key = K.t = struct
-
-
- (** Tag *)
- module Tag: sig
- type t
- type gen
- val mk_gen: unit -> gen
- val to_int: t -> int
- val dtag : t
- val next_tag: gen -> t
- val incr_tag: gen -> unit
- (** all of them are different from dtag *)
- end = struct
- type t = int
- type gen = int ref
- let to_int x = x
- let dtag = min_int (** tag used in the polymorphic non hashconsed case *)
- let mk_gen () = ref (min_int + 1)
- let next_tag gen = !gen
- let incr_tag gen = incr gen; assert (!gen != dtag)
-
- end
-
- module M : sig
- type (+'a) t
- type 'a data = Data.t
- val nt: 'a data t -> 'a data NT.t
- val rebuild: 'a data NT.t -> 'a data t
- type 'a view = private
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a t * 'a t
- val view: 'a data t -> 'a data view
- val tag : 'a data t -> int
- val ktag : 'a data t -> int
- val mk_Empty: 'a data t
- val mk_Lf: K.t -> 'a data -> 'a data t
- val mk_Br: int -> 'a data t -> 'a data t -> 'a data t
- end = struct
- module Check = struct
- type 'a def = 'a Def.t = (** check the type of Def.t *)
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a def * 'a def
- end
-
- type 'a t =
- | Empty
- | Lf of K.t * 'a * Tag.t
- | Br of int * 'a t * 'a t * Tag.t
-
- type 'a data = Data.t
-
- (** This obj.magic "just" hide the last field *)
- let nt x = (Obj.magic (x : 'a t) : 'a Check.def)
-
- let tag = function
- | Empty -> Tag.to_int Tag.dtag
- | Lf(_,_,tag) | Br(_,_,_,tag) -> Tag.to_int tag
-
- let ktag = function
- | Empty -> assert false (** absurd: Should'nt be used on Empty *)
- | Lf(k,_,_) -> K.tag k
- | Br(i,_,_,_) -> i
-
- module WH = Weak.Make(struct
- type 'a t' = 'a t
- type t = Data.t t'
-
- let equal x y =
- match x, y with
- | Empty, Empty -> true
- | Lf(i1,d1,_), Lf(i2,d2,_) ->
- K.equal i1 i2 && Data.equal d1 d2
- | Br(_,l1,r1,_), Br(_,l2,r2,_) -> l1 == l2 && r1 == r2
- | _ -> false
-
- let hash = function
- | Empty -> 0
- | Lf(i1,d1,_) ->
- 65599 * ((K.tag i1) + (Data.hash d1 * 65599 + 31))
- | Br(_,l,r,_) ->
- 65599 * ((tag l) + ((tag r) * 65599 + 17))
- end)
-
- let gentag = Tag.mk_gen ()
- let htable = WH.create 5003
-
- let hashcons d =
- let o = WH.merge htable d in
- if o == d then Tag.incr_tag gentag;
- o
-
- let mk_Empty = Empty
- let mk_Lf k x = hashcons (Lf(k,x,Tag.next_tag gentag))
- let mk_Br k t0 t1 =
- (* assert (t0 != Empty && t1 != Empty); *)
- hashcons (Br(k,t0,t1,Tag.next_tag gentag))
-
-
- let rec rebuild t = match t with
- | Def.Empty -> mk_Empty
- | Def.Lf(i,d) -> mk_Lf i d
- | Def.Br(i,l,r) -> mk_Br i (rebuild l) (rebuild r)
-
- type 'a view =
- | Empty
- | Lf of K.t * 'a
- | Br of int * 'a t * 'a t
-
- (** This obj.magic "just" hide the last field of the root node *)
- let view x = (Obj.magic (x : 'a t): 'a view)
-
- end
-
- include Gen(M)
-
- let mk_Empty = M.mk_Empty
- let mk_Lf = M.mk_Lf
-
-let nt = M.nt
-let rebuild = M.rebuild
-
-let compare_t s t = Pervasives.compare (M.tag s) (M.tag t)
-let equal_t (s:'a data t) t = s == t
-
-(** with Def.t *)
-let rec interi_nt lf_phi s t =
- match M.view s , t with
- | M.Empty , _ -> mk_Empty
- | _ , Def.Empty -> mk_Empty
- | M.Lf(i,x) , Def.Lf(j,y) ->
- if K.equal i j
- then lf_phi i x y
- else mk_Empty
- | M.Lf(i,x) , Def.Br _ ->
- (match NT.occur i t with None -> mk_Empty | Some y -> lf_phi i x y)
- | M.Br _ , Def.Lf(j,y) ->
- (match occur j s with None -> mk_Empty | Some x -> lf_phi j x y)
- | M.Br(p,s0,s1) , Def.Br(q,t0,t1) ->
- if p == q then
- (* prefixes agree *)
- glue (interi_nt lf_phi s0 t0) (interi_nt lf_phi s1 t1)
- else if included_prefix p q then
- (* q contains p. Intersect t with a subtree of s *)
- if zero_bit q p
- then interi_nt lf_phi s0 t (* t has bit m = 0 => t is inside s0 *)
- else interi_nt lf_phi s1 t (* t has bit m = 1 => t is inside s1 *)
- else if included_prefix q p then
- (* p contains q. Intersect s with a subtree of t *)
- if zero_bit p q
- then interi_nt lf_phi s t0 (* s has bit n = 0 => s is inside t0 *)
- else interi_nt lf_phi s t1 (* t has bit n = 1 => s is inside t1 *)
- else
- (* prefix disagree *)
- mk_Empty
-
-let inter_nt phi = interi_nt (fun i x y -> mk_Lf i (phi i x y))
-let interf_nt phi = interi_nt (fun i x y -> lf i (phi i x y))
-let set_inter_nt m1 m2 = interi_nt (fun i x _ -> mk_Lf i x) m1 m2
-
-end
-
-end
diff --git a/src/util/pp.mli b/src/util/pp.mli
deleted file mode 100644
index 3fb167699..000000000
--- a/src/util/pp.mli
+++ /dev/null
@@ -1,158 +0,0 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
-
-(*i $Id: pp.mli,v 1.22 2009-10-19 11:55:33 bobot Exp $ i*)
-
-type formatter = Format.formatter
-type 'a printer = formatter -> 'a -> unit
-
-val print_option : 'a printer -> 'a option printer
-val print_option_or_default :
- string -> 'a printer -> 'a option printer
-val print_list :
- unit printer ->
- 'a printer -> 'a list printer
-val print_list_or_default :
- string -> unit printer ->
- 'a printer -> 'a list printer
-val print_list_par :
- (formatter -> unit -> unit) ->
- 'b printer -> 'b list printer
-val print_list_delim :
- start:unit printer ->
- stop:unit printer ->
- sep:unit printer ->
- 'b printer -> 'b list printer
-
-val print_pair_delim :
- unit printer ->
- unit printer ->
- unit printer ->
- 'a printer ->
- 'b printer -> ('a * 'b) printer
-val print_pair :
- 'a printer ->
- 'b printer -> ('a * 'b) printer
-
-val print_iter1 :
- (('a -> unit) -> 'b -> unit) ->
- unit printer ->
- 'a printer ->
- 'b printer
-
-val print_iter2:
- (('a -> 'b -> unit) -> 'c -> unit) ->
- unit printer ->
- unit printer ->
- 'a printer ->
- 'b printer ->
- 'c printer
-(** [print_iter2 iter sep1 sep2 print1 print2 fmt t]
- iter iterator on [t : 'c]
- print1 k sep2 () print2 v sep1 () print1 sep2 () ...
-*)
-
-
-val print_iteri2:
- (('a -> 'b -> unit) -> 'c -> unit) ->
- unit printer ->
- unit printer ->
- 'a printer ->
- ('a -> 'b printer) ->
- 'c printer
-(** [print_iter2 iter sep1 sep2 print1 print2 fmt t]
- iter iterator on [t : 'c]
- print1 k sep2 () print2 v sep1 () print1 sep2 () ...
-*)
-
-val print_iter22:
- (('a -> 'b -> unit) -> 'c -> unit) ->
- unit printer ->
- (formatter -> 'a -> 'b -> unit) ->
- 'c printer
-(** [print_iter22 iter sep print fmt t]
- iter iterator on [t : 'c]
- print k v sep () print k v sep () ...
-*)
-
-(** formatted: string which is formatted "@ " allow to cut the line if
- too long *)
-type formatted = (unit, unit, unit, unit, unit, unit) format6
-val empty_formatted : formatted
-
-val space : unit printer
-val alt : unit printer
-val alt2 : unit printer
-val newline : unit printer
-val newline2 : unit printer
-val dot : unit printer
-val comma : unit printer
-val star : unit printer
-val simple_comma : unit printer
-val semi : unit printer
-val colon : unit printer
-val underscore : unit printer
-val equal : unit printer
-val arrow : unit printer
-val lbrace : unit printer
-val rbrace : unit printer
-val lsquare : unit printer
-val rsquare : unit printer
-val lparen : unit printer
-val rparen : unit printer
-val lchevron : unit printer
-val rchevron : unit printer
-val nothing : 'a printer
-val string : string printer
-val float : float printer
-val int : int printer
-val constant_string : string -> unit printer
-val formatted : formatted printer
-val constant_formatted : formatted -> unit printer
-val print0 : unit printer
-val hov : int -> 'a printer -> 'a printer
-val indent : int -> 'a printer -> 'a printer
-(** add the indentation at the first line *)
-val add_flush : 'a printer -> 'a printer
-
-val asd : 'a printer -> 'a printer
-(** add string delimiter " " *)
-
-val open_formatter : ?margin:int -> out_channel -> formatter
-val close_formatter : formatter -> unit
-val open_file_and_formatter : ?margin:int -> string -> out_channel * formatter
-val close_file_and_formatter : out_channel * formatter -> unit
-val print_in_file_no_close :
- ?margin:int -> (formatter -> unit) -> string -> out_channel
-val print_in_file : ?margin:int -> (formatter -> unit) -> string -> unit
-
-
-val print_list_opt :
- unit printer ->
- (formatter -> 'a -> bool) -> formatter -> 'a list -> bool
-
-
-val string_of : 'a printer -> 'a -> string
-val string_of_wnl : 'a printer -> 'a -> string
- (** same as {!string_of} but without newline *)
-
-val wnl : formatter -> unit
-
-val sprintf :
- ('b, formatter, unit, string) Pervasives.format4 -> 'b
-
-val sprintf_wnl :
- ('b, formatter, unit, string) Pervasives.format4 -> 'b
-
-module Ansi :
-sig
- val set_column : int printer
-end
diff --git a/src/util/rc.mli b/src/util/rc.mli
deleted file mode 100644
index cdb3f08ab..000000000
--- a/src/util/rc.mli
+++ /dev/null
@@ -1,221 +0,0 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
-
-(** Rc file management *)
-
-(** {2 Exception} *)
-
-type rc_value =
- | RCint of int
- | RCbool of bool
- | RCfloat of float
- | RCstring of string
- | RCident of string
-
-(* exception SyntaxError *)
-exception ExtraParameters of string
-(** [ExtraParameters name] One section of name [name] has two many
- parameters : more than one if [name] is a family, more than none
- if [name] is a section *)
-
-exception MissingParameters of string
-(** [MissingParameters name] One section of a family [name] has no
- parameters *)
-
-(* exception UnknownSection of string *)
-exception UnknownField of string
-(** [UnknownField key] The key [key] appeared in a section but is not
- expected there *)
-(* exception MissingSection of string *)
-exception MissingField of string
-(** [MissingField key] The field [key] is required but not given *)
-exception DuplicateSection of string
-(** [DuplicateSection name] section [name] appears more than once *)
-exception DuplicateField of string * rc_value * rc_value
-(** [DuplicateField key] key [key] appears more than once *)
-exception StringExpected of string * rc_value
-(** [StringExpected key value] string expected *)
-(* exception IdentExpected of string * rc_value *)
-(* (\** [IdentExpected key value] string expected *\) *)
-exception IntExpected of string * rc_value
-(** [IntExpected key value] int expected *)
-exception BoolExpected of string * rc_value
-(** [BoolExpected key value] bool expected *)
-
-
-(** {2 RC API} *)
-
-
-type t (** Rc parsed file *)
-type section (** section in rc file *)
-type family = (string * section) list (** A family in rc files *)
-type simple_family = section list (** A family w/o arguments in rc files*)
-
-val empty : t (** An empty Rc *)
-val empty_section : section (** An empty section *)
-
-val get_section : t -> string -> section option
-(** [get_section rc name]
- @return None if the section is not in the rc file
- @raise DuplicateSection if multiple section has the name [name]
- @raise ExtraParameters if [name] is a family in [rc] instead of a section
-*)
-
-val get_family : t -> string -> family
-(** [get_family rc name] return all the sections of the family [name] in [rc]
- @raise MissingParameters if [name] also corresponds to a section in [rc]
-*)
-
-val get_simple_family : t -> string -> simple_family
-(** [get_simple_family rc name] return all the sections of the simple
- family [name] in [rc]
- @raise ExtraParameters if [name] also corresponds to family in [rc]
-*)
-
-val set_section : t -> string -> section -> t
-(** [set_section rc name section] add a section [section] with name [name]
- in [rc]. Remove former section [name] if present in [rc]
-*)
-
-val set_family : t -> string -> family -> t
-(** [set_family rc name family] add all the section in [family] using
- the associated [string] as argument of the family [name] in [rc].
- Remove all the former sections of family [name] if present in [rc].
-*)
-
-val set_simple_family : t -> string -> simple_family -> t
-(** [set_simple_family rc name family] add all the section in [family]
- using the associated [string] as argument of the family [name] in [rc].
- Remove all the former sections of family [name] if present in [rc].
-*)
-
-val get_int : ?default:int -> section -> string -> int
-(** [get_int ~default section key] one key to one value
-
- @raise Bad_value_type if the value associated to [key] is not of type
- {!int}
-
- @raise Key_not_found if default is not given and no value is
- associated to [key]
-
- @raise Multiple_value if the key appears multiple time.
-*)
-
-val get_into : section -> string -> int option
-
-val get_intl : ?default:int list -> section -> string -> int list
-(** [get_intl ~default section key] one key to many value
-
- @raise Bad_value_type if the value associated to [key] is not of
- type {!int}
-
- @raise MissingField if default is not given and no values are
- associated to [key]
-*)
-
-val set_int : ?default:int -> section -> string -> int -> section
-(** [set_int ?default section key value] add the association [key] to [value]
- in the section if value is not default.
- Remove all former associations with this [key]
-*)
-
-val set_intl : ?default:int list -> section -> string -> int list -> section
-(** [set_int ?default section key lvalue] add the associations [key] to all the
- [lvalue] in the section if value is not default.
- Remove all former associations with this [key]
-*)
-
-val get_bool : ?default:bool -> section -> string -> bool
-(** Same as {!get_int} but on bool *)
-
-val get_booll : ?default:bool list -> section -> string -> bool list
-(** Same as {!get_intl} but on bool *)
-
-val get_boolo : section -> string -> bool option
-
-val set_bool : ?default:bool -> section -> string -> bool -> section
-(** Same as {!set_int} but on bool *)
-
-val set_booll : ?default:bool list -> section -> string -> bool list -> section
-(** Same as {!set_intl} but on bool *)
-
-
-val get_string : ?default:string -> section -> string -> string
-(** Same as {!get_int} but on string *)
-
-val get_stringl : ?default:string list -> section -> string -> string list
-(** Same as {!get_intl} but on string *)
-
-val get_stringo : section -> string -> string option
-
-val set_string : ?default:string -> section -> string -> string -> section
-(** Same as {!set_int} but on string *)
-
-val set_stringl : ?default:string list ->
- section -> string -> string list -> section
-(** Same as {!set_intl} but on string *)
-
-(* val ident : ?default:string -> section -> string -> string *)
-(* (\** raise Bad_value_type *)
-(* raise Key_not_found *)
-(* raise Multiple_value *)
-(* *\) *)
-
-(* val identl : ?default:string list -> section -> string -> string list *)
-(* (\** raise Bad_value_type *)
-(* raise Key_not_found *\) *)
-
-(* val set_ident : section -> string -> string -> section *)
-(* (\** raise Yet_defined_key *)
-(* raise Bad_value_type *)
-(* *\) *)
-
-(* val set_identl : section -> string -> string list -> section *)
-(* (\** raise Yet_defined_key *)
-(* raise Bad_value_type *)
-(* *\) *)
-
-val check_exhaustive : section -> Stdlib.Sstr.t -> unit
-(** [check_exhaustive section keys] check that only the keys in [keys]
- appear inside the section [section]
-
- @raise UnknownField if it is not the case
-*)
-
-exception CannotOpen of string * string
-exception SyntaxErrorFile of string * string
-
-val from_channel : in_channel -> t
-(** [from_channel cin] returns the Rc of the input channel [cin]
- @raise SyntaxErrorFile in case of incorrect syntax
- @raise ExtraParameters if a section header has more than one argument
-*)
-
-val from_file : string -> t
-(** [from_file filename] returns the Rc of the file [filename]
- @raise CannotOpen is [filename] does not exist
- @raise SyntaxErrorFile in case of incorrect syntax
- @raise ExtraParameters if a section header has more than one argument
-*)
-
-val to_formatter : t Pp.printer
- (** [to_formatter fmt rc] writes the Rc [rc] to the formatter [fmt] *)
-
-val to_channel : out_channel -> t -> unit
- (** [to_channel cout rc] writes the Rc [rc] to the output channel [out] *)
-
-val to_file : string -> t -> unit
- (** [to_file filename rc] writes the Rc [rc] to the file [filename] *)
-
-val get_home_dir : unit -> string
- (** [get_home_dir ()] returns the home dir of the user *)
-
-
diff --git a/src/util/rc.mll b/src/util/rc.mll
deleted file mode 100644
index 9496e1dc5..000000000
--- a/src/util/rc.mll
+++ /dev/null
@@ -1,429 +0,0 @@
-(********************************************************************)
-(* *)
-(* The Why3 Verification Platform / The Why3 Development Team *)
-(* Copyright 2010-2012 -- INRIA - CNRS - Paris-Sud University *)
-(* *)
-(* This software is distributed under the terms of the GNU Lesser *)
-(* General Public License version 2.1, with the special exception *)
-(* on linking described in file LICENSE. *)
-(* *)
-(********************************************************************)
-
-{
-open Lexing
-open Format
-open Stdlib
-
-let get_home_dir () =
- try Sys.getenv "HOME"
- with Not_found ->
- (* try windows env var *)
- try Sys.getenv "USERPROFILE"
- with Not_found -> ""
-
-type rc_value =
- | RCint of int
- | RCbool of bool
- | RCfloat of float
- | RCstring of string
- | RCident of string
-
-
-(* Error handling *)
-
-(* exception SyntaxError *)
-exception ExtraParameters of string
-exception MissingParameters of string
-(* exception UnknownSection of string *)
-exception UnknownField of string
-(* exception MissingSection of string *)
-exception MissingField of string
-exception DuplicateSection of string
-exception DuplicateField of string * rc_value * rc_value
-exception StringExpected of string * rc_value
-(* dead code
-exception IdentExpected of string * rc_value
-*)
-exception IntExpected of string * rc_value
-exception BoolExpected of string * rc_value
-
-(* dead code
-let error ?loc e = match loc with
- | None -> raise e
- | Some loc -> raise (Loc.Located (loc, e))
-*)
-
-(* conf files *)
-
-let escape_string s =
- let n = ref 0 in
- for i = 0 to String.length s - 1 do
- n := !n +
- (match String.unsafe_get s i with
- | '"' | '\\' | '\n' | '\r' | '\t' -> 2
- | _ -> 1)
- done;
- if !n = String.length s then s else begin
- let s' = String.create !n in
- n := 0;
- for i = 0 to String.length s - 1 do
- let c = String.unsafe_get s i in
- begin match c with
- | ('"' | '\\' | '\n' | '\r' | '\t') ->
- String.unsafe_set s' !n '\\'; incr n
- | _ -> ()
- end;
- String.unsafe_set s' !n
- (match c with '\n' -> 'n' | '\r' -> 'r' | '\t' -> 't' | _ -> c);
- incr n
- done;
- s'
- end
-
-let print_rc_value fmt = function
- | RCint i -> fprintf fmt "%d" i
- | RCbool b -> fprintf fmt "%B" b
- | RCfloat f -> fprintf fmt "%f" f
- | RCstring s -> fprintf fmt "\"%s\"" (escape_string s)
- | RCident s -> fprintf fmt "%s" s
-
-let () = Exn_printer.register (fun fmt e -> match e with
- (* | SyntaxError -> *)
- (* fprintf fmt "syntax error" *)
- | ExtraParameters s ->
- fprintf fmt "section '%s': header too long" s
- | MissingParameters s ->
- fprintf fmt "section '%s': header too short" s
- (* | UnknownSection s -> *)
- (* fprintf fmt "unknown section '%s'" s *)
- | UnknownField s ->
- fprintf fmt "unknown field '%s'" s
- (* | MissingSection s -> *)
- (* fprintf fmt "section '%s' is missing" s *)
- | MissingField s ->
- fprintf fmt "field '%s' is missing" s
- | DuplicateSection s ->
- fprintf fmt "section '%s' is already given" s
- | DuplicateField (s,u,v) ->
- fprintf fmt "cannot set field '%s' to %a, as it is already set to %a"
- s print_rc_value v print_rc_value u
- | StringExpected (s,v) ->
- fprintf fmt "cannot set field '%s' to %a: a string is expected"
- s print_rc_value v
-(* dead code
- | IdentExpected (s,v) ->
- fprintf fmt "cannot set field '%s' to %a: an identifier is expected"
- s print_rc_value v
-*)
- | IntExpected (s,v) ->
- fprintf fmt "cannot set field '%s' to %a: an integer is expected"
- s print_rc_value v
- | e -> raise e)
-
-type section = rc_value list Mstr.t
-type family = (string * section) list
-type simple_family = section list
-
-type ofamily = (string option * section) list
-type t = ofamily Mstr.t
-
-let empty = Mstr.empty
-let empty_section = Mstr.empty
-
-let make_t tl =
- let add_key acc (key,value) =
- let l = Mstr.find_def [] key acc in
- Mstr.add key (value::l) acc in
- let add_section t (args,sectionl) =
- let sname,arg = match args with
- | [] -> assert false
- | [sname] -> sname,None
- | [sname;arg] -> sname,Some arg
- | sname::_ -> raise (ExtraParameters sname) in
- let m = List.fold_left add_key empty_section sectionl in
- let m = Mstr.map List.rev m in
- let l = Mstr.find_def [] sname t in
- Mstr.add sname ((arg,m)::l) t in
- List.fold_left add_section empty tl
-
-let get_section t sname =
- try
- let l = Mstr.find sname t in
- match l with
- | [None,v] -> Some v
- | [Some _,_] -> raise (ExtraParameters sname)
- | _ -> raise (DuplicateSection sname)
- with Not_found -> None
-
-let get_family t sname =
- try
- let l = Mstr.find sname t in
- let get (arg,section) =
- (match arg with None -> raise (MissingParameters sname) | Some v -> v,
- section) in
- List.map get l
- with Not_found -> []
-
-let get_simple_family t sname =
- try
- let l = Mstr.find sname t in
- let get (arg,section) =
- (match arg with Some _ -> raise (ExtraParameters sname) | None ->
- section) in
- List.map get l
- with Not_found -> []
-
-
-let set_section t sname section =
- Mstr.add sname [None,section] t
-
-let set_family t sname sections =
- if sections = [] then Mstr.remove sname t else
- let set (arg,section) = (Some arg,section) in
- Mstr.add sname (List.map set sections) t
-
-let set_simple_family t sname sections =
- if sections = [] then Mstr.remove sname t else
- let set section = (None,section) in
- Mstr.add sname (List.map set sections) t
-
-let get_value read section key =
- let l = Mstr.find key section in
- match l with
- | [] -> assert false
- | [v] -> read key v
- | v1::v2::_ -> raise (DuplicateField (key,v1,v2))
-
-let get_value read ?default section key =
- try
- get_value read section key
- with Not_found ->
- match default with
- | None -> raise (MissingField key)
- | Some v -> v
-
-let get_valueo read section key =
- try
- Some (get_value read section key)
- with MissingField _ -> None
-
-let get_valuel read ?default section key =
- try
- let l = Mstr.find key section in
- List.map (read key) l
- with Not_found ->
- match default with
- | None -> raise (MissingField key)
- | Some v -> v
-
-let set_value write ?default section key value =
- let actually_write = match default with
- | None -> true
- | Some default -> default <> value in
- if actually_write
- then Mstr.add key [write value] section
- else section
-
-let set_valuel write ?default section key valuel =
- if valuel = [] then Mstr.remove key section else
- let actually_write = match default with
- | None -> true
- | Some default -> default <> valuel in
- if actually_write
- then Mstr.add key (List.map write valuel) section
- else Mstr.remove key section
-
-let rint k = function
- | RCint n -> n
- | v -> raise (IntExpected (k,v))
-
-let wint i = RCint i
-
-let rbool k = function
- | RCbool b -> b
- | v -> raise (BoolExpected (k,v))
-
-let wbool b = RCbool b
-
-let rstring k = function
- | RCident s | RCstring s -> s
- | v -> raise (StringExpected (k,v))
-
-let wstring s = RCstring s
-
-let get_int = get_value rint
-let get_intl = get_valuel rint
-let get_into = get_valueo rint
-
-let set_int = set_value wint
-let set_intl = set_valuel wint
-
-let get_bool = get_value rbool
-let get_booll = get_valuel rbool
-let get_boolo = get_valueo rbool
-let set_bool = set_value wbool
-let set_booll = set_valuel wbool
-
-let get_string = get_value rstring
-let get_stringl = get_valuel rstring
-let get_stringo = get_valueo rstring
-let set_string = set_value wstring
-let set_stringl = set_valuel wstring
-
-let check_exhaustive section keyl =
- let test k _ = if Sstr.mem k keyl then ()
- else raise (UnknownField k) in
- Mstr.iter test section
-
-let buf = Buffer.create 17
-
-let current_rec = ref []
-let current_list = ref []
-let current = ref []
-
-let push_field key value =
- current_list := (key,value) :: !current_list
-
-let push_record () =
- if !current_list <> [] then
- current := (!current_rec,List.rev !current_list) :: !current;
- current_rec := [];
- current_list := []
-
- exception SyntaxError of string
- let syntax_error s = raise (SyntaxError s)
-
-}
-
-let space = [' ' '\t' '\r' '\n']+
-let digit = ['0'-'9']
-let letter = ['a'-'z' 'A'-'Z']
-let ident = (letter | '_') (letter | digit | '_' | '-' | '+' | '.') *
-let sign = '-' | '+'
-let integer = sign? digit+
-let mantissa = ['e''E'] sign? digit+
-let real = sign? digit* '.' digit* mantissa?
-let escape = ['\\''"''n''t''r']
-
-rule record = parse
- | space
- { record lexbuf }
- | '#' [^'\n']* ('\n' | eof)
- { record lexbuf }
- | '[' (ident as key) space*
- { header [key] lexbuf }
- | eof
- { push_record () }
- | (ident as key) space* '=' space*
- { value key lexbuf }
- | _ as c
- { syntax_error ("invalid keyval pair starting with " ^ String.make 1 c) }
-
-and header keylist = parse
- | (ident as key) space*
- { header (key::keylist) lexbuf }
- | ']'
- { push_record ();
- current_rec := List.rev keylist;
- record lexbuf }
- | eof
- { syntax_error "unterminated header" }
- | _ as c
- { syntax_error ("invalid header starting with " ^ String.make 1 c) }
-
-and value key = parse
- | integer as i
- { push_field key (RCint (int_of_string i));
- record lexbuf }
- | real as r
- { push_field key (RCfloat (float_of_string r));
- record lexbuf }
- | '"'
- { Buffer.clear buf;
- string_val key lexbuf }
- | "true"
- { push_field key (RCbool true);
- record lexbuf }
- | "false"
- { push_field key (RCbool false);
- record lexbuf }
- | ident as id
- { push_field key (RCident (*kind_of_ident*) id);
- record lexbuf }
- | eof
- { syntax_error "unterminated keyval pair" }
- | _ as c
- { syntax_error ("invalid value starting with " ^ String.make 1 c) }
-
-and string_val key = parse
- | '"'
- { push_field key (RCstring (Buffer.contents buf));
- record lexbuf
- }
- | [^ '\\' '"'] as c
- { Buffer.add_char buf c;
- string_val key lexbuf }
- | '\\' (['\\' '"' 'n' 'r' 't'] as c)
- { Buffer.add_char buf
- (match c with 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t' | _ -> c);
- string_val key lexbuf }
- | '\\' '\n'
- { string_val key lexbuf }
- | '\\' (_ as c)
- { Buffer.add_char buf '\\';
- Buffer.add_char buf c;
- string_val key lexbuf }
- | eof
- { syntax_error "unterminated string" }
-
-
-{
-
-let from_channel cin =
- current := [];
- record (from_channel cin);
- make_t !current
-
-exception CannotOpen of string * string
-exception SyntaxErrorFile of string * string
-
-let from_file f =
- let c =
- try open_in f with Sys_error s -> raise (CannotOpen (f, s))
- in
- try
- let r = from_channel c in close_in c; r
- with
- | SyntaxError s -> close_in c; raise (SyntaxErrorFile (f, s))
- | e -> close_in c; raise e
-
-let () = Exn_printer.register (fun fmt e -> match e with
- | CannotOpen (_, s) ->
- Format.fprintf fmt "system error: `%s'" s
- | SyntaxErrorFile (f, s) ->
- Format.fprintf fmt "syntax error in %s: %s" f s
- | _ -> raise e)
-
-let to_formatter fmt t =
- let print_kv k fmt v = fprintf fmt "%s = %a" k print_rc_value v in
- let print_kvl fmt k vl = Pp.print_list Pp.newline (print_kv k) fmt vl in
- let print_section sname fmt (h,l) =
- fprintf fmt "[%s%a]@\n%a"
- sname (Pp.print_option (fun fmt -> fprintf fmt " %s")) h
- (Pp.print_iter22 Mstr.iter Pp.newline print_kvl) l in
- let print_sectionl fmt sname l =
- Pp.print_list Pp.newline2 (print_section sname) fmt l in
- let print_t fmt t =
- Pp.print_iter22 Mstr.iter Pp.newline2 print_sectionl fmt t in
- print_t fmt t;
- pp_print_newline fmt ()
-
-let to_channel cout t =
- to_formatter (formatter_of_out_channel cout) t
-
-let to_file s t =
- let out = open_out s in
- to_channel out t;
- close_out out
-
-}
diff --git a/src/util/shuffle.mli b/src/util/shuffle.mli
deleted file mode 100644
index 71eb1e3f4..000000000
--- a/src/util/shuffle.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-val set_shuffle: int array option -> unit
-(** if None is given shuffling is disable (default) *)
-
-val is_shuffle: unit -> bool
-
-val shuffle2: ('a * 'a) -> ('a * 'a)
-(* uniform *)
-
-val shuffle3: ('a * 'a * 'a) -> ('a * 'a * 'a)
-(* uniform *)
-
-val shufflel: 'a list -> 'a list
-(* not uniform *)
-
-val seq2: ('a -> 'b) -> ('a * 'a) -> ('b * 'b)
-(* uniform *)
-
-val seq3: ('a -> 'b) -> ('a * 'a * 'a) -> ('b * 'b * 'b)
-(* uniform *)
-
-val seql': ('a -> unit) -> 'a list -> unit
-val seql : (unit -> unit) list -> unit
-
-val chooseb: ('a -> 'b) -> ((unit -> bool) ->'a -> 'b) -> 'a -> 'b
-(** [chooseb f g] call f if there is no shuffling or g otherwise.
- The first argument given to g is a random boolean generator.
-*)
-
-val int: int -> int
diff --git a/src/variable.ml b/src/variable.ml
deleted file mode 100644
index 504ccf035..000000000
--- a/src/variable.ml
+++ /dev/null
@@ -1,76 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-
-open Popop
-open Stdlib
-open Types
-
-type make_dec = Cl.t -> Explanation.chogen
-
-module Dem = struct
-
- module Data = struct
- type t = make_dec
- let print fmt _ = Format.fprintf fmt "make_dec"
- end
-
- let immediate = false
- let key = Demon.Fast.create "Variable.dec"
- let throttle = 100
- let wakeup d = function
- | Solver.Events.Fired.EventRegCl (cl,make_dec) ->
- Solver.Delayed.register_decision d (make_dec cl)
- | _ -> assert false
-end
-
-module EDem = Demon.Fast.Register(Dem)
-
-let cst =
- let h = DStr.H.create 10 in
- fun ty s ->
- try
- let cl = DStr.H.find h s in
- assert (Ty.equal (Cl.ty cl) ty);
- cl
- with Not_found ->
- let cl = Cl.fresh s ty in
- DStr.H.add h s cl;
- cl
-
-
-let dec_of_sort = Ty.H.create 20
-
-let register_sort ~dec ty =
- Ty.H.add_new Impossible dec_of_sort ty dec
-
-let add_dec ~dec t cl =
- Demon.Fast.attach t Dem.key
- [Demon.Create.EventRegCl(cl,dec)]
-
-let fresh ty s =
- match Ty.H.find_opt dec_of_sort ty with
- | Some make_dec ->
- Demon.Fast.fresh_with_reg_cl Dem.key s ty make_dec
- | None -> Cl.fresh s ty
-
-let th_register env =
- EDem.init env
diff --git a/src/variable.mli b/src/variable.mli
deleted file mode 100644
index af11ebbbd..000000000
--- a/src/variable.mli
+++ /dev/null
@@ -1,39 +0,0 @@
-(**************************************************************************)
-(* *)
-(* This file is part of Frama-C. *)
-(* *)
-(* Copyright (C) 2013 *)
-(* CEA (Commissariat à l'énergie atomique et aux énergies *)
-(* alternatives) *)
-(* *)
-(* you can redistribute it and/or modify it under the terms of the GNU *)
-(* Lesser General Public License as published by the Free Software *)
-(* Foundation, version 2.1. *)
-(* *)
-(* It 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 Lesser General Public License for more details. *)
-(* *)
-(* See the GNU Lesser General Public License version 2.1 *)
-(* for more details (enclosed in the file licenses/LGPLv2.1). *)
-(* *)
-(**************************************************************************)
-open Popop
-open Types
-
-type make_dec = Cl.t -> Explanation.chogen
-
-val cst: Ty.t -> string -> Cl.t
-(** same string, same class *)
-
-val fresh: Ty.t -> string -> Cl.t
-(** always fresh *)
-
-val add_dec: dec:make_dec -> Solver.Delayed.t -> Cl.t -> unit
-(** Ask for a decision for this *)
-
-val register_sort: dec:make_dec -> Ty.t -> unit
-
-val th_register: Solver.Delayed.t -> unit
-(** Run on every solver that will use these function *)
diff --git a/tests/Makefile b/tests/Makefile
new file mode 100644
index 000000000..45609a4fa
--- /dev/null
+++ b/tests/Makefile
@@ -0,0 +1,13 @@
+
+BIN=witan.exe
+
+all: $(BIN)
+ @cd parsing && $(MAKE) --no-print-directory
+
+clean:
+ rm -rf $(BIN)
+ cd parsing && $(MAKE) clean
+
+$(BIN):
+ @ln -f -s ../_build/default/src/bin/witan.exe witan.exe
+
diff --git a/tests/myutop_main.ml b/tests/myutop_main.ml
deleted file mode 100644
index 23117ee56..000000000
--- a/tests/myutop_main.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-
-let base = Filename.dirname Sys.executable_name
-let resolve_path s = Filename.concat base s
-
-let () =
- UTop.require ["zarith";"ocamlgraph";"cryptokit"];
- Topdirs.dir_install_printer Format.err_formatter
- Longident.(Ldot(Lident "Z","pp_print"));
- Topdirs.dir_install_printer Format.err_formatter
- Longident.(Ldot(Lident "Q","pp_print"));
-
- List.iter Topdirs.dir_directory
- (List.map resolve_path
- (List.map (Filename.concat "_build/")
- ["src";
- "src/util";
- "src/inputlang/altergo";
- "src/inputlang/dimacs_cnf";
- "src/inputlang/smtlib2";
- "tests";
- "src/cmd";
- "src/arith";
- ]));
-
- ignore (Topdirs.load_file Format.err_formatter
- (resolve_path "_build/src/cmd/popop_lib.cma"));
- List.iter (fun p -> Topdirs.dir_install_printer
- Format.err_formatter
- (Longident.Ldot(p,"print")))
- Longident.[Lident "Polynome";
- Ldot(Lident "Popop_types","Dom");
- Ldot(Lident "Popop_types","Sem");
- Ldot(Lident "Popop_types","Dem");
- Ldot(Lident "Popop_types","Cl");
- Ldot(Ldot(Lident "Solver","Events"),"Fired");
- Lident "Interval";
- Lident "Uninterp";
- ];
-
- let exec_init s =
- match UTop.parse_toplevel_phrase_default s true with
- | UTop.Value r ->
- ignore(Toploop.execute_phrase true Format.err_formatter r)
- | _ -> assert false
- in
- let init = ["open Popop;;";
- "open Types;;";] in
- let first = ref true in
- UTop.at_new_command (fun () ->
- if !first then begin
- first := false;
- List.iter exec_init init;
- end;
-
- )
-
-
-(* Start utop. It never returns. *)
-let () = UTop_main.main ()
diff --git a/tests/parsing/Axioms/SYN000+0.ax b/tests/parsing/Axioms/SYN000+0.ax
new file mode 100644
index 000000000..39ac9e448
--- /dev/null
+++ b/tests/parsing/Axioms/SYN000+0.ax
@@ -0,0 +1,37 @@
+%------------------------------------------------------------------------------
+% File : SYN000+0 : TPTP v6.4.0. Released v3.6.0.
+% Domain : Syntactic
+% Axioms : A simple include file for FOF
+% Version : Biased.
+% English :
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Syntax : Number of formulae : 3 ( 3 unit)
+% Number of atoms : 3 ( 0 equality)
+% Maximal formula depth : 1 ( 1 average)
+% Number of connectives : 0 ( 0 ~ ; 0 |; 0 &)
+% ( 0 <=>; 0 =>; 0 <=)
+% ( 0 <~>; 0 ~|; 0 ~&)
+% Number of predicates : 3 ( 3 propositional; 0-0 arity)
+% Number of functors : 0 ( 0 constant; --- arity)
+% Number of variables : 0 ( 0 singleton; 0 !; 0 ?)
+% Maximal term depth : 0 ( 0 average)
+% SPC :
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Some axioms to include
+fof(ia1,axiom,
+ ia1).
+
+fof(ia2,axiom,
+ ia2).
+
+fof(ia3,axiom,
+ ia3).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/Axioms/SYN000-0.ax b/tests/parsing/Axioms/SYN000-0.ax
new file mode 100644
index 000000000..ded5b5c1b
--- /dev/null
+++ b/tests/parsing/Axioms/SYN000-0.ax
@@ -0,0 +1,34 @@
+%------------------------------------------------------------------------------
+% File : SYN000-0 : TPTP v6.4.0. Released v3.6.0.
+% Domain : Syntactic
+% Axioms : A simple include file for CNF
+% Version : Biased.
+% English :
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Syntax : Number of clauses : 3 ( 0 non-Horn; 3 unit; 3 RR)
+% Number of atoms : 3 ( 0 equality)
+% Maximal clause size : 1 ( 1 average)
+% Number of predicates : 3 ( 3 propositional; 0-0 arity)
+% Number of functors : 0 ( 0 constant; --- arity)
+% Number of variables : 0 ( 0 singleton)
+% Maximal term depth : 0 ( 0 average)
+% SPC :
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Some axioms to include
+cnf(ia1,axiom,
+ ia1).
+
+cnf(ia2,axiom,
+ ia2).
+
+cnf(ia3,axiom,
+ ia3).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/Axioms/SYN000^0.ax b/tests/parsing/Axioms/SYN000^0.ax
new file mode 100644
index 000000000..a0ff404ce
--- /dev/null
+++ b/tests/parsing/Axioms/SYN000^0.ax
@@ -0,0 +1,46 @@
+%------------------------------------------------------------------------------
+% File : SYN000^0 : TPTP v6.4.0. Released v3.7.0.
+% Domain : Syntactic
+% Axioms : A simple include file for THF
+% Version : Biased.
+% English :
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Syntax : Number of formulae : 6 ( 6 unit; 3 type; 0 defn)
+% Number of atoms : 6 ( 0 equality; 0 variable)
+% Maximal formula depth : 2 ( 2 average)
+% Number of connectives : 0 ( 0 ~; 0 |; 0 &; 0 @)
+% ( 0 <=>; 0 =>; 0 <=; 0 <~>)
+% ( 0 ~|; 0 ~&; 0 !!; 0 ??)
+% Number of type conns : 0 ( 0 >; 0 *; 0 +)
+% Number of symbols : 4 ( 3 :; 0 :=)
+% Number of variables : 0 ( 0 sgn; 0 !; 0 ?; 0 ^)
+% ( 0 :; 0 :=; 0 !>; 0 ?*)
+% SPC :
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Some axioms to include
+thf(ia1_type,type,(
+ ia1: $o )).
+
+thf(ia2_type,type,(
+ ia2: $o )).
+
+thf(ia3_type,type,(
+ ia3: $o )).
+
+thf(ia1,axiom,(
+ ia1 )).
+
+thf(ia2,axiom,(
+ ia2 )).
+
+thf(ia3,axiom,(
+ ia3 )).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/Axioms/SYN000_0.ax b/tests/parsing/Axioms/SYN000_0.ax
new file mode 100644
index 000000000..b976fbbc8
--- /dev/null
+++ b/tests/parsing/Axioms/SYN000_0.ax
@@ -0,0 +1,47 @@
+%------------------------------------------------------------------------------
+% File : SYN000_0 : TPTP v6.4.0. Released v5.0.0.
+% Domain : Syntactic
+% Axioms : A simple include file for TFF
+% Version : Biased.
+% English :
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Syntax : Number of formulae : 6 ( 6 unit; 3 type)
+% Number of atoms : 6 ( 0 equality)
+% Maximal formula depth : 2 ( 2 average)
+% Number of connectives : 0 ( 0 ~; 0 |; 0 &)
+% ( 0 <=>; 0 =>; 0 <=; 0 <~>)
+% ( 0 ~|; 0 ~&)
+% Number of type conns : 0 ( 0 >; 0 *; 0 +; 0 <<)
+% Number of predicates : 4 ( 4 propositional; 0-0 arity)
+% Number of functors : 0 ( 0 constant; --- arity)
+% Number of variables : 0 ( 0 sgn; 0 !; 0 ?)
+% Maximal term depth : 0 ( 0 average)
+% SPC :
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Some axioms to include
+tff(ia1_type,type,(
+ ia1: $o )).
+
+tff(ia2_type,type,(
+ ia2: $o )).
+
+tff(ia3_type,type,(
+ ia3: $o )).
+
+tff(ia1,axiom,(
+ ia1 )).
+
+tff(ia2,axiom,(
+ ia2 )).
+
+tff(ia3,axiom,(
+ ia3 )).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/Axioms/SYN001-0.ax b/tests/parsing/Axioms/SYN001-0.ax
new file mode 100644
index 000000000..d496094eb
--- /dev/null
+++ b/tests/parsing/Axioms/SYN001-0.ax
@@ -0,0 +1,1821 @@
+%--------------------------------------------------------------------------
+% File : SYN001-0 : TPTP v6.4.0. Released v1.0.0.
+% Domain : Syntactic (Random Prolog Theory)
+% Axioms : Synthetic domain theory for EBL
+% Version : [SE94] axioms : Especial.
+% English :
+
+% Refs : [SE94] Segre & Elkan (1994), A High-Performance Explanation-B
+% Source : [SE94]
+% Names :
+
+% Status : Satisfiable
+% Syntax : Number of clauses : 368 ( 0 non-Horn; 38 unit; 361 RR)
+% Number of atoms : 1059 ( 0 equality)
+% Maximal clause size : 5 ( 3 average)
+% Number of predicates : 48 ( 0 propositional; 1-3 arity)
+% Number of functors : 5 ( 5 constant; 0-0 arity)
+% Number of variables : 626 ( 160 singleton)
+% Maximal term depth : 1 ( 1 average)
+% SPC :
+
+% Comments : This theory has a finite deductive closure.
+%--------------------------------------------------------------------------
+%----Facts
+cnf(axiom_1,axiom,
+ ( s0(d) )).
+
+cnf(axiom_2,axiom,
+ ( q0(e,d) )).
+
+cnf(axiom_3,axiom,
+ ( n0(d,e) )).
+
+cnf(axiom_4,axiom,
+ ( m0(e,d,a) )).
+
+cnf(axiom_5,axiom,
+ ( s0(b) )).
+
+cnf(axiom_6,axiom,
+ ( q0(b,b) )).
+
+cnf(axiom_7,axiom,
+ ( n0(d,b) )).
+
+cnf(axiom_8,axiom,
+ ( m0(e,d,e) )).
+
+cnf(axiom_9,axiom,
+ ( r0(b) )).
+
+cnf(axiom_10,axiom,
+ ( p0(b,d) )).
+
+cnf(axiom_11,axiom,
+ ( n0(e,b) )).
+
+cnf(axiom_12,axiom,
+ ( m0(a,X,a) )).
+
+cnf(axiom_13,axiom,
+ ( r0(e) )).
+
+cnf(axiom_14,axiom,
+ ( p0(b,X) )).
+
+cnf(axiom_15,axiom,
+ ( n0(a,b) )).
+
+cnf(axiom_16,axiom,
+ ( m0(c,b,a) )).
+
+cnf(axiom_17,axiom,
+ ( q0(X,d) )).
+
+cnf(axiom_18,axiom,
+ ( p0(c,b) )).
+
+cnf(axiom_19,axiom,
+ ( m0(X,d,Y) )).
+
+cnf(axiom_20,axiom,
+ ( l0(a) )).
+
+cnf(axiom_21,axiom,
+ ( q0(b,e) )).
+
+cnf(axiom_22,axiom,
+ ( p0(b,c) )).
+
+cnf(axiom_23,axiom,
+ ( m0(a,e,e) )).
+
+cnf(axiom_24,axiom,
+ ( l0(c) )).
+
+cnf(axiom_25,axiom,
+ ( q0(d,d) )).
+
+cnf(axiom_26,axiom,
+ ( n0(d,c) )).
+
+cnf(axiom_27,axiom,
+ ( m0(e,b,c) )).
+
+cnf(axiom_28,axiom,
+ ( k0(e) )).
+
+cnf(axiom_29,axiom,
+ ( q0(d,b) )).
+
+cnf(axiom_30,axiom,
+ ( n0(e,e) )).
+
+cnf(axiom_31,axiom,
+ ( m0(b,b,e) )).
+
+cnf(axiom_32,axiom,
+ ( k0(b) )).
+
+cnf(axiom_33,axiom,
+ ( q0(d,c) )).
+
+cnf(axiom_34,axiom,
+ ( n0(c,d) )).
+
+cnf(axiom_35,axiom,
+ ( m0(d,e,c) )).
+
+cnf(axiom_36,axiom,
+ ( q0(a,b) )).
+
+cnf(axiom_37,axiom,
+ ( n0(b,a) )).
+
+cnf(axiom_38,axiom,
+ ( m0(b,a,a) )).
+
+%----Rules
+cnf(rule_001,axiom,
+ ( k1(I)
+ | ~ n0(J,I) )).
+
+cnf(rule_002,axiom,
+ ( l1(G,G)
+ | ~ n0(H,G) )).
+
+cnf(rule_003,axiom,
+ ( l1(C,D)
+ | ~ p0(E,C)
+ | ~ r0(F)
+ | ~ m0(D,C,E) )).
+
+cnf(rule_004,axiom,
+ ( l1(A,A)
+ | ~ k1(A)
+ | ~ l0(B)
+ | ~ l1(B,B) )).
+
+cnf(rule_005,axiom,
+ ( m1(B,C,B)
+ | ~ m0(C,C,B) )).
+
+cnf(rule_006,axiom,
+ ( m1(J,J,J)
+ | ~ m0(A,A,J) )).
+
+cnf(rule_007,axiom,
+ ( m1(G,H,G)
+ | ~ p0(I,H)
+ | ~ r0(G) )).
+
+cnf(rule_008,axiom,
+ ( m1(b,b,b)
+ | ~ l0(b) )).
+
+cnf(rule_009,axiom,
+ ( m1(D,D,D)
+ | ~ s0(E)
+ | ~ r0(E)
+ | ~ q0(F,D) )).
+
+cnf(rule_010,axiom,
+ ( m1(B,B,c)
+ | ~ n0(C,C)
+ | ~ l1(c,c)
+ | ~ p0(C,B) )).
+
+cnf(rule_011,axiom,
+ ( m1(J,J,A)
+ | ~ k0(J)
+ | ~ n0(A,A) )).
+
+cnf(rule_012,axiom,
+ ( m1(e,e,e)
+ | ~ r0(e) )).
+
+cnf(rule_013,axiom,
+ ( m1(H,H,H)
+ | ~ q0(I,H) )).
+
+cnf(rule_014,axiom,
+ ( m1(E,E,E)
+ | ~ m0(F,G,E) )).
+
+cnf(rule_015,axiom,
+ ( m1(B,C,C)
+ | ~ l0(D)
+ | ~ m0(C,C,B) )).
+
+cnf(rule_016,axiom,
+ ( m1(H,I,I)
+ | ~ m1(J,I,H)
+ | ~ m1(J,A,I) )).
+
+cnf(rule_017,axiom,
+ ( m1(F,F,F)
+ | ~ s0(F)
+ | ~ q0(G,d) )).
+
+cnf(rule_018,axiom,
+ ( m1(C,C,C)
+ | ~ q0(D,E)
+ | ~ q0(D,C) )).
+
+cnf(rule_019,axiom,
+ ( m1(A,B,c)
+ | ~ r0(c)
+ | ~ s0(d)
+ | ~ q0(B,d)
+ | ~ p0(A,B) )).
+
+cnf(rule_020,axiom,
+ ( m1(c,c,c)
+ | ~ l0(c) )).
+
+cnf(rule_021,axiom,
+ ( m1(I,J,I)
+ | ~ l0(I)
+ | ~ k0(J) )).
+
+cnf(rule_022,axiom,
+ ( m1(e,e,e)
+ | ~ s0(e) )).
+
+cnf(rule_023,axiom,
+ ( m1(a,a,a)
+ | ~ l0(a)
+ | ~ s0(d) )).
+
+cnf(rule_024,axiom,
+ ( m1(F,a,G)
+ | ~ m0(a,H,a)
+ | ~ q0(F,G)
+ | ~ m1(G,c,G) )).
+
+cnf(rule_025,axiom,
+ ( m1(C,C,C)
+ | ~ m0(D,E,C) )).
+
+cnf(rule_026,axiom,
+ ( m1(A,A,A)
+ | ~ l0(A)
+ | ~ l0(B)
+ | ~ p0(B,d) )).
+
+cnf(rule_027,axiom,
+ ( m1(b,b,b)
+ | ~ q0(c,d)
+ | ~ l1(a,b) )).
+
+cnf(rule_028,axiom,
+ ( m1(J,J,J)
+ | ~ l0(J)
+ | ~ k0(J)
+ | ~ m0(J,J,J) )).
+
+cnf(rule_029,axiom,
+ ( m1(H,I,H)
+ | ~ p0(H,I)
+ | ~ s0(H) )).
+
+cnf(rule_030,axiom,
+ ( m1(e,e,e)
+ | ~ r0(e) )).
+
+cnf(rule_031,axiom,
+ ( m1(c,a,c)
+ | ~ r0(e)
+ | ~ m0(a,e,c)
+ | ~ r0(G)
+ | ~ k0(e) )).
+
+cnf(rule_032,axiom,
+ ( m1(F,F,F)
+ | ~ s0(F) )).
+
+cnf(rule_033,axiom,
+ ( m1(C,C,C)
+ | ~ q0(D,D)
+ | ~ m1(E,D,C) )).
+
+cnf(rule_034,axiom,
+ ( m1(A,B,B)
+ | ~ k1(a)
+ | ~ k1(B)
+ | ~ q0(A,A) )).
+
+cnf(rule_035,axiom,
+ ( m1(I,J,I)
+ | ~ r0(I)
+ | ~ l0(J) )).
+
+cnf(rule_036,axiom,
+ ( n1(A,A,B)
+ | ~ m0(b,B,A) )).
+
+cnf(rule_037,axiom,
+ ( n1(H,I,H)
+ | ~ p0(J,H)
+ | ~ l0(I)
+ | ~ r0(H) )).
+
+cnf(rule_038,axiom,
+ ( n1(G,G,G)
+ | ~ n0(G,G)
+ | ~ q0(a,G) )).
+
+cnf(rule_039,axiom,
+ ( n1(E,c,E)
+ | ~ m0(F,E,c) )).
+
+cnf(rule_040,axiom,
+ ( n1(C,e,e)
+ | ~ m0(C,D,e)
+ | ~ k1(C) )).
+
+cnf(rule_041,axiom,
+ ( n1(e,e,B)
+ | ~ s0(b)
+ | ~ m1(b,B,e) )).
+
+cnf(rule_042,axiom,
+ ( n1(H,H,H)
+ | ~ m0(I,J,I)
+ | ~ k0(H)
+ | ~ q0(A,J) )).
+
+cnf(rule_043,axiom,
+ ( n1(G,G,G)
+ | ~ k1(G)
+ | ~ p0(G,G) )).
+
+cnf(rule_044,axiom,
+ ( n1(D,E,D)
+ | ~ p0(D,D)
+ | ~ p0(E,F) )).
+
+cnf(rule_045,axiom,
+ ( n1(d,d,d)
+ | ~ q0(d,d) )).
+
+cnf(rule_046,axiom,
+ ( n1(A,A,A)
+ | ~ m1(B,C,A)
+ | ~ k0(B) )).
+
+cnf(rule_047,axiom,
+ ( n1(I,d,J)
+ | ~ p0(J,J)
+ | ~ r0(I)
+ | ~ l1(J,d) )).
+
+cnf(rule_048,axiom,
+ ( n1(F,F,F)
+ | ~ m0(G,H,H)
+ | ~ m0(H,F,G)
+ | ~ n1(F,F,F) )).
+
+cnf(rule_049,axiom,
+ ( n1(c,c,c)
+ | ~ l0(c) )).
+
+cnf(rule_050,axiom,
+ ( n1(D,E,D)
+ | ~ s0(b)
+ | ~ l0(D)
+ | ~ p0(b,E) )).
+
+cnf(rule_051,axiom,
+ ( n1(B,B,B)
+ | ~ m1(c,B,C)
+ | ~ m0(b,C,c)
+ | ~ n1(C,B,C) )).
+
+cnf(rule_052,axiom,
+ ( n1(I,I,I)
+ | ~ m0(J,J,J)
+ | ~ k1(I)
+ | ~ s0(I)
+ | ~ p0(A,J) )).
+
+cnf(rule_053,axiom,
+ ( n1(a,H,b)
+ | ~ p0(H,d)
+ | ~ p0(a,b) )).
+
+cnf(rule_054,axiom,
+ ( n1(E,F,F)
+ | ~ l0(G)
+ | ~ l1(G,E)
+ | ~ n1(E,F,E) )).
+
+cnf(rule_055,axiom,
+ ( n1(d,e,e)
+ | ~ p0(d,d)
+ | ~ n1(e,e,e)
+ | ~ r0(b) )).
+
+cnf(rule_056,axiom,
+ ( n1(a,a,a)
+ | ~ l0(a)
+ | ~ r0(a) )).
+
+cnf(rule_057,axiom,
+ ( n1(D,D,D)
+ | ~ r0(D) )).
+
+cnf(rule_058,axiom,
+ ( n1(B,B,B)
+ | ~ l1(C,B)
+ | ~ n0(C,B) )).
+
+cnf(rule_059,axiom,
+ ( n1(H,H,I)
+ | ~ m0(J,A,A)
+ | ~ m0(I,J,H) )).
+
+cnf(rule_060,axiom,
+ ( n1(d,d,b)
+ | ~ q0(b,e)
+ | ~ m1(d,e,e)
+ | ~ k0(b) )).
+
+cnf(rule_061,axiom,
+ ( n1(G,G,G)
+ | ~ k0(G)
+ | ~ s0(G) )).
+
+cnf(rule_062,axiom,
+ ( n1(D,D,D)
+ | ~ m0(E,E,F)
+ | ~ n1(E,D,E) )).
+
+cnf(rule_063,axiom,
+ ( p1(D,D,E)
+ | ~ n0(d,D)
+ | ~ k0(E) )).
+
+cnf(rule_064,axiom,
+ ( p1(A,A,A)
+ | ~ m0(B,C,b)
+ | ~ l0(A) )).
+
+cnf(rule_065,axiom,
+ ( p1(I,I,I)
+ | ~ l1(J,J)
+ | ~ p0(I,J)
+ | ~ n0(J,J) )).
+
+cnf(rule_066,axiom,
+ ( p1(G,G,G)
+ | ~ n0(H,G) )).
+
+cnf(rule_067,axiom,
+ ( p1(E,E,E)
+ | ~ q0(F,E) )).
+
+cnf(rule_068,axiom,
+ ( p1(D,D,D)
+ | ~ k0(D) )).
+
+cnf(rule_069,axiom,
+ ( p1(B,B,C)
+ | ~ p0(C,B) )).
+
+cnf(rule_070,axiom,
+ ( p1(c,c,c)
+ | ~ p0(a,c) )).
+
+cnf(rule_071,axiom,
+ ( p1(H,I,H)
+ | ~ l0(J)
+ | ~ p1(I,A,H)
+ | ~ s0(b) )).
+
+cnf(rule_072,axiom,
+ ( p1(F,F,F)
+ | ~ s0(G)
+ | ~ s0(F) )).
+
+cnf(rule_073,axiom,
+ ( p1(D,D,D)
+ | ~ n0(e,b)
+ | ~ k0(b)
+ | ~ k0(D)
+ | ~ k1(E) )).
+
+cnf(rule_074,axiom,
+ ( p1(B,B,C)
+ | ~ p0(C,B)
+ | ~ r0(B) )).
+
+cnf(rule_075,axiom,
+ ( p1(a,a,a)
+ | ~ p0(b,a) )).
+
+cnf(rule_076,axiom,
+ ( p1(b,b,b)
+ | ~ p1(b,b,b)
+ | ~ s0(d) )).
+
+cnf(rule_077,axiom,
+ ( p1(c,e,b)
+ | ~ m0(b,c,e) )).
+
+cnf(rule_078,axiom,
+ ( p1(d,d,b)
+ | ~ p0(d,b)
+ | ~ m0(e,a,a) )).
+
+cnf(rule_079,axiom,
+ ( p1(A,A,A)
+ | ~ k0(e)
+ | ~ k1(A)
+ | ~ l0(c) )).
+
+cnf(rule_080,axiom,
+ ( p1(G,G,G)
+ | ~ n0(H,H)
+ | ~ l0(I)
+ | ~ n1(H,J,G) )).
+
+cnf(rule_081,axiom,
+ ( p1(B,B,B)
+ | ~ m1(C,D,B)
+ | ~ q0(D,E)
+ | ~ l0(F) )).
+
+cnf(rule_082,axiom,
+ ( p1(H,I,J)
+ | ~ m0(J,H,A)
+ | ~ p1(J,H,A) )).
+
+cnf(rule_083,axiom,
+ ( p1(F,b,G)
+ | ~ m1(F,G,b)
+ | ~ k0(G) )).
+
+cnf(rule_084,axiom,
+ ( p1(D,D,D)
+ | ~ m0(b,E,b)
+ | ~ l1(D,b) )).
+
+cnf(rule_085,axiom,
+ ( p1(B,B,B)
+ | ~ p0(C,B) )).
+
+cnf(rule_086,axiom,
+ ( p1(I,I,I)
+ | ~ l0(I)
+ | ~ m0(J,A,I) )).
+
+cnf(rule_087,axiom,
+ ( p1(a,b,a)
+ | ~ r0(b)
+ | ~ p1(a,a,a) )).
+
+cnf(rule_088,axiom,
+ ( p1(a,a,a)
+ | ~ l0(a) )).
+
+cnf(rule_089,axiom,
+ ( p1(d,d,H)
+ | ~ s0(H)
+ | ~ n1(c,d,H)
+ | ~ r0(d)
+ | ~ n0(c,H) )).
+
+cnf(rule_090,axiom,
+ ( p1(e,e,e)
+ | ~ r0(e)
+ | ~ k0(e) )).
+
+cnf(rule_091,axiom,
+ ( p1(C,C,C)
+ | ~ q0(D,E)
+ | ~ k1(F)
+ | ~ n1(D,C,G) )).
+
+cnf(rule_092,axiom,
+ ( q1(J,A,J)
+ | ~ n0(B,A)
+ | ~ p0(C,J) )).
+
+cnf(rule_093,axiom,
+ ( q1(H,H,H)
+ | ~ q0(I,H) )).
+
+cnf(rule_094,axiom,
+ ( q1(b,e,e)
+ | ~ s0(e)
+ | ~ k0(b)
+ | ~ l0(c) )).
+
+cnf(rule_095,axiom,
+ ( q1(F,G,G)
+ | ~ p0(G,F) )).
+
+cnf(rule_096,axiom,
+ ( q1(B,B,B)
+ | ~ n1(C,D,D)
+ | ~ p0(C,E)
+ | ~ m1(B,D,C)
+ | ~ q1(E,C,D) )).
+
+cnf(rule_097,axiom,
+ ( q1(A,A,A)
+ | ~ s0(A) )).
+
+cnf(rule_098,axiom,
+ ( q1(H,H,H)
+ | ~ s0(H)
+ | ~ m0(I,I,J) )).
+
+cnf(rule_099,axiom,
+ ( q1(E,F,F)
+ | ~ k0(G)
+ | ~ l0(E)
+ | ~ q1(F,F,G) )).
+
+cnf(rule_100,axiom,
+ ( q1(C,C,C)
+ | ~ n0(D,C) )).
+
+cnf(rule_101,axiom,
+ ( q1(B,B,B)
+ | ~ k1(B)
+ | ~ q0(B,b)
+ | ~ p1(b,b,B) )).
+
+cnf(rule_102,axiom,
+ ( q1(J,J,J)
+ | ~ k0(J)
+ | ~ l0(A) )).
+
+cnf(rule_103,axiom,
+ ( q1(I,I,I)
+ | ~ m0(I,c,b) )).
+
+cnf(rule_104,axiom,
+ ( q1(E,F,E)
+ | ~ l0(E)
+ | ~ r0(G)
+ | ~ p0(H,E)
+ | ~ q0(F,F) )).
+
+cnf(rule_105,axiom,
+ ( q1(C,C,D)
+ | ~ s0(C)
+ | ~ p0(D,d) )).
+
+cnf(rule_106,axiom,
+ ( q1(B,B,B)
+ | ~ s0(B) )).
+
+cnf(rule_107,axiom,
+ ( q1(e,A,A)
+ | ~ m0(A,d,A)
+ | ~ m0(e,d,A) )).
+
+cnf(rule_108,axiom,
+ ( q1(H,H,H)
+ | ~ p0(I,J)
+ | ~ p1(H,b,b)
+ | ~ q0(b,b) )).
+
+cnf(rule_109,axiom,
+ ( q1(E,E,F)
+ | ~ p0(G,G)
+ | ~ q0(F,E)
+ | ~ k1(E) )).
+
+cnf(rule_110,axiom,
+ ( q1(B,B,B)
+ | ~ m0(C,D,B) )).
+
+cnf(rule_111,axiom,
+ ( q1(d,d,c)
+ | ~ m0(c,b,a)
+ | ~ m1(c,d,a) )).
+
+cnf(rule_112,axiom,
+ ( q1(A,A,A)
+ | ~ k1(A)
+ | ~ s0(b) )).
+
+cnf(rule_113,axiom,
+ ( q1(H,H,I)
+ | ~ r0(J)
+ | ~ m1(H,I,I) )).
+
+cnf(rule_114,axiom,
+ ( q1(F,F,F)
+ | ~ m0(F,F,G)
+ | ~ k0(G) )).
+
+cnf(rule_115,axiom,
+ ( q1(b,b,b)
+ | ~ l0(b) )).
+
+cnf(rule_116,axiom,
+ ( q1(E,E,E)
+ | ~ r0(E) )).
+
+cnf(rule_117,axiom,
+ ( q1(d,d,d)
+ | ~ k0(e)
+ | ~ s0(d) )).
+
+cnf(rule_118,axiom,
+ ( q1(C,C,C)
+ | ~ p0(b,d)
+ | ~ s0(b)
+ | ~ n1(D,d,C) )).
+
+cnf(rule_119,axiom,
+ ( q1(B,b,b)
+ | ~ s0(B)
+ | ~ s0(b) )).
+
+cnf(rule_120,axiom,
+ ( q1(b,b,b)
+ | ~ r0(b) )).
+
+cnf(rule_121,axiom,
+ ( q1(I,I,I)
+ | ~ m0(J,A,I) )).
+
+cnf(rule_122,axiom,
+ ( q1(G,G,G)
+ | ~ m0(G,H,G) )).
+
+cnf(rule_123,axiom,
+ ( q1(F,F,F)
+ | ~ m0(c,F,F)
+ | ~ r0(F) )).
+
+cnf(rule_124,axiom,
+ ( r1(D)
+ | ~ q0(D,E)
+ | ~ s0(d)
+ | ~ q1(d,E,d) )).
+
+cnf(rule_125,axiom,
+ ( s1(I)
+ | ~ p0(I,I) )).
+
+cnf(rule_126,axiom,
+ ( s1(F)
+ | ~ q0(F,G)
+ | ~ s1(H) )).
+
+cnf(rule_127,axiom,
+ ( k2(C,D)
+ | ~ m1(E,D,C)
+ | ~ k1(F)
+ | ~ k2(F,D) )).
+
+cnf(rule_128,axiom,
+ ( k2(B,B)
+ | ~ n1(e,d,B)
+ | ~ m1(B,e,B)
+ | ~ q1(B,B,d) )).
+
+cnf(rule_129,axiom,
+ ( k2(J,J)
+ | ~ q1(A,J,J) )).
+
+cnf(rule_130,axiom,
+ ( k2(e,e)
+ | ~ l1(e,e) )).
+
+cnf(rule_131,axiom,
+ ( l2(D,E)
+ | ~ s1(D)
+ | ~ n0(e,E)
+ | ~ l2(E,E) )).
+
+cnf(rule_132,axiom,
+ ( l2(c,c)
+ | ~ l2(c,c)
+ | ~ l1(e,e) )).
+
+cnf(rule_133,axiom,
+ ( l2(J,J)
+ | ~ p0(A,A)
+ | ~ s1(B)
+ | ~ m0(C,B,J) )).
+
+cnf(rule_134,axiom,
+ ( l2(G,G)
+ | ~ m0(H,G,I)
+ | ~ m1(I,H,H)
+ | ~ p0(H,G) )).
+
+cnf(rule_135,axiom,
+ ( m2(F)
+ | ~ s0(F)
+ | ~ l1(G,H) )).
+
+cnf(rule_136,axiom,
+ ( m2(b)
+ | ~ k1(b) )).
+
+cnf(rule_137,axiom,
+ ( n2(A)
+ | ~ p1(B,C,A) )).
+
+cnf(rule_138,axiom,
+ ( n2(a)
+ | ~ m1(b,a,e)
+ | ~ k1(c)
+ | ~ n1(e,a,e)
+ | ~ q1(c,a,d) )).
+
+cnf(rule_139,axiom,
+ ( n2(c)
+ | ~ l1(e,c)
+ | ~ k0(b) )).
+
+cnf(rule_140,axiom,
+ ( n2(e)
+ | ~ r1(b)
+ | ~ r0(e)
+ | ~ p1(b,I,J) )).
+
+cnf(rule_141,axiom,
+ ( p2(B,a,B)
+ | ~ q1(B,a,B) )).
+
+cnf(rule_142,axiom,
+ ( p2(J,J,J)
+ | ~ k1(A)
+ | ~ k0(A)
+ | ~ l2(a,A)
+ | ~ k2(J,a) )).
+
+cnf(rule_143,axiom,
+ ( p2(c,e,e)
+ | ~ l1(c,b)
+ | ~ q1(e,e,e) )).
+
+cnf(rule_144,axiom,
+ ( p2(b,c,a)
+ | ~ r0(e)
+ | ~ n1(c,I,I)
+ | ~ p0(b,I)
+ | ~ k2(c,a) )).
+
+cnf(rule_145,axiom,
+ ( p2(e,G,H)
+ | ~ r0(e)
+ | ~ p1(G,H,e) )).
+
+cnf(rule_146,axiom,
+ ( p2(C,D,D)
+ | ~ p1(C,E,F)
+ | ~ l1(E,F)
+ | ~ p2(C,D,C) )).
+
+cnf(rule_147,axiom,
+ ( p2(e,c,c)
+ | ~ r1(d)
+ | ~ l1(e,c) )).
+
+cnf(rule_148,axiom,
+ ( p2(J,J,J)
+ | ~ m1(A,B,J)
+ | ~ p2(A,J,A) )).
+
+cnf(rule_149,axiom,
+ ( p2(H,H,d)
+ | ~ r1(a)
+ | ~ m0(I,H,d) )).
+
+cnf(rule_150,axiom,
+ ( p2(F,F,F)
+ | ~ m1(G,G,F) )).
+
+cnf(rule_151,axiom,
+ ( p2(d,d,d)
+ | ~ k1(d)
+ | ~ s0(d) )).
+
+cnf(rule_152,axiom,
+ ( p2(C,D,D)
+ | ~ n1(E,D,E)
+ | ~ p0(C,D)
+ | ~ p2(C,D,C) )).
+
+cnf(rule_153,axiom,
+ ( p2(B,B,B)
+ | ~ n1(d,d,B) )).
+
+cnf(rule_154,axiom,
+ ( p2(A,A,A)
+ | ~ q1(A,A,A) )).
+
+cnf(rule_155,axiom,
+ ( p2(H,I,I)
+ | ~ k1(J)
+ | ~ p2(e,H,I) )).
+
+cnf(rule_156,axiom,
+ ( p2(F,e,G)
+ | ~ n1(e,F,a)
+ | ~ q1(a,G,F) )).
+
+cnf(rule_157,axiom,
+ ( p2(E,E,E)
+ | ~ l1(E,d) )).
+
+cnf(rule_158,axiom,
+ ( p2(B,B,C)
+ | ~ q1(c,B,D)
+ | ~ s1(c)
+ | ~ s0(e)
+ | ~ p2(B,D,B) )).
+
+cnf(rule_159,axiom,
+ ( p2(A,A,A)
+ | ~ k1(A) )).
+
+cnf(rule_160,axiom,
+ ( p2(H,H,H)
+ | ~ m1(a,a,I)
+ | ~ p2(a,J,H) )).
+
+cnf(rule_161,axiom,
+ ( p2(d,b,b)
+ | ~ p1(d,b,e) )).
+
+cnf(rule_162,axiom,
+ ( p2(b,c,c)
+ | ~ p1(G,b,b)
+ | ~ n1(e,e,G)
+ | ~ q1(e,c,G) )).
+
+cnf(rule_163,axiom,
+ ( p2(E,E,E)
+ | ~ q1(F,c,F)
+ | ~ k2(E,c) )).
+
+cnf(rule_164,axiom,
+ ( p2(B,B,B)
+ | ~ p0(B,B)
+ | ~ r1(C)
+ | ~ p2(D,C,B) )).
+
+cnf(rule_165,axiom,
+ ( p2(I,I,I)
+ | ~ q1(J,A,J)
+ | ~ p2(J,J,A) )).
+
+cnf(rule_166,axiom,
+ ( p2(a,H,d)
+ | ~ n0(H,d)
+ | ~ m1(a,H,d) )).
+
+cnf(rule_167,axiom,
+ ( p2(G,G,G)
+ | ~ s1(G)
+ | ~ k1(G) )).
+
+cnf(rule_168,axiom,
+ ( p2(a,c,b)
+ | ~ l1(e,c)
+ | ~ l2(e,b)
+ | ~ r1(e)
+ | ~ m1(d,a,c) )).
+
+cnf(rule_169,axiom,
+ ( p2(D,D,D)
+ | ~ q1(E,E,E)
+ | ~ p1(D,F,D) )).
+
+cnf(rule_170,axiom,
+ ( p2(C,e,C)
+ | ~ n1(C,e,e) )).
+
+cnf(rule_171,axiom,
+ ( p2(A,A,A)
+ | ~ n1(B,B,B)
+ | ~ p0(A,A) )).
+
+cnf(rule_172,axiom,
+ ( p2(a,a,a)
+ | ~ p1(e,e,a) )).
+
+cnf(rule_173,axiom,
+ ( p2(I,I,I)
+ | ~ r1(J)
+ | ~ r0(I) )).
+
+cnf(rule_174,axiom,
+ ( p2(H,H,H)
+ | ~ n2(H)
+ | ~ k1(e) )).
+
+cnf(rule_175,axiom,
+ ( p2(F,F,F)
+ | ~ l1(G,F) )).
+
+cnf(rule_176,axiom,
+ ( p2(D,E,D)
+ | ~ m1(E,D,E) )).
+
+cnf(rule_177,axiom,
+ ( q2(E,F,F)
+ | ~ k0(F)
+ | ~ p1(E,E,E) )).
+
+cnf(rule_178,axiom,
+ ( q2(B,B,B)
+ | ~ q0(C,B)
+ | ~ n1(C,B,D) )).
+
+cnf(rule_179,axiom,
+ ( q2(J,J,J)
+ | ~ k1(A)
+ | ~ n1(J,J,A) )).
+
+cnf(rule_180,axiom,
+ ( q2(d,a,a)
+ | ~ q2(d,c,a)
+ | ~ s1(c)
+ | ~ q0(e,c) )).
+
+cnf(rule_181,axiom,
+ ( q2(I,I,I)
+ | ~ p1(I,I,I) )).
+
+cnf(rule_182,axiom,
+ ( q2(F,G,F)
+ | ~ p1(F,F,H)
+ | ~ n1(G,F,H)
+ | ~ q2(G,H,F) )).
+
+cnf(rule_183,axiom,
+ ( q2(D,c,E)
+ | ~ k1(E)
+ | ~ l0(c)
+ | ~ l2(E,D) )).
+
+cnf(rule_184,axiom,
+ ( q2(B,B,B)
+ | ~ q1(C,c,B) )).
+
+cnf(rule_185,axiom,
+ ( q2(I,I,I)
+ | ~ n1(J,d,A)
+ | ~ k1(I)
+ | ~ q2(A,A,J) )).
+
+cnf(rule_186,axiom,
+ ( q2(G,G,H)
+ | ~ l1(H,G) )).
+
+cnf(rule_187,axiom,
+ ( q2(C,D,C)
+ | ~ r1(D)
+ | ~ m0(E,F,C)
+ | ~ k0(D)
+ | ~ q2(D,D,D) )).
+
+cnf(rule_188,axiom,
+ ( r2(G)
+ | ~ r1(G)
+ | ~ l0(G) )).
+
+cnf(rule_189,axiom,
+ ( s2(H)
+ | ~ q2(b,H,b)
+ | ~ s1(b) )).
+
+cnf(rule_190,axiom,
+ ( s2(d)
+ | ~ s1(a)
+ | ~ s0(d) )).
+
+cnf(rule_191,axiom,
+ ( s2(d)
+ | ~ r1(d)
+ | ~ s1(d) )).
+
+cnf(rule_192,axiom,
+ ( k3(J,A,J)
+ | ~ s1(A)
+ | ~ p2(B,A,C)
+ | ~ n0(J,C) )).
+
+cnf(rule_193,axiom,
+ ( k3(H,H,H)
+ | ~ s1(H)
+ | ~ q2(d,I,d)
+ | ~ s2(I) )).
+
+cnf(rule_194,axiom,
+ ( k3(F,F,G)
+ | ~ k2(G,F) )).
+
+cnf(rule_195,axiom,
+ ( k3(c,c,c)
+ | ~ s2(e)
+ | ~ k2(c,e) )).
+
+cnf(rule_196,axiom,
+ ( k3(C,C,C)
+ | ~ p2(D,E,D)
+ | ~ m1(C,C,E) )).
+
+cnf(rule_197,axiom,
+ ( k3(A,A,A)
+ | ~ l2(B,b)
+ | ~ k1(A) )).
+
+cnf(rule_198,axiom,
+ ( k3(c,c,c)
+ | ~ k0(a)
+ | ~ r2(c) )).
+
+cnf(rule_199,axiom,
+ ( k3(I,J,J)
+ | ~ l1(J,I)
+ | ~ k3(I,J,J) )).
+
+cnf(rule_200,axiom,
+ ( k3(F,F,F)
+ | ~ p2(G,H,e)
+ | ~ s1(G)
+ | ~ k3(F,G,G) )).
+
+cnf(rule_201,axiom,
+ ( k3(B,B,C)
+ | ~ p1(C,D,B)
+ | ~ m2(E)
+ | ~ m2(D) )).
+
+cnf(rule_202,axiom,
+ ( k3(G,G,H)
+ | ~ q0(I,H)
+ | ~ k2(G,J)
+ | ~ k3(H,A,J) )).
+
+cnf(rule_203,axiom,
+ ( k3(d,d,d)
+ | ~ p1(a,d,b)
+ | ~ r2(a)
+ | ~ l2(e,b) )).
+
+cnf(rule_204,axiom,
+ ( k3(a,a,a)
+ | ~ r2(a) )).
+
+cnf(rule_205,axiom,
+ ( k3(E,E,E)
+ | ~ p2(F,E,E) )).
+
+cnf(rule_206,axiom,
+ ( k3(C,D,C)
+ | ~ p2(D,C,C) )).
+
+cnf(rule_207,axiom,
+ ( k3(J,J,J)
+ | ~ p0(A,J)
+ | ~ k3(J,J,J)
+ | ~ k3(A,J,B) )).
+
+cnf(rule_208,axiom,
+ ( k3(I,I,I)
+ | ~ r2(c)
+ | ~ l1(b,I) )).
+
+cnf(rule_209,axiom,
+ ( k3(E,E,E)
+ | ~ m2(F)
+ | ~ l1(G,H)
+ | ~ s2(E)
+ | ~ k3(G,H,G) )).
+
+cnf(rule_210,axiom,
+ ( k3(D,D,D)
+ | ~ n2(D) )).
+
+cnf(rule_211,axiom,
+ ( k3(C,C,C)
+ | ~ l0(C)
+ | ~ r2(e)
+ | ~ r0(e) )).
+
+cnf(rule_212,axiom,
+ ( k3(B,B,B)
+ | ~ m2(B) )).
+
+cnf(rule_213,axiom,
+ ( k3(I,I,I)
+ | ~ r1(I)
+ | ~ p2(J,A,A) )).
+
+cnf(rule_214,axiom,
+ ( k3(c,c,c)
+ | ~ r2(c) )).
+
+cnf(rule_215,axiom,
+ ( l3(G,H)
+ | ~ r0(G)
+ | ~ p2(G,H,G) )).
+
+cnf(rule_216,axiom,
+ ( l3(D,D)
+ | ~ p1(D,D,E)
+ | ~ p2(E,F,D) )).
+
+cnf(rule_217,axiom,
+ ( l3(C,C)
+ | ~ n2(C)
+ | ~ m2(b) )).
+
+cnf(rule_218,axiom,
+ ( l3(B,B)
+ | ~ r2(B) )).
+
+cnf(rule_219,axiom,
+ ( l3(I,I)
+ | ~ n2(J)
+ | ~ l1(A,I)
+ | ~ l3(A,A) )).
+
+cnf(rule_220,axiom,
+ ( l3(G,G)
+ | ~ s2(H)
+ | ~ l1(G,G) )).
+
+cnf(rule_221,axiom,
+ ( l3(d,d)
+ | ~ k2(a,d) )).
+
+cnf(rule_222,axiom,
+ ( l3(D,D)
+ | ~ k3(E,D,D)
+ | ~ l2(F,F) )).
+
+cnf(rule_223,axiom,
+ ( l3(c,c)
+ | ~ k2(b,c) )).
+
+cnf(rule_224,axiom,
+ ( l3(d,c)
+ | ~ s2(d)
+ | ~ k3(a,c,a)
+ | ~ r0(b) )).
+
+cnf(rule_225,axiom,
+ ( m3(J,A,J)
+ | ~ m0(B,B,A)
+ | ~ l2(C,J)
+ | ~ m0(J,C,C)
+ | ~ s2(B) )).
+
+cnf(rule_226,axiom,
+ ( m3(G,G,G)
+ | ~ k2(H,I)
+ | ~ m3(G,I,G)
+ | ~ n0(I,a)
+ | ~ l2(a,a) )).
+
+cnf(rule_227,axiom,
+ ( m3(C,C,C)
+ | ~ q0(D,E)
+ | ~ s0(F)
+ | ~ s2(E)
+ | ~ r2(C) )).
+
+cnf(rule_228,axiom,
+ ( m3(J,A,A)
+ | ~ n2(J)
+ | ~ m2(A)
+ | ~ m3(B,J,B) )).
+
+cnf(rule_229,axiom,
+ ( m3(b,b,b)
+ | ~ q2(a,b,a) )).
+
+cnf(rule_230,axiom,
+ ( m3(c,b,d)
+ | ~ l1(d,b)
+ | ~ m2(d)
+ | ~ q2(b,c,d) )).
+
+cnf(rule_231,axiom,
+ ( m3(H,I,H)
+ | ~ r2(H)
+ | ~ k2(c,I) )).
+
+cnf(rule_232,axiom,
+ ( m3(G,G,G)
+ | ~ l2(G,G)
+ | ~ n2(G) )).
+
+cnf(rule_233,axiom,
+ ( m3(E,E,E)
+ | ~ n2(E)
+ | ~ m2(F) )).
+
+cnf(rule_234,axiom,
+ ( m3(D,e,e)
+ | ~ n2(e)
+ | ~ p2(D,e,e) )).
+
+cnf(rule_235,axiom,
+ ( m3(B,B,C)
+ | ~ r2(C)
+ | ~ k3(B,C,B) )).
+
+cnf(rule_236,axiom,
+ ( m3(A,A,A)
+ | ~ n2(A) )).
+
+cnf(rule_237,axiom,
+ ( m3(J,c,J)
+ | ~ s2(c)
+ | ~ q2(J,c,c) )).
+
+cnf(rule_238,axiom,
+ ( m3(I,I,I)
+ | ~ p2(I,I,I) )).
+
+cnf(rule_239,axiom,
+ ( m3(b,b,b)
+ | ~ l2(a,b) )).
+
+cnf(rule_240,axiom,
+ ( n3(D)
+ | ~ p2(E,F,D) )).
+
+cnf(rule_241,axiom,
+ ( p3(C,D,E)
+ | ~ q2(F,d,C)
+ | ~ k2(D,E) )).
+
+cnf(rule_242,axiom,
+ ( p3(J,A,B)
+ | ~ r2(A)
+ | ~ k3(A,B,J) )).
+
+cnf(rule_243,axiom,
+ ( p3(I,d,e)
+ | ~ l3(b,e)
+ | ~ p2(d,b,c)
+ | ~ n3(I)
+ | ~ q2(I,d,I) )).
+
+cnf(rule_244,axiom,
+ ( p3(H,H,H)
+ | ~ n2(H) )).
+
+cnf(rule_245,axiom,
+ ( p3(E,E,E)
+ | ~ l1(F,F)
+ | ~ l3(F,E)
+ | ~ p3(G,G,F) )).
+
+cnf(rule_246,axiom,
+ ( p3(D,D,D)
+ | ~ l2(D,D) )).
+
+cnf(rule_247,axiom,
+ ( p3(A,A,A)
+ | ~ n2(A)
+ | ~ q2(B,C,A)
+ | ~ s1(B) )).
+
+cnf(rule_248,axiom,
+ ( p3(I,I,I)
+ | ~ p2(J,I,I)
+ | ~ n3(I) )).
+
+cnf(rule_249,axiom,
+ ( p3(H,H,H)
+ | ~ k1(H)
+ | ~ n2(H) )).
+
+cnf(rule_250,axiom,
+ ( p3(E,E,E)
+ | ~ k1(E)
+ | ~ q2(F,G,E) )).
+
+cnf(rule_251,axiom,
+ ( p3(A,B,B)
+ | ~ m3(B,C,D)
+ | ~ p2(A,B,D) )).
+
+cnf(rule_252,axiom,
+ ( p3(H,H,H)
+ | ~ q0(I,H)
+ | ~ k2(J,J) )).
+
+cnf(rule_253,axiom,
+ ( p3(b,c,b)
+ | ~ k2(c,b) )).
+
+cnf(rule_254,axiom,
+ ( p3(e,b,e)
+ | ~ m3(e,G,e)
+ | ~ q2(G,G,b) )).
+
+cnf(rule_255,axiom,
+ ( q3(G,H)
+ | ~ q2(I,G,H)
+ | ~ n0(I,G) )).
+
+cnf(rule_256,axiom,
+ ( q3(E,E)
+ | ~ p2(F,E,E)
+ | ~ q3(F,E) )).
+
+cnf(rule_257,axiom,
+ ( q3(B,C)
+ | ~ n1(D,B,C)
+ | ~ s2(B)
+ | ~ q3(C,B) )).
+
+cnf(rule_258,axiom,
+ ( q3(I,I)
+ | ~ r2(I)
+ | ~ s1(J)
+ | ~ l2(A,A) )).
+
+cnf(rule_259,axiom,
+ ( q3(G,G)
+ | ~ m0(H,d,H)
+ | ~ k1(G)
+ | ~ r2(d)
+ | ~ q3(H,G) )).
+
+cnf(rule_260,axiom,
+ ( r3(G,H,H)
+ | ~ s2(H)
+ | ~ l2(c,G) )).
+
+cnf(rule_261,axiom,
+ ( r3(D,D,D)
+ | ~ l1(E,F)
+ | ~ n1(F,F,F)
+ | ~ r2(D) )).
+
+cnf(rule_262,axiom,
+ ( r3(A,A,A)
+ | ~ p1(B,C,A)
+ | ~ l2(C,B)
+ | ~ r3(A,B,A) )).
+
+cnf(rule_263,axiom,
+ ( r3(I,I,I)
+ | ~ m0(d,J,I)
+ | ~ r3(I,I,J) )).
+
+cnf(rule_264,axiom,
+ ( r3(H,H,H)
+ | ~ s2(H) )).
+
+cnf(rule_265,axiom,
+ ( r3(F,F,F)
+ | ~ l2(G,F) )).
+
+cnf(rule_266,axiom,
+ ( r3(E,E,E)
+ | ~ r2(E) )).
+
+cnf(rule_267,axiom,
+ ( r3(B,C,B)
+ | ~ p2(B,D,C) )).
+
+cnf(rule_268,axiom,
+ ( r3(H,H,I)
+ | ~ m2(I)
+ | ~ m3(J,b,H)
+ | ~ r3(I,A,A) )).
+
+cnf(rule_269,axiom,
+ ( r3(a,a,e)
+ | ~ k2(a,a)
+ | ~ q2(G,e,G)
+ | ~ m2(b)
+ | ~ m3(a,G,G) )).
+
+cnf(rule_270,axiom,
+ ( r3(F,b,F)
+ | ~ r0(F)
+ | ~ p2(b,F,b)
+ | ~ l2(F,F) )).
+
+cnf(rule_271,axiom,
+ ( r3(C,C,C)
+ | ~ p3(D,C,E)
+ | ~ r3(D,D,D) )).
+
+cnf(rule_272,axiom,
+ ( r3(J,A,B)
+ | ~ k2(A,B)
+ | ~ r2(B)
+ | ~ r3(B,J,J) )).
+
+cnf(rule_273,axiom,
+ ( s3(I,J)
+ | ~ q2(A,I,A)
+ | ~ s2(I)
+ | ~ m0(A,B,J) )).
+
+cnf(rule_274,axiom,
+ ( k4(c)
+ | ~ n0(c,d)
+ | ~ q3(e,b)
+ | ~ n3(e) )).
+
+cnf(rule_275,axiom,
+ ( k4(E)
+ | ~ k3(F,F,F)
+ | ~ n0(G,F)
+ | ~ k4(E) )).
+
+cnf(rule_276,axiom,
+ ( k4(e)
+ | ~ q3(C,C)
+ | ~ q1(a,a,D)
+ | ~ r3(C,e,D) )).
+
+cnf(rule_277,axiom,
+ ( l4(J)
+ | ~ p3(A,B,J) )).
+
+cnf(rule_278,axiom,
+ ( l4(H)
+ | ~ m0(I,H,H)
+ | ~ l4(I) )).
+
+cnf(rule_279,axiom,
+ ( m4(E,F)
+ | ~ l2(G,F)
+ | ~ s3(a,E) )).
+
+cnf(rule_280,axiom,
+ ( m4(C,C)
+ | ~ p3(D,D,D)
+ | ~ m3(C,C,D)
+ | ~ m4(C,C) )).
+
+cnf(rule_281,axiom,
+ ( n4(J,A)
+ | ~ p3(J,A,A)
+ | ~ n4(J,J) )).
+
+cnf(rule_282,axiom,
+ ( n4(d,d)
+ | ~ k3(c,c,e)
+ | ~ q1(d,d,d) )).
+
+cnf(rule_283,axiom,
+ ( n4(e,e)
+ | ~ l3(b,a)
+ | ~ p3(b,e,a) )).
+
+cnf(rule_284,axiom,
+ ( n4(H,H)
+ | ~ k4(I)
+ | ~ m3(H,H,H) )).
+
+cnf(rule_285,axiom,
+ ( p4(G,G,H)
+ | ~ r0(G)
+ | ~ r3(H,G,H) )).
+
+cnf(rule_286,axiom,
+ ( p4(D,D,D)
+ | ~ q3(E,F)
+ | ~ n3(D) )).
+
+cnf(rule_287,axiom,
+ ( p4(B,C,B)
+ | ~ k3(B,B,C) )).
+
+cnf(rule_288,axiom,
+ ( p4(H,I,I)
+ | ~ r3(I,I,H)
+ | ~ p4(J,J,A) )).
+
+cnf(rule_289,axiom,
+ ( p4(D,D,D)
+ | ~ l4(D)
+ | ~ n0(D,E)
+ | ~ p4(F,G,F) )).
+
+cnf(rule_290,axiom,
+ ( p4(A,A,A)
+ | ~ m3(B,C,A)
+ | ~ p4(A,C,A) )).
+
+cnf(rule_291,axiom,
+ ( p4(I,I,I)
+ | ~ p3(J,J,I) )).
+
+cnf(rule_292,axiom,
+ ( p4(F,F,F)
+ | ~ k3(G,H,H)
+ | ~ n4(F,H)
+ | ~ p1(H,G,F) )).
+
+cnf(rule_293,axiom,
+ ( p4(C,C,C)
+ | ~ q3(D,E)
+ | ~ n4(E,C)
+ | ~ l3(D,D) )).
+
+cnf(rule_294,axiom,
+ ( p4(c,c,B)
+ | ~ n3(a)
+ | ~ m3(B,c,a) )).
+
+cnf(rule_295,axiom,
+ ( q4(B,C)
+ | ~ k3(D,D,B)
+ | ~ q2(E,C,B)
+ | ~ m3(E,F,E) )).
+
+cnf(rule_296,axiom,
+ ( q4(I,I)
+ | ~ r1(I)
+ | ~ l4(J)
+ | ~ q4(J,A) )).
+
+cnf(rule_297,axiom,
+ ( q4(b,b)
+ | ~ k3(c,e,b)
+ | ~ l1(b,c) )).
+
+cnf(rule_298,axiom,
+ ( r4(G)
+ | ~ n3(G)
+ | ~ q3(H,I)
+ | ~ p0(J,G) )).
+
+cnf(rule_299,axiom,
+ ( s4(A)
+ | ~ p3(B,C,D)
+ | ~ l1(A,C) )).
+
+cnf(rule_300,axiom,
+ ( k5(E)
+ | ~ s4(F)
+ | ~ r3(G,E,E) )).
+
+cnf(rule_301,axiom,
+ ( k5(b)
+ | ~ s4(e)
+ | ~ n1(b,b,b) )).
+
+cnf(rule_302,axiom,
+ ( l5(H)
+ | ~ q4(I,I)
+ | ~ k1(H) )).
+
+cnf(rule_303,axiom,
+ ( m5(D,E)
+ | ~ r0(D)
+ | ~ p4(D,F,E) )).
+
+cnf(rule_304,axiom,
+ ( m5(C,C)
+ | ~ k4(C) )).
+
+cnf(rule_305,axiom,
+ ( m5(B,B)
+ | ~ s4(B)
+ | ~ m4(e,e) )).
+
+cnf(rule_306,axiom,
+ ( m5(J,J)
+ | ~ s4(A)
+ | ~ r0(J) )).
+
+cnf(rule_307,axiom,
+ ( n5(B,C)
+ | ~ q4(D,E)
+ | ~ n4(B,E)
+ | ~ p4(F,F,C)
+ | ~ n5(F,C) )).
+
+cnf(rule_308,axiom,
+ ( n5(J,J)
+ | ~ m0(A,J,A)
+ | ~ n5(A,J) )).
+
+cnf(rule_309,axiom,
+ ( n5(H,H)
+ | ~ n4(I,H) )).
+
+cnf(rule_310,axiom,
+ ( n5(E,E)
+ | ~ p0(E,F)
+ | ~ m4(G,G)
+ | ~ k5(d) )).
+
+cnf(rule_311,axiom,
+ ( n5(d,d)
+ | ~ p4(c,d,c) )).
+
+cnf(rule_312,axiom,
+ ( n5(b,e)
+ | ~ r3(d,b,c)
+ | ~ n4(b,e) )).
+
+cnf(rule_313,axiom,
+ ( n5(C,C)
+ | ~ q4(D,C) )).
+
+cnf(rule_314,axiom,
+ ( n5(B,B)
+ | ~ r4(B) )).
+
+cnf(rule_315,axiom,
+ ( n5(A,A)
+ | ~ s1(A)
+ | ~ k4(A) )).
+
+cnf(rule_316,axiom,
+ ( n5(H,H)
+ | ~ p4(I,H,H)
+ | ~ s1(H)
+ | ~ p4(b,b,J) )).
+
+cnf(rule_317,axiom,
+ ( n5(d,G)
+ | ~ k3(d,G,a)
+ | ~ n4(G,d) )).
+
+cnf(rule_318,axiom,
+ ( p5(E,E,F)
+ | ~ s4(F)
+ | ~ l2(E,E) )).
+
+cnf(rule_319,axiom,
+ ( p5(B,C,C)
+ | ~ l2(B,D)
+ | ~ p5(B,D,B)
+ | ~ m4(D,C) )).
+
+cnf(rule_320,axiom,
+ ( p5(I,J,I)
+ | ~ q4(J,A)
+ | ~ s1(I) )).
+
+cnf(rule_321,axiom,
+ ( p5(b,b,b)
+ | ~ p4(G,G,H)
+ | ~ k5(b) )).
+
+cnf(rule_322,axiom,
+ ( q5(J,A)
+ | ~ s4(J)
+ | ~ m2(A) )).
+
+cnf(rule_323,axiom,
+ ( q5(a,a)
+ | ~ r4(a) )).
+
+cnf(rule_324,axiom,
+ ( q5(I,I)
+ | ~ l4(I) )).
+
+cnf(rule_325,axiom,
+ ( q5(H,H)
+ | ~ q4(H,H) )).
+
+cnf(rule_326,axiom,
+ ( q5(G,G)
+ | ~ m4(G,G) )).
+
+cnf(rule_327,axiom,
+ ( r5(C,D)
+ | ~ s4(C)
+ | ~ k0(b)
+ | ~ n3(D) )).
+
+cnf(rule_328,axiom,
+ ( r5(B,B)
+ | ~ k4(B) )).
+
+cnf(rule_329,axiom,
+ ( s5(H)
+ | ~ l4(H)
+ | ~ r4(I) )).
+
+cnf(rule_330,axiom,
+ ( s5(E)
+ | ~ k4(E)
+ | ~ s3(E,F)
+ | ~ l5(G)
+ | ~ s5(G) )).
+
+%--------------------------------------------------------------------------
diff --git a/tests/parsing/Axioms/SYN002+0.ax b/tests/parsing/Axioms/SYN002+0.ax
new file mode 100644
index 000000000..584f8e7bc
--- /dev/null
+++ b/tests/parsing/Axioms/SYN002+0.ax
@@ -0,0 +1,37 @@
+%------------------------------------------------------------------------------
+% File : SYN002+0 : TPTP v6.4.0. Released v3.6.0.
+% Domain : Syntactic
+% Axioms : Orevkov formula
+% Version : [TS00] axioms : Especial.
+% English : r(x,y,z)=y+2^x=z
+
+% Refs : [TS00] Troelska & Schwichtenberg (2000), Basic Proof Theory
+% : [Rat08] Raths (2008), Email to G. Sutcliffe
+% Source : [Rat08]
+% Names :
+
+% Status : Satisfiable
+% Syntax : Number of formulae : 2 ( 1 unit)
+% Number of atoms : 4 ( 0 equality)
+% Maximal formula depth : 7 ( 4 average)
+% Number of connectives : 2 ( 0 ~ ; 0 |; 0 &)
+% ( 0 <=>; 2 =>; 0 <=)
+% ( 0 <~>; 0 ~|; 0 ~&)
+% Number of predicates : 1 ( 0 propositional; 3-3 arity)
+% Number of functors : 2 ( 1 constant; 0-1 arity)
+% Number of variables : 5 ( 0 singleton; 5 !; 0 ?)
+% Maximal term depth : 2 ( 1 average)
+% SPC :
+
+% Comments :
+%------------------------------------------------------------------------------
+fof(hyp1,axiom,(
+ ! [Y] : r(Y,zero,succ(Y)) )).
+
+fof(hyp2,axiom,(
+ ! [Y,X,Z,Z1] :
+ ( r(Y,X,Z)
+ => ( r(Z,X,Z1)
+ => r(Y,succ(X),Z1) ) ) )).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/Makefile b/tests/parsing/Makefile
new file mode 100644
index 000000000..00160b8e3
--- /dev/null
+++ b/tests/parsing/Makefile
@@ -0,0 +1,15 @@
+
+BIN=../witan.exe
+TESTS=$(patsubst %.p,%.res,$(wildcard *.p))
+
+all: $(TESTS)
+
+%.res: %.p $(BIN)
+ @if ! $(BIN) --type-only $< > /dev/null; then \
+ /bin/echo -e "\e[31m[KO]\e[0m [parsing] $<"; \
+ exit 1; \
+ else \
+ /bin/echo -e "\e[32m[OK]\e[0m [parsing] $<"; \
+ fi
+
+clean:
diff --git a/tests/parsing/SYN000+1.p b/tests/parsing/SYN000+1.p
new file mode 100644
index 000000000..91bd5fac0
--- /dev/null
+++ b/tests/parsing/SYN000+1.p
@@ -0,0 +1,99 @@
+%------------------------------------------------------------------------------
+% File : SYN000+1 : TPTP v6.1.0. Released v4.0.0.
+% Domain : Syntactic
+% Problem : Basic TPTP FOF syntax
+% Version : Biased.
+% English : Basic TPTP FOF syntax that you can't survive without parsing.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Theorem
+% Rating : 0.28 v6.1.0, 0.33 v6.0.0, 0.43 v5.5.0, 0.48 v5.4.0, 0.46 v5.3.0, 0.52 v5.2.0, 0.40 v5.1.0, 0.43 v5.0.0, 0.54 v4.1.0, 0.57 v4.0.1, 0.78 v4.0.0
+% Syntax : Number of formulae : 12 ( 5 unit)
+% Number of atoms : 31 ( 3 equality)
+% Maximal formula depth : 7 ( 4 average)
+% Number of connectives : 28 ( 9 ~; 10 |; 3 &)
+% ( 1 <=>; 3 =>; 1 <=)
+% ( 1 <~>; 0 ~|; 0 ~&)
+% Number of predicates : 16 ( 10 propositional; 0-3 arity)
+% Number of functors : 8 ( 5 constant; 0-3 arity)
+% Number of variables : 13 ( 0 sgn; 5 !; 8 ?)
+% Maximal term depth : 4 ( 2 average)
+% SPC : FOF_THM_RFO_SEQ
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Propositional
+fof(propositional,axiom,
+ ( ( p0
+ & ~ q0 )
+ => ( r0
+ | ~ s0 ) )).
+
+%----First-order
+fof(first_order,axiom,(
+ ! [X] :
+ ( ( p(X)
+ | ~ q(X,a) )
+ => ? [Y,Z] :
+ ( r(X,f(Y),g(X,f(Y),Z))
+ & ~ s(f(f(f(b)))) ) ) )).
+
+%----Equality
+fof(equality,axiom,(
+ ? [Y] :
+ ! [X,Z] :
+ ( f(Y) = g(X,f(Y),Z)
+ | f(f(f(b))) != a
+ | X = f(Y) ) )).
+
+%----True and false
+fof(true_false,axiom,
+ ( $true
+ | $false )).
+
+%----Quoted symbols
+fof(single_quoted,axiom,
+ ( 'A proposition'
+ | 'A predicate'(a)
+ | p('A constant')
+ | p('A function'(a))
+ | p('A \'quoted \\ escape\'') )).
+
+%----Connectives - seen |, &, =>, ~ already
+fof(useful_connectives,axiom,(
+ ! [X] :
+ ( ( p(X)
+ <= ~ q(X,a) )
+ <=> ? [Y,Z] :
+ ( r(X,f(Y),g(X,f(Y),Z))
+ <~> ~ s(f(f(f(b)))) ) ) )).
+
+%----Annotated formula names
+fof(123,axiom,(
+ ! [X] :
+ ( ( p(X)
+ | ~ q(X,a) )
+ => ? [Y,Z] :
+ ( r(X,f(Y),g(X,f(Y),Z))
+ & ~ s(f(f(f(b)))) ) ) )).
+
+%----Roles
+fof(role_hypothesis,hypothesis,(
+ p(h) )).
+
+fof(role_conjecture,conjecture,(
+ ? [X] : p(X) )).
+
+%----Include directive
+include('Axioms/SYN000+0.ax').
+
+%----Comments
+/* This
+ is a block
+ comment.
+*/
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000+2.p b/tests/parsing/SYN000+2.p
new file mode 100644
index 000000000..c3c513dd1
--- /dev/null
+++ b/tests/parsing/SYN000+2.p
@@ -0,0 +1,127 @@
+%------------------------------------------------------------------------------
+% File : SYN000+2 : TPTP v6.1.0. Bugfixed v4.1.1.
+% Domain : Syntactic
+% Problem : Advanced TPTP FOF syntax
+% Version : Biased.
+% English : Advanced TPTP FOF syntax that you will encounter some time.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Rating : 0.50 v6.1.0, 0.40 v6.0.0, 0.50 v5.5.0, 0.67 v5.2.0, 1.00 v5.0.0
+% Syntax : Number of formulae : 20 ( 16 unit)
+% Number of atoms : 31 ( 2 equality)
+% Maximal formula depth : 7 ( 2 average)
+% Number of connectives : 13 ( 2 ~; 9 |; 0 &)
+% ( 0 <=>; 0 =>; 0 <=; 0 <~>)
+% ( 1 ~|; 1 ~&)
+% Number of predicates : 8 ( 3 propositional; 0-3 arity)
+% Number of functors : 22 ( 20 constant; 0-3 arity)
+% Number of variables : 8 ( 0 sgn; 8 !; 0 ?)
+% Maximal term depth : 2 ( 1 average)
+% Arithmetic symbols : 12 ( 0 pred; 0 func; 12 numbers)
+% SPC : FOF_SAT_RFO_SEQ
+
+% Comments :
+% Bugfixes : v4.0.1 - Added more numbers, particularly rationals.
+% : v4.1.1 - Removed rationals with negative denominators.
+%------------------------------------------------------------------------------
+%----Quoted symbols
+fof(distinct_object,axiom,(
+ "An Apple" != "A \"Microsoft \\ escape\"" )).
+
+%----Numbers
+fof(integers,axiom,
+ ( p(12)
+ | p(-12) )).
+
+fof(rationals,axiom,
+ ( p(123/456)
+ | p(-123/456)
+ | p(+123/456) )).
+
+fof(reals,axiom,
+ ( p(123.456 )
+ | p(-123.456 )
+ | p(123.456E789 )
+ | p(123.456e789 )
+ | p(-123.456E789 )
+ | p(123.456E-789 )
+ | p(-123.456E-789 ) )).
+
+%----Connectives - seen |, &, =>, ~ already
+fof(never_used_connectives,axiom,(
+ ! [X] :
+ ( ( p(X)
+ ~| ~ q(X,a) )
+ ~& p(X) ) )).
+
+%----Roles
+fof(role_definition,definition,(
+ ! [X] : f(d) = f(X) )).
+
+fof(role_assumption,assumption,(
+ p(a) )).
+
+fof(role_lemma,lemma,(
+ p(l) )).
+
+fof(role_theorem,theorem,(
+ p(t) )).
+
+fof(role_unknown,unknown,(
+ p(u) )).
+
+%----Selective include directive
+include('Axioms/SYN000+0.ax',[ia1,ia3]).
+
+%----Source
+fof(source_unknown,axiom,(
+ ! [X] : p(X) ),
+ unknown).
+
+fof(source,axiom,(
+ ! [X] : p(X) ),
+ file('SYN000-1.p')).
+
+fof(source_name,axiom,(
+ ! [X] : p(X) ),
+ file('SYN000-1.p',source_unknown)).
+
+fof(source_copy,axiom,(
+ ! [X] : p(X) ),
+ source_unknown).
+
+fof(source_introduced_assumption,axiom,(
+ ! [X] : p(X) ),
+ introduced(assumption,[from,the,world])).
+
+fof(source_inference,axiom,(
+ p(a) ),
+ inference(magic,
+ [status(thm),assumptions([source_introduced_assumption])],
+ [theory(equality),source_unknown])).
+
+fof(source_inference_with_bind,axiom,(
+ p(a) ),
+ inference(magic,
+ [status(thm)],
+ [theory(equality),source_unknown:[bind(X,$fot(a))]])).
+
+%----Useful info
+fof(useful_info,axiom,(
+ ! [X] : p(X) ),
+ unknown,
+ [simple,
+ prolog(like,Data,[nested,12.2]),
+ AVariable,
+ 12.2,
+ "A distinct object",
+ $fof(p(X) | ~ q(X,a) | r(X,f(Y),g(X,f(Y),Z)) | ~ s(f(f(f(b))))),
+ data(name):[colon,list,2],
+ [simple,prolog(like,Data,[nested,12.2]),AVariable,12.2]
+ ]).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000-1.p b/tests/parsing/SYN000-1.p
new file mode 100644
index 000000000..350233282
--- /dev/null
+++ b/tests/parsing/SYN000-1.p
@@ -0,0 +1,83 @@
+%------------------------------------------------------------------------------
+% File : SYN000-1 : TPTP v6.1.0. Released v4.0.0.
+% Domain : Syntactic
+% Problem : Basic TPTP CNF syntax
+% Version : Biased.
+% English : Basic TPTP CNF syntax that you can't survive without parsing.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Unsatisfiable
+% Rating : 0.40 v6.1.0, 0.36 v6.0.0, 0.50 v5.4.0, 0.55 v5.3.0, 0.56 v5.2.0, 0.62 v5.1.0, 0.65 v5.0.0, 0.64 v4.1.0, 0.62 v4.0.1, 0.64 v4.0.0
+% Syntax : Number of clauses : 11 ( 6 non-Horn; 5 unit; 7 RR)
+% Number of atoms : 27 ( 3 equality)
+% Maximal clause size : 5 ( 2 average)
+% Number of predicates : 16 ( 10 propositional; 0-3 arity)
+% Number of functors : 8 ( 5 constant; 0-3 arity)
+% Number of variables : 11 ( 5 singleton)
+% Maximal term depth : 4 ( 2 average)
+% SPC : CNF_UNS_RFO_SEQ_NHN
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Propositional
+cnf(propositional,axiom,
+ ( p0
+ | ~ q0
+ | r0
+ | ~ s0 )).
+
+%----First-order
+cnf(first_order,axiom,
+ ( p(X)
+ | ~ q(X,a)
+ | r(X,f(Y),g(X,f(Y),Z))
+ | ~ s(f(f(f(b)))) )).
+
+%----Equality
+cnf(equality,axiom,
+ ( f(Y) = g(X,f(Y),Z)
+ | f(f(f(b))) != a
+ | X = f(Y) )).
+
+%----True and false
+cnf(true_false,axiom,
+ ( $true
+ | $false )).
+
+%----Quoted symbols
+cnf(single_quoted,axiom,
+ ( 'A proposition'
+ | 'A predicate'(Y)
+ | p('A constant')
+ | p('A function'(a))
+ | p('A \'quoted \\ escape\'') )).
+
+%----Connectives - seen them all already
+
+%----Annotated formula names
+cnf(123,axiom,
+ ( p(X)
+ | ~ q(X,a)
+ | r(X,f(Y),g(X,f(Y),Z))
+ | ~ s(f(f(f(b)))) )).
+
+%----Roles - seen axiom already
+cnf(role_hypothesis,hypothesis,
+ p(h)).
+
+cnf(role_negated_conjecture,negated_conjecture,
+ ~ p(X)).
+
+%----Include directive
+include('Axioms/SYN000-0.ax').
+
+%----Comments
+/* This
+ is a block
+ comment.
+*/
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000-2.p b/tests/parsing/SYN000-2.p
new file mode 100644
index 000000000..488c11a0b
--- /dev/null
+++ b/tests/parsing/SYN000-2.p
@@ -0,0 +1,117 @@
+%------------------------------------------------------------------------------
+% File : SYN000-2 : TPTP v6.1.0. Bugfixed v4.1.1.
+% Domain : Syntactic
+% Problem : Advanced TPTP CNF syntax
+% Version : Biased.
+% English : Advanced TPTP CNF syntax that you will encounter some time.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Rating : 0.70 v6.1.0, 0.78 v6.0.0, 1.00 v5.4.0, 0.90 v5.3.0, 0.89 v5.2.0, 0.90 v5.0.0
+% Syntax : Number of clauses : 19 ( 3 non-Horn; 16 unit; 12 RR)
+% Number of atoms : 28 ( 2 equality)
+% Maximal clause size : 7 ( 1 average)
+% Number of predicates : 8 ( 3 propositional; 0-3 arity)
+% Number of functors : 22 ( 20 constant; 0-3 arity)
+% Number of variables : 7 ( 7 singleton)
+% Maximal term depth : 2 ( 1 average)
+% Arithmetic symbols : 12 ( 0 pred; 0 func; 12 numbers)
+% SPC : CNF_SAT_RFO_EQU_NUE
+
+% Comments :
+% Bugfixes : v4.0.1 - Added more numbers, particularly rationals.
+% : v4.1.1 - Removed rationals with negative denominators.
+%------------------------------------------------------------------------------
+%----Quoted symbols
+cnf(distinct_object,axiom,
+ ( "An Apple" != "A \"Microsoft \\ escape\"" )).
+
+%----Numbers
+cnf(integers,axiom,
+ ( p(12)
+ | p(-12) )).
+
+cnf(rationals,axiom,
+ ( p(123/456)
+ | p(-123/456)
+ | p(+123/456) )).
+
+cnf(reals,axiom,
+ ( p(123.456 )
+ | p(-123.456 )
+ | p(123.456E789 )
+ | p(123.456e789 )
+ | p(-123.456E789 )
+ | p(123.456E-789 )
+ | p(-123.456E-789 ) )).
+
+%----Roles - seen axiom already
+cnf(role_definition,definition,
+ f(d) = f(X) ).
+
+cnf(role_assumption,assumption,
+ p(a) ).
+
+cnf(role_lemma,lemma,
+ p(l) ).
+
+cnf(role_theorem,theorem,
+ p(t) ).
+
+cnf(role_unknown,unknown,
+ p(u) ).
+
+%----Selective include directive
+include('Axioms/SYN000-0.ax',[ia1,ia3]).
+
+%----Source
+cnf(source_unknown,axiom,
+ p(X),
+ unknown).
+
+cnf(source,axiom,
+ p(X),
+ file('SYN000-1.p')).
+
+cnf(source_name,axiom,
+ p(X),
+ file('SYN000-1.p',source_unknown)).
+
+cnf(source_copy,axiom,
+ p(X),
+ source_unknown).
+
+cnf(source_introduced_assumption,axiom,
+ p(X),
+ introduced(assumption,[from,the,world])).
+
+cnf(source_inference,axiom,
+ p(a),
+ inference(magic,
+ [status(thm),assumptions([source_introduced_assumption])],
+ [theory(equality),source_unknown]) ).
+
+cnf(source_inference_with_bind,axiom,
+ p(a),
+ inference(magic,
+ [status(thm)],
+ [theory(equality),source_unknown:[bind(X,$fot(a))]]) ).
+
+%----Useful info
+cnf(useful_info,axiom,
+ p(X),
+ unknown,
+ [simple,
+ prolog(like,Data,[nested,12.2]),
+ AVariable,
+ 12.2,
+ "A distinct object",
+ $cnf(p(X) | ~q(X,a) | r(X,f(Y),g(X,f(Y),Z)) | ~ s(f(f(f(b))))),
+ data(name):[colon,list,2],
+ [simple,prolog(like,Data,[nested,12.2]),AVariable,12.2]
+ ]).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000=2.p b/tests/parsing/SYN000=2.p
new file mode 100644
index 000000000..13bc52534
--- /dev/null
+++ b/tests/parsing/SYN000=2.p
@@ -0,0 +1,309 @@
+%------------------------------------------------------------------------------
+% File : SYN000=2 : TPTP v6.1.0. Bugfixed v5.5.1.
+% Domain : Syntactic
+% Problem : TF0 syntax with arithmetic
+% Version : Biased.
+% English :
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Theorem
+% Rating : 1.00 v6.0.0
+% Syntax : Number of formulae : 83 ( 73 unit; 6 type)
+% Number of atoms : 100 ( 4 equality)
+% Maximal formula depth : 7 ( 1 average)
+% Number of connectives : 14 ( 0 ~; 10 |; 1 &)
+% ( 0 <=>; 3 =>; 0 <=; 0 <~>)
+% ( 0 ~|; 0 ~&)
+% Number of type conns : 3 ( 3 >; 0 *; 0 +; 0 <<)
+% Number of predicates : 20 ( 10 propositional; 0-2 arity)
+% Number of functors : 41 ( 24 constant; 0-2 arity)
+% Number of variables : 14 ( 1 sgn; 3 !; 11 ?)
+% Maximal term depth : 3 ( 1 average)
+% Arithmetic symbols : 37 ( 9 pred; 7 func; 21 numbers)
+% SPC : TF0_THM_EQU_ARI
+
+% Comments :
+% Bugfixes : v5.5.1 - Removed $evaleq.
+%------------------------------------------------------------------------------
+%----Types for what follows
+tff(p_int_type,type,(
+ p_int: $int > $o )).
+
+tff(p_rat_type,type,(
+ p_rat: $rat > $o )).
+
+tff(p_real_type,type,(
+ p_real: $real > $o )).
+
+tff(a_int,type,(
+ a_int: $int )).
+
+tff(a_rat,type,(
+ a_rat: $rat )).
+
+tff(a_real,type,(
+ a_real: $real )).
+
+%----Numbers
+tff(integers,axiom,
+ ( p_int(123)
+ | p_int(-123) )).
+
+tff(rationals,axiom,
+ ( p_rat(123/456)
+ | p_rat(-123/456)
+ | p_rat(123/456) )).
+
+tff(reals,axiom,
+ ( p_real(123.456)
+ | p_real(-123.456)
+ | p_real(123.456E78)
+ | p_real(123.456e78)
+ | p_real(-123.456E78)
+ | p_real(123.456E-78)
+ | p_real(-123.456E-78) )).
+
+%----Variables
+tff(variables_int,axiom,(
+ ! [X: $int] :
+ ? [Y: $int] :
+ ( p_int(X)
+ => p_int(Y) ) )).
+
+tff(variables_rat,axiom,(
+ ! [X: $rat] :
+ ? [Y: $rat] :
+ ( p_rat(X)
+ => p_rat(Y) ) )).
+
+tff(variables_real,axiom,(
+ ! [X: $real] :
+ ? [Y: $real] :
+ ( p_real(X)
+ => p_real(Y) ) )).
+
+%----Arithmetic relations
+tff(less_int,axiom,(
+ $less(a_int,3) )).
+
+tff(less_rat,axiom,(
+ $less(a_rat,3/9) )).
+
+tff(less_real,axiom,(
+ $less(a_real,3.3) )).
+
+tff(lesseq_int,axiom,(
+ $lesseq(a_int,3) )).
+
+tff(lesseq_rat,axiom,(
+ $lesseq(a_rat,3/9) )).
+
+tff(lesseq_real,axiom,(
+ $lesseq(a_real,3.3) )).
+
+tff(greater_int,axiom,(
+ $greater(a_int,-3) )).
+
+tff(greater_rat,axiom,(
+ $greater(a_rat,-3/9) )).
+
+tff(greater_real,axiom,(
+ $greater(a_real,-3.3) )).
+
+tff(greatereq_int,axiom,(
+ $greatereq(a_int,-3) )).
+
+tff(greatereq_rat,axiom,(
+ $greatereq(a_rat,-3/9) )).
+
+tff(greatereq_real,axiom,(
+ $greatereq(a_real,-3.3) )).
+
+tff(equal_int,axiom,(
+ a_int = 0 )).
+
+tff(equal_rat,axiom,(
+ a_rat = 0/1 )).
+
+tff(equal_real,axiom,(
+ a_real = 0.0 )).
+
+%----Arithmetic functions
+tff(uminus_int,axiom,(
+ p_int($uminus(3)) )).
+
+tff(uminus_rat,axiom,(
+ p_rat($uminus(3/9)) )).
+
+tff(uminus_real,axiom,(
+ p_real($uminus(3.3)) )).
+
+tff(sum_int,axiom,(
+ p_int($sum(3,3)) )).
+
+tff(sum_rat,axiom,(
+ p_rat($sum(3/9,3/9)) )).
+
+tff(sum_real,axiom,(
+ p_real($sum(3.3,3.3)) )).
+
+tff(difference_int,axiom,(
+ p_int($difference(3,3)) )).
+
+tff(difference_rat,axiom,(
+ p_rat($difference(3/9,3/9)) )).
+
+tff(difference_real,axiom,(
+ p_real($difference(3.3,3.3)) )).
+
+tff(product_int,axiom,(
+ p_int($product(3,3)) )).
+
+tff(product_rat,axiom,(
+ p_rat($product(3/9,3/9)) )).
+
+tff(product_real,axiom,(
+ p_real($product(3.3,3.3)) )).
+
+tff(quotient_rat,axiom,(
+ p_rat($quotient(3/9,3/9)) )).
+
+tff(quotient_real,axiom,(
+ p_real($quotient(3.3,3.3)) )).
+
+tff(quotient_e_int,axiom,(
+ p_int($quotient_e(3,3)) )).
+
+tff(quotient_e_rat,axiom,(
+ p_rat($quotient_e(3/9,3/9)) )).
+
+tff(quotient_e_real,axiom,(
+ p_real($quotient_e(3.3,3.3)) )).
+
+tff(quotient_t_int,axiom,(
+ p_int($quotient_t(3,3)) )).
+
+tff(quotient_t_rat,axiom,(
+ p_rat($quotient_t(3/9,3/9)) )).
+
+tff(quotient_t_real,axiom,(
+ p_real($quotient_t(3.3,3.3)) )).
+
+tff(quotient_f_int,axiom,(
+ p_int($quotient_f(3,3)) )).
+
+tff(quotient_f_rat,axiom,(
+ p_rat($quotient_f(3/9,3/9)) )).
+
+tff(quotient_f_real,axiom,(
+ p_real($quotient_f(3.3,3.3)) )).
+
+tff(remainder_e_int,axiom,(
+ p_int($remainder_e(3,3)) )).
+
+tff(remainder_e_rat,axiom,(
+ p_rat($remainder_e(3/9,3/9)) )).
+
+tff(remainder_e_real,axiom,(
+ p_real($remainder_e(3.3,3.3)) )).
+
+tff(remainder_t_int,axiom,(
+ p_int($remainder_t(3,3)) )).
+
+tff(remainder_t_rat,axiom,(
+ p_rat($remainder_t(3/9,3/9)) )).
+
+tff(remainder_t_real,axiom,(
+ p_real($remainder_t(3.3,3.3)) )).
+
+tff(remainder_f_int,axiom,(
+ p_int($remainder_f(3,3)) )).
+
+tff(remainder_f_rat,axiom,(
+ p_rat($remainder_f(3/9,3/9)) )).
+
+tff(remainder_f_real,axiom,(
+ p_real($remainder_f(3.3,3.3)) )).
+
+tff(floor_int,axiom,(
+ p_int($floor(3)) )).
+
+tff(floor_rat,axiom,(
+ p_rat($floor(3/9)) )).
+
+tff(floor_int,axiom,(
+ p_real($floor(3.3)) )).
+
+tff(ceiling_int,axiom,(
+ p_int($ceiling(3)) )).
+
+tff(ceiling_rat,axiom,(
+ p_rat($ceiling(3/9)) )).
+
+tff(ceiling_int,axiom,(
+ p_real($ceiling(3.3)) )).
+
+tff(truncate_int,axiom,(
+ p_int($truncate(3)) )).
+
+tff(truncate_rat,axiom,(
+ p_rat($truncate(3/9)) )).
+
+tff(truncate_int,axiom,(
+ p_real($truncate(3.3)) )).
+
+%----Recognizing numbers
+tff(is_int_int,axiom,(
+ ? [X: $int] : $is_int(X) )).
+
+tff(is_int_rat,axiom,(
+ ? [X: $rat] : $is_int(X) )).
+
+tff(is_int_real,axiom,(
+ ? [X: $real] : $is_int(X) )).
+
+tff(is_rat_rat,axiom,(
+ ? [X: $rat] : $is_rat(X) )).
+
+tff(is_rat_real,axiom,(
+ ? [X: $real] : $is_rat(X) )).
+
+%----Coercion
+tff(to_int_int,axiom,(
+ p_int($to_int(3)) )).
+
+tff(to_int_rat,axiom,(
+ p_int($to_int(3/9)) )).
+
+tff(to_int_real,axiom,(
+ p_int($to_int(3.3)) )).
+
+tff(to_rat_int,axiom,(
+ p_rat($to_rat(3)) )).
+
+tff(to_rat_rat,axiom,(
+ p_rat($to_rat(3/9)) )).
+
+tff(to_rat_real,axiom,(
+ p_rat($to_rat(3.3)) )).
+
+tff(to_real_int,axiom,(
+ p_real($to_real(3)) )).
+
+tff(to_real_rat,axiom,(
+ p_real($to_real(3/9)) )).
+
+tff(to_real_real,axiom,(
+ p_real($to_real(3.3)) )).
+
+%----A conjecture to prove
+tff(mixed,conjecture,(
+ ? [X: $int,Y: $rat,Z: $real] :
+ ( Y = $to_rat($sum(X,2))
+ & ( $less($to_int(Y),3)
+ | $greater($to_real(Y),3.3) ) ) )).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000^1.p b/tests/parsing/SYN000^1.p
new file mode 100644
index 000000000..32221893f
--- /dev/null
+++ b/tests/parsing/SYN000^1.p
@@ -0,0 +1,192 @@
+%------------------------------------------------------------------------------
+% File : SYN000^1 : TPTP v6.1.0. Released v3.7.0.
+% Domain : Syntactic
+% Problem : Basic TPTP
+% Version : Biased.
+% English : Basic TPTP that you can't survive without parsing.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Theorem
+% Rating : 0.57 v6.1.0, 0.29 v6.0.0, 0.43 v5.5.0, 0.50 v5.4.0, 0.60 v5.1.0, 0.20 v4.1.0, 0.00 v3.7.0
+% Syntax : Number of formulae : 42 ( 18 unit; 27 type; 0 defn)
+% Number of atoms : 161 ( 4 equality; 32 variable)
+% Maximal formula depth : 11 ( 4 average)
+% Number of connectives : 96 ( 9 ~; 10 |; 3 &; 68 @)
+% ( 1 <=>; 3 =>; 1 <=; 1 <~>)
+% ( 0 ~|; 0 ~&; 0 !!; 0 ??)
+% Number of type conns : 26 ( 26 >; 0 *; 0 +; 0 <<)
+% Number of symbols : 33 ( 27 :)
+% Number of variables : 18 ( 1 sgn; 6 !; 8 ?; 4 ^)
+% ( 18 :; 0 !>; 0 ?*)
+% ( 0 @-; 0 @+)
+% SPC : TH0_THM_EQU
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Propositional
+thf(p0_type,type,(
+ p0: $o )).
+
+thf(q0_type,type,(
+ q0: $o )).
+
+thf(r0_type,type,(
+ r0: $o )).
+
+thf(s0_type,type,(
+ s0: $o )).
+
+thf(propositional,axiom,
+ ( ( p0
+ & ~ ( q0 ) )
+ => ( r0
+ | ~ ( s0 ) ) )).
+
+%----First-order
+thf(a_type,type,(
+ a: $i )).
+
+thf(b_type,type,(
+ b: $i )).
+
+thf(h_type,type,(
+ h: $i )).
+
+thf(f_type,type,(
+ f: $i > $i )).
+
+thf(g_type,type,(
+ g: $i > $i > $i > $i )).
+
+thf(p_type,type,(
+ p: $i > $o )).
+
+thf(q_type,type,(
+ q: $i > $i > $o )).
+
+thf(r_type,type,(
+ r: $i > $i > $i > $o )).
+
+thf(s_type,type,(
+ s: $i > $o )).
+
+thf(first_order,axiom,(
+ ! [X: $i] :
+ ( ( ( p @ X )
+ | ~ ( q @ X @ a ) )
+ => ? [Y: $i,Z: $i] :
+ ( ( r @ X @ ( f @ Y ) @ ( g @ X @ ( f @ Y ) @ Z ) )
+ & ~ ( s @ ( f @ ( f @ ( f @ b ) ) ) ) ) ) )).
+
+%----Equality
+thf(equality,axiom,(
+ ? [Y: $i] :
+ ! [X: $i,Z: $i] :
+ ( ( ( f @ Y )
+ = ( g @ X @ ( f @ Y ) @ Z ) )
+ | ( ( f @ ( f @ ( f @ b ) ) )
+ != a )
+ | ( X
+ = ( f @ Y ) ) ) )).
+
+%----True and false
+thf(true_false,axiom,
+ ( $true
+ | $false )).
+
+thf(quoted_proposition_type,type,(
+ 'A proposition': $o )).
+
+thf(quoted_predicate_type,type,(
+ 'A predicate': $i > $o )).
+
+thf(quoted_constant_type,type,(
+ 'A constant': $i )).
+
+thf(quoted_function_type,type,(
+ 'A function': $i > $i )).
+
+thf(quoted_escape_type,type,(
+ 'A \'quoted \\ escape\'': $i )).
+
+%----Quoted symbols
+thf(single_quoted,axiom,
+ ( 'A proposition'
+ | ( 'A predicate' @ a )
+ | ( p @ 'A constant' )
+ | ( p @ ( 'A function' @ a ) )
+ | ( p @ 'A \'quoted \\ escape\'' ) )).
+
+%----Connectives - seen |, &, =>, ~ already
+thf(useful_connectives,axiom,(
+ ! [X: $i] :
+ ( ( ( p @ X )
+ <= ~ ( q @ X @ a ) )
+ <=> ? [Y: $i,Z: $i] :
+ ( ( r @ X @ ( f @ Y ) @ ( g @ X @ ( f @ Y ) @ Z ) )
+ <~> ~ ( s @ ( f @ ( f @ ( f @ b ) ) ) ) ) ) )).
+
+%----Lambda terms
+thf(l1_type,type,(
+ l1: $i > ( $i > $o ) > $o )).
+
+thf(l2_type,type,(
+ l2: ( $i > ( $i > $i ) > $i ) > $o )).
+
+thf(lambda_defn,axiom,
+ ( l1
+ = ( ^ [C: $i,P: $i > $o] :
+ ( P @ C ) ) )).
+
+thf(lambda_use,axiom,
+ ( l2
+ @ ^ [C: $i,F: $i > $i] :
+ ( F @ C ) )).
+
+%----New types
+thf(new_type,type,(
+ new: $tType )).
+
+thf(newc_type,type,(
+ newc: new )).
+
+thf(newf_type,type,(
+ newf: new > $i > new )).
+
+thf(newp_type,type,(
+ newp: new > $i > $o )).
+
+thf(new_axiom,axiom,(
+ ! [X: new] :
+ ( newp @ ( newf @ newc @ a ) @ a ) )).
+
+%----Annotated formula names
+thf(123,axiom,(
+ ! [X: $i] :
+ ( ( ( p @ X )
+ | ~ ( q @ X @ a ) )
+ => ? [Y: $i,Z: $i] :
+ ( ( r @ X @ ( f @ Y ) @ ( g @ X @ ( f @ Y ) @ Z ) )
+ & ~ ( s @ ( f @ ( f @ ( f @ b ) ) ) ) ) ) )).
+
+%----Roles
+thf(role_hypothesis,hypothesis,
+ ( p @ h )).
+
+thf(role_conjecture,conjecture,(
+ ? [X: $i] :
+ ( p @ X ) )).
+
+%----Include directive
+include('Axioms/SYN000^0.ax').
+
+%----Comments
+/* This
+ is a block
+ comment.
+*/
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000^2.p b/tests/parsing/SYN000^2.p
new file mode 100644
index 000000000..64c636098
--- /dev/null
+++ b/tests/parsing/SYN000^2.p
@@ -0,0 +1,206 @@
+%------------------------------------------------------------------------------
+% File : SYN000^2 : TPTP v6.1.0. Bugfixed v5.5.0.
+% Domain : Syntactic
+% Problem : Advanced TPTP
+% Version : Biased.
+% English : Advanced TPTP TH0 syntax that you will encounter some time.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Rating : 1.00 v5.5.0
+% Syntax : Number of formulae : 38 ( 6 unit; 12 type; 1 defn)
+% Number of atoms : 151 ( 10 equality; 36 variable)
+% Maximal formula depth : 8 ( 4 average)
+% Number of connectives : 83 ( 2 ~; 9 |; 3 &; 62 @)
+% ( 1 <=>; 2 =>; 0 <=; 0 <~>)
+% ( 1 ~|; 1 ~&; 1 !!; 1 ??)
+% Number of type conns : 12 ( 9 >; 3 *; 0 +; 0 <<)
+% Number of symbols : 38 ( 12 :)
+% Number of variables : 25 ( 1 sgn; 20 !; 3 ?; 0 ^)
+% ( 25 :; 0 !>; 0 ?*)
+% ( 1 @-; 1 @+)
+% Arithmetic symbols : 3 ( 3 pred; 0 func; 0 numbers)
+% SPC : TH0_SAT_EQU
+
+% Comments :
+% Bugfixes : v4.0.1 - Fixed connective_terms and pi_sigma_operators so they're
+% well typed.
+% : v4.0.1 - Added more numbers, particularly rationals.
+% : v4.1.1 - Removed rationals with negative denominators.
+% : v4.1.1 - Fixed p_real_type
+% : v5.5.0 - Fixed tff to thf in 4 formulae
+%------------------------------------------------------------------------------
+%----Quoted symbols
+thf(distinct_object,axiom,(
+ "An Apple" != "A \"Microsoft \\ escape\"" )).
+
+%----Numbers
+thf(p_int_type,type,(
+ p_int: $int > $o )).
+
+thf(p_rat_type,type,(
+ p_rat: $rat > $o )).
+
+thf(p_real_type,type,(
+ p_real: $real > $o )).
+
+thf(integers,axiom,
+ ( ( p_int @ 123 )
+ | ( p_int @ -123 ) )).
+
+thf(rationals,axiom,
+ ( ( p_rat @ 123/456 )
+ | ( p_rat @ -123/456 )
+ | ( p_rat @ +123/456 ) )).
+
+thf(reals,axiom,
+ ( ( p_real @ 123.456 )
+ | ( p_real @ -123.456 )
+ | ( p_real @ 123.456E789 )
+ | ( p_real @ 123.456e789 )
+ | ( p_real @ -123.456E789 )
+ | ( p_real @ 123.456E-789 )
+ | ( p_real @ -123.456E-789 ) )).
+
+%----Types for stuff below
+thf(a_type,type,(
+ a: $i )).
+
+thf(b_type,type,(
+ b: $i )).
+
+thf(f_type,type,(
+ f: $i > $i )).
+
+thf(g_type,type,(
+ g: ( $i * $i ) > $i )).
+
+thf(h_type,type,(
+ h: ( $i * $i * $i ) > $i )).
+
+thf(p_type,type,(
+ p: $i > $o )).
+
+thf(q_type,type,(
+ q: $i > $i > $o )).
+
+%----Conditional constructs
+thf(if_then_else_thf,axiom,
+ ! [Z: $i] :
+ $ite_f(
+ ? [X: $i] : ( p @ X)
+ , ! [X: $i] : (q @ X @ X)
+ , ( q @ Z @ $ite_f(! [X: $i] : ( p @ X), ( f @ a), ( f@ Z))) ) ).
+
+%----Let binders
+thf(let_binders_thf,axiom,(
+ ! [X: $i] :
+ $let_ff(
+ ! [Y1: $i,Y2: $i] :
+ ( ( p @ Y1 @ Y2)
+ <=> ( q @ Y1) )
+ , $let_tf(
+ ! [X1: $i,X2: $i] : ( ( g @ X1 @ X2) = (h @ X1 @ X1 @ X1) )
+ , ( p @ ( g @ a @ b) ) ) ) )).
+
+%----Connective terms
+thf(equal_equal_equal,axiom,(
+ = = = )).
+
+thf(connective_terms,axiom,(
+ ! [P: $o,C: $i] :
+ ( ( & @ ( p @ C ) @ P )
+ = ( ~ @ ( ~& @ ( p @ C ) @ P ) ) ) )).
+
+%----Connectives - seen |, &, =>, ~ already
+thf(pi_sigma_operators,axiom,
+ ( ( !! ( p )
+ & ?? ( p ) )
+ = ( ! [X: $i] :
+ ? [Y: $i] :
+ ( ( p @ X )
+ & ( p @ Y ) ) ) )).
+
+thf(description_choice,axiom,
+ ( ? [X: $i] :
+ ( ( p @ X )
+ & ! [Y: $i] :
+ ( ( p @ Y )
+ => ( X = Y ) ) )
+ => ( ( @-[X: $i] :
+ ( p @ X ) )
+ = ( @+[X: $i] :
+ ( p @ X ) ) ) )).
+
+thf(never_used_connectives,axiom,(
+ ! [X: $i] :
+ ( ( ( p @ X )
+ ~| ~ ( q @ X @ a ) )
+ ~& ( p @ X ) ) )).
+
+%----Roles
+thf(role_definition,definition,(
+ ! [X: $i] :
+ ( ( f @ a )
+ = ( f @ X ) ) )).
+
+thf(role_assumption,assumption,
+ ( p @ a )).
+
+thf(role_lemma,lemma,
+ ( p @ a )).
+
+thf(role_theorem,theorem,
+ ( p @ a )).
+
+thf(role_unknown,unknown,
+ ( p @ a )).
+
+%----Selective include directive
+include('Axioms/SYN000^0.ax',[ia1_type,ia1,ia3_type,ia3]).
+
+%----Source
+thf(source_unknown,axiom,(
+ ! [X: $i] :
+ ( p @ X ) ),
+ unknown).
+
+thf(source,axiom,(
+ ! [X: $i] :
+ ( p @ X ) ),
+ file('SYN000-1.p')).
+
+thf(source_name,axiom,(
+ ! [X: $i] :
+ ( p @ X ) ),
+ file('SYN000-1.p',source_unknown)).
+
+thf(source_copy,axiom,(
+ ! [X: $i] :
+ ( p @ X ) ),
+ source_unknown).
+
+thf(source_introduced_assumption,axiom,(
+ ! [X: $i] :
+ ( p @ X ) ),
+ introduced(assumption,[from,the,world])).
+
+thf(source_inference,axiom,
+ ( p @ a ),
+ inference(magic,[status(thm),assumptions([source_introduced_assumption])],[theory(equality),source_unknown])).
+
+thf(source_inference_with_bind,axiom,
+ ( p @ a ),
+ inference(magic,[status(thm)],[theory(equality),source_unknown:[bind(X,$fot(a))]])).
+
+%----Useful info
+thf(useful_info,axiom,(
+ ! [X: $i] :
+ ( p @ X ) ),
+ unknown,
+ [simple,prolog(like,Data,[nested,12.2]),AVariable,12.2,"A distinct object",$thf(( p @ X ) | ~ ( q @ X @ a )),data(name):[colon,list,2],[simple,prolog(like,Data,[nested,12.2]),AVariable,12.2]]).
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000_1.p b/tests/parsing/SYN000_1.p
new file mode 100644
index 000000000..0e4fa9d59
--- /dev/null
+++ b/tests/parsing/SYN000_1.p
@@ -0,0 +1,170 @@
+%------------------------------------------------------------------------------
+% File : SYN000_1 : TPTP v6.1.0. Released v5.0.0.
+% Domain : Syntactic
+% Problem : Basic TPTP TF0 syntax without arithmetic
+% Version : Biased.
+% English : Basic TPTP TF0 syntax that you can't survive without parsing.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Theorem
+% Rating : 0.00 v6.0.0, 0.40 v5.5.0, 0.25 v5.4.0, 0.33 v5.2.0, 0.67 v5.0.0
+% Syntax : Number of formulae : 38 ( 21 unit; 25 type)
+% Number of atoms : 74 ( 3 equality)
+% Maximal formula depth : 7 ( 3 average)
+% Number of connectives : 28 ( 9 ~; 10 |; 3 &)
+% ( 1 <=>; 3 =>; 1 <=; 1 <~>)
+% ( 0 ~|; 0 ~&)
+% Number of type conns : 17 ( 10 >; 7 *; 0 +; 0 <<)
+% Number of predicates : 37 ( 30 propositional; 0-3 arity)
+% Number of functors : 10 ( 6 constant; 0-3 arity)
+% Number of variables : 14 ( 1 sgn; 6 !; 8 ?)
+% Maximal term depth : 4 ( 2 average)
+% SPC : TF0_THM_EQU_NAR
+
+% Comments :
+%------------------------------------------------------------------------------
+%----Propositional
+tff(p0_type,type,(
+ p0: $o )).
+
+tff(q0_type,type,(
+ q0: $o )).
+
+tff(r0_type,type,(
+ r0: $o )).
+
+tff(s0_type,type,(
+ s0: $o )).
+
+tff(propositional,axiom,
+ ( ( p0
+ & ~ q0 )
+ => ( r0
+ | ~ s0 ) )).
+
+%----First-order
+tff(a_type,type,(
+ a: $i )).
+
+tff(b_type,type,(
+ b: $i )).
+
+tff(h_type,type,(
+ h: $i )).
+
+tff(f_type,type,(
+ f: $i > $i )).
+
+tff(g_type,type,(
+ g: ( $i * $i * $i ) > $i )).
+
+tff(p_type,type,(
+ p: $i > $o )).
+
+tff(q_type,type,(
+ q: ( $i * $i ) > $o )).
+
+tff(r_type,type,(
+ r: ( $i * $i * $i ) > $o )).
+
+tff(s_type,type,(
+ s: $i > $o )).
+
+tff(first_order,axiom,(
+ ! [X: $i] :
+ ( ( p(X)
+ | ~ q(X,a) )
+ => ? [Y: $i,Z: $i] :
+ ( r(X,f(Y),g(X,f(Y),Z))
+ & ~ s(f(f(f(b)))) ) ) )).
+
+%----Equality
+tff(equality,axiom,(
+ ? [Y: $i] :
+ ! [X: $i,Z: $i] :
+ ( f(Y) = g(X,f(Y),Z)
+ | f(f(f(b))) != a
+ | X = f(Y) ) )).
+
+%----True and false
+tff(true_false,axiom,
+ ( $true
+ | $false )).
+
+tff(quoted_proposition_type,type,(
+ 'A proposition': $o )).
+
+tff(quoted_predicate_type,type,(
+ 'A predicate': $i > $o )).
+
+tff(quoted_constant_type,type,(
+ 'A constant': $i )).
+
+tff(quoted_function_type,type,(
+ 'A function': $i > $i )).
+
+tff(quoted_escape_type,type,(
+ 'A \'quoted \\ escape\'': $i )).
+
+%----Quoted symbols
+tff(single_quoted,axiom,
+ ( 'A proposition'
+ | 'A predicate'(a)
+ | p('A constant')
+ | p('A function'(a))
+ | p('A \'quoted \\ escape\'') )).
+
+%----Connectives - seen |, &, =>, ~ already
+tff(useful_connectives,axiom,(
+ ! [X: $i] :
+ ( ( p(X)
+ <= ~ q(X,a) )
+ <=> ? [Y: $i,Z: $i] :
+ ( r(X,f(Y),g(X,f(Y),Z))
+ <~> ~ s(f(f(f(b)))) ) ) )).
+
+%----New types
+tff(new_type,type,(
+ new: $tType )).
+
+tff(newc_type,type,(
+ newc: new )).
+
+tff(newf_type,type,(
+ newf: ( new * $i ) > new )).
+
+tff(newp_type,type,(
+ newp: ( new * $i ) > $o )).
+
+tff(new_axiom,axiom,(
+ ! [X: new] : newp(newf(newc,a),a) )).
+
+%----Annotated formula names
+tff(123,axiom,(
+ ! [X: $i] :
+ ( ( p(X)
+ | ~ q(X,a) )
+ => ? [Y: $i,Z: $i] :
+ ( r(X,f(Y),g(X,f(Y),Z))
+ & ~ s(f(f(f(b)))) ) ) )).
+
+%----Roles
+tff(role_hypothesis,hypothesis,(
+ p(h) )).
+
+tff(role_conjecture,conjecture,(
+ ? [X: $i] : p(X) )).
+
+%----Include directive
+include('Axioms/SYN000_0.ax').
+
+%----Comments
+/* This
+ is a block
+ comment.
+*/
+
+%------------------------------------------------------------------------------
diff --git a/tests/parsing/SYN000_2.p b/tests/parsing/SYN000_2.p
new file mode 100644
index 000000000..1ecba0fda
--- /dev/null
+++ b/tests/parsing/SYN000_2.p
@@ -0,0 +1,135 @@
+%------------------------------------------------------------------------------
+% File : SYN000_2 : TPTP v6.1.0. Bugfixed v5.5.1.
+% Domain : Syntactic
+% Problem : Advanced TPTP TF0 syntax without arithmetic
+% Version : Biased.
+% English : Advanced TPTP TF0 syntax that you will encounter some time.
+
+% Refs :
+% Source : [TPTP]
+% Names :
+
+% Status : Satisfiable
+% Rating : 1.00 v6.0.0
+% Syntax : Number of formulae : 26 ( 18 unit; 7 type)
+% Number of atoms : 42 ( 2 equality)
+% Maximal formula depth : 5 ( 2 average)
+% Number of connectives : 6 ( 2 ~; 0 |; 1 &)
+% ( 1 <=>; 0 =>; 0 <=; 0 <~>)
+% ( 1 ~|; 1 ~&)
+% Number of type conns : 9 ( 5 >; 4 *; 0 +; 0 <<)
+% Number of predicates : 14 ( 11 propositional; 0-2 arity)
+% Number of functors : 6 ( 4 constant; 0-2 arity)
+% Number of variables : 18 ( 0 sgn; 13 !; 1 ?)
+% Maximal term depth : 2 ( 1 average)
+% SPC : TF0_SAT_EQU_NAR
+
+% Comments :
+% Bugfixes : v5.5.1 - Fixed let_binders.
+%------------------------------------------------------------------------------
+%----Quoted symbols
+tff(distinct_object,axiom,(
+ "An Apple" != "A \"Microsoft \\ escape\"" )).
+
+%----Types for stuff below
+tff(a_type,type,(
+ a: $i )).
+
+tff(b_type,type,(
+ b: $i )).
+
+tff(f_type,type,(
+ f: $i > $i )).
+
+tff(g_type,type,(
+ g: ( $i * $i ) > $i )).
+
+tff(h_type,type,(
+ h: ( $i * $i * $i ) > $i )).
+
+tff(p_type,type,(
+ p: $i > $o )).
+
+tff(q_type,type,(
+ q: ( $i * $i ) > $o )).
+
+%----Conditional constructs
+tff(conditionals,axiom,(
+ ! [Z: $i] :
+ $ite_f(
+ ? [X: $i] : p(X)
+ , ! [X: $i] : q(X,X)
+ , q(Z,$ite_t(! [X: $i] : p(X), f(a), f(Z))) ) )).
+
+%----Let binders
+tff(let_binders,axiom,(
+ ! [X: $i] :
+ $let_ff(
+ ! [Y1: $i,Y2: $i] :
+ ( q(Y1,Y2)
+ <=> p(Y1) )
+ , ( q($let_tt(! [Z1: $i] : f(Z1) = g(Z1,b), f(a)),X)
+ & p($let_ft(! [Y3: $i,Y4: $i] : ( q(Y3,Y4) <=> $ite_f(Y3 = Y4, q(a,a), q(Y3,Y4) ) ), $ite_t(q(b,b), f(a), f(X)))) ) ) )).
+
+%----Rare connectives
+tff(never_used_connectives,axiom,(
+ ! [X: $i] :
+ ( ( p(X)
+ ~| ~ q(X,a) )
+ ~& p(X) ) )).
+
+%----Roles
+tff(role_definition,definition,(
+ ! [X: $i] : f(a) = f(X) )).
+
+tff(role_assumption,assumption,(
+ p(a) )).
+
+tff(role_lemma,lemma,(
+ p(a) )).
+
+tff(role_theorem,theorem,(
+ p(a) )).
+
+tff(role_unknown,unknown,(
+ p(a) )).
+
+%----Selective include directive
+include('Axioms/SYN000_0.ax',[ia1,ia3]).
+
+%----Source
+tff(source_unknown,axiom,(
+ ! [X: $i] : p(X) ),
+ unknown).
+
+tff(source,axiom,(
+ ! [X: $i] : p(X) ),
+ file('SYN000-1.p')).
+
+tff(source_name,axiom,(
+ ! [X: $i] : p(X) ),
+ file('SYN000-1.p',source_unknown)).
+
+tff(source_copy,axiom,(
+ ! [X: $i] : p(X) ),
+ source_unknown).
+
+tff(source_introduced_assumption,axiom,(
+ ! [X: $i] : p(X) ),
+ introduced(assumption,[from,the,world])).
+
+tff(source_inference,axiom,(
+ p(a) ),
+ inference(magic,[status(thm),assumptions([source_introduced_assumption])],[theory(equality),source_unknown])).
+
+tff(source_inference_with_bind,axiom,(
+ p(a) ),
+ inference(magic,[status(thm)],[theory(equality),source_unknown:[bind(X,$fot(a))]])).
+
+%----Useful info
+tff(useful_info,axiom,(
+ ! [X: $i] : p(X) ),
+ unknown,
+ [simple,prolog(like,Data,[nested,12.2]),AVariable,12.2,"A distinct object",$tff(p(X) | ~ q(X,a)),data(name):[colon,list,2],[simple,prolog(like,Data,[nested,12.2]),AVariable,12.2]]).
+
+%------------------------------------------------------------------------------
diff --git a/tests/tests.ml b/tests/tests.ml
deleted file mode 100644
index 05d9c4b82..000000000
--- a/tests/tests.ml
+++ /dev/null
@@ -1,124 +0,0 @@
-open OUnit
-open Tests_lib
-
-
-let unused = Template.lazy_propagation
-
-let opt_seed = ref 0
-
-let print_seed fmt = function
- | None -> Format.fprintf fmt "No"
- | Some [|i|] -> Format.fprintf fmt "%i" i
- | _ -> assert false
-
-let make_tests acc seed =
- let module Utils = Tests_utils in
- let module Uf = Tests_uf in
- let module Arith = Tests_arith in
- let module UfArith = Tests_arith_uninterp in
- let module Bv = Tests_bv in
- let module Bool = Tests_bool in
- let test = ((Pp.sprintf "seed %a" print_seed seed) >:::
- [Utils.tests;
- Uf.tests ; Arith.tests; UfArith.tests; Bool.tests; Bv.tests]) in
- let test = test_decorate
- (fun f -> (fun () -> Shuffle.set_shuffle seed; f ())) test in
- test::acc
-
-let tests () =
- let l = Util.foldi (fun acc i -> make_tests acc (Some [|i|])) []
- (!opt_seed + 1) (!opt_seed + 9)in
- make_tests l None
-
-let tests () =
-(* test_decorate
- (fun f ->
- if Printexc.backtrace_status ()
- then fun () -> try f () with exn -> Printexc.print_backtrace stdout;
- raise exn
- else f
- ) *)
- TestList (tests ())
-
-(** From oUnit.ml v 1.2.2 *)
-(** just need to make the tests lazily computed *)
-
-(* 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
-
-
-(* Call this one from you test suites *)
-let run_test_tt_main ?(arg_specs=[]) suite =
- let only_test = ref [] in
- let () =
- Arg.parse
- (Arg.align
- [
- "-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 () = Debug.Args.set_flags_selected () in
- let verbose = Debug.test_flag debug 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 = run_test_tt ~verbose nsuite in
- if not (was_successful result) then
- exit 1
- else
- result
-
-(*** End *)
-
-let () =
- if not (Solver.check_initialization ()) ||
- not (Conflict.check_initialization ()) then
- exit 1
-
-let _ =
- try
- run_test_tt_main
- ~arg_specs:["--seed",Arg.Set_int opt_seed,
- " Base seed used for shuffling the arbitrary decision";
- Debug.Args.desc_debug;
- Debug.Args.desc_debug_all]
- tests
- with e when not (Debug.test_flag Debug.stack_trace) ->
- Format.eprintf "%a@." Exn_printer.exn_printer e;
- exit 1
diff --git a/tests/tests_altergo_arith.split b/tests/tests_altergo_arith.split
deleted file mode 100644
index cc63c40a6..000000000
--- a/tests/tests_altergo_arith.split
+++ /dev/null
@@ -1,1972 +0,0 @@
-(*
-$$$arith
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts d'arithmétique linéaire en utilisant la procédure de décision de Fourier Motzkin ou le solveur Oméga.
-*)
-
-(*deactivated
-(* status: Valid *)
-goal g1: forall x:int. x<=x
-*)
-
-(* status: Valid *)
-goal g2: forall x:int. x-x = 0
-
-(*deactivated
-(* status: Valid *)
-goal g3: forall x:int. 0<=x -> 0=x-x and 0<=x and x<=x
-
-(* status: Valid *)
-goal g4: forall x,y,z:int. x<=y and y+z<=x and 0<=z -> x=y
-
-(* status: Valid *)
-logic P:prop
-goal g5: forall x:int. x=10 and (3<x -> P) -> P
-*)
-(* status: Valid *)
-logic f: int -> int
-goal g6: forall x,y:int. x+1=y -> f(x+2)=f(y+1)
-(*deactivated
-(* status: Valid *)
-logic Q:int -> prop
-goal g7: forall x,y:int. Q(y) -> (y<=x and x<=y) -> Q(x)
-
-(* status: Valid *)
-logic f: int -> int
-goal g8:
- forall x,y,u,v,z:int.
- u=v and u<=x+y and x+y<=u and v<=z+x+4 and z+x+4<=v -> f(x+y) = f(z+x+4)
-*)
-(* status: Valid *)
-logic f: int -> int
-goal g9: forall x:int. f(x) = x -> f(2*x - f(x)) = x
-
-(* status: Valid *)
-type a
-logic f : int -> a
-goal g10:
- forall x,z:int.
- forall u,t:a.
- f(x+3)=u and f(z+2)=t and x=z-1 -> u=t
-
-(* status: Valid *)
-type a
-logic f : int -> a
-goal g11:
- forall x,y,z:int.
- forall u,t:a.
- x=y-1 and f(x)=u and z=2 and f(z)=t and y=3 -> u=t
-(*deactivated
-(* status: Valid *)
-goal g12:forall x,z,v,u:int. v<=z+4 and u<=v+2 and z+6<=u -> u+v=z+u+4
-*)
-(* status: Valid *)
-logic P:prop
-goal g13: 1=2 -> P
-
-(* status: Valid *)
-goal g14: forall x,y:int. x=y-1 and y=2 -> x=1
-(*deactivated
-(* status: Valid *)
-goal g15: forall x:int. x<0 -> -x >=0
-
-(* status: Valid *)
-logic p,q : int -> prop
-goal g16 :
- (forall k:int. 0 <= k <= 10 -> p(k)) ->
- p(11) ->
- forall k:int. 0 <= k <= 11 -> p(k)
-
-(* status: Valid *)
-logic p,q : int -> prop
-goal g17 :
- (forall k:int. 0 <= k <= 10 -> (p(k) and q(k))) ->
- p(11) -> q(11) ->
- forall k:int. 0 <= k <= 11 -> (p(k) and q(k))
-
-(* status: Valid *)
-logic p,q : int -> prop
-goal g18 :
- (forall k:int. 0 <= k <= 10 -> p(k) -> q(k)) ->
- (p(11) -> q(11)) ->
- forall k:int. 0 <= k <= 11 -> p(k) -> q(k)
-
-(* status: Valid *)
-logic p,q : int -> prop
-logic a,b : int
-
-goal g19 :
- (forall k:int. a <= k <= b -> p(k)) ->
- p(b+1) ->
- forall k:int. a <= k <= b+1 -> p(k)
-
-(* status: Valid *)
-logic p,q : int -> prop
-logic a,b : int
-
-goal g20 :
- (forall k:int. a <= k <= b -> (p(k) and q(k))) ->
- p(b+1) -> q(b+1) ->
- forall k:int. a <= k <= b+1 -> (p(k) and q(k))
-
-(* status: Valid *)
-goal g21:
- forall size:int. (0 <= size) -> (size <= size) and (0 = (size - size))
-*)
-
-(* status: Valid *)
-
-logic f : int -> int
-logic t,u,x,y,z : int
-
-goal g22:t=f(0) -> u=f(4*x+5*y-3*z-3) -> 8*x+10*y=6*z+6 -> t=u
-
-(*deactivated
-(* status: Valid *)
-goal g23: forall x:int. x*x>=0 -> 1=1
-*)
-
-(* status: Valid *)
-goal g24: forall x:int. (2+4)*x = (1+1)*x + (2*3)*x -(3-2)*x + (1*x)*(3-4)
-
-(* status: Valid *)
-goal g24bis: forall x:int. (2+4)*x = (1*x)*(10-4)
-
-(* status: Unknown *)
-goal g24bis: forall x:int. x = (1*x)*(10-4)
-
-(* status: Valid *)
-goal g24ter: forall x:int. x = (1*x)
-
-(*deactivated
-(* status: Valid *)
-logic a:int
-
-goal g25: a=0 -> 0<=a-1 -> false
-
-
-(* status: Valid *)
-goal g26: forall i0:int.(i0 <= 7) -> (i0 <> 6) -> (i0 >= 6) -> i0 = 7
-
-
-(* status: Valid *)
-logic f:int ->int
-
-goal g27:
- forall n:int.
- forall count:int.
- forall sum:int.
- sum = (f(count) * f(count)) ->
- (sum <= n) ->
- forall count0:int.
- (count0 = f(count)) ->
- (n >= count0 * count0)
-*)
-(* status: Valid *)
-logic q : int
-logic p : int
-logic b : int
-logic a : int
-
-(*
-axiom a1: forall x:int. x*0 = 0
-axiom a2: forall x:int. 0*x = 0
-*)
-
-axiom x9 : q = a
-axiom x10 : p = 0
-goal g28 : a = p * b + q
-
-(* status: Valid *)
-
-logic f : int -> int
-logic u,t,x : int
-
-goal g29: u=f(0) -> t=f(x) -> x=0 -> u=t
-
-
-(* status: Valid *)
-
-goal g30: forall x:int. x = 3*x+4 -> x = -2
-
-
-(*deactivated
-(* status: Valid *)
-type 't pointer
-
-type ('t, 'v) memory
-
-logic select : ('a2, 'a1) memory, 'a2 pointer -> 'a1
-
-logic store : ('a1, 'a2) memory, 'a1 pointer, 'a2 -> ('a1, 'a2) memory
-
-axiom select_store_eq:
- (forall m:('a1, 'a2) memory.
- (forall p1:'a1 pointer.
- (forall p2:'a1 pointer.
- (forall a:'a2 [store(m, p1, a), p2].
- ((p1 = p2) -> (select(store(m, p1, a), p2) = a))))))
-
-axiom select_store_neq:
- (forall m:('a1, 'a2) memory.
- (forall p1:'a1 pointer.
- (forall p2:'a1 pointer.
- (forall a:'a2 [store(m, p1, a), p2].
- ((p1 <> p2) -> (select(store(m, p1, a), p2) = select(m, p2)))))))
-
-type int32
-
-logic f : int32 -> int
-
-type int_P
-
-logic aa:int
-
-goal f_ensures_default_po_1:
- forall p:int_P pointer.
- forall m1:(int_P, int32) memory.
- forall result:int32.
- f(result) = 1 ->
- forall m2:(int_P, int32) memory.
- m2 = store(m1, p, result) ->
- f(select(m2, p)) = 1
-
-
-(* status: Valid *)
-
-goal g30_1: forall x:int. x<>1 and 1 <= x and x <= 2 -> x=2
-
-
-(* status: Valid *)
-
-goal g30_2 : forall x:int. 0 <= x <= 1 -> x=0 or x=1
-
-
-(* status: Valid *)
-
-goal g30_3 : forall x:int. 0 <= x <= 1 -> (x = 0 or x = 1)
-
-
-(* status: Valid *)
-
-logic p,q : int -> prop
-
-goal g30_4 :
- (forall k:int. 0 <= k <= 10 -> p(k)) ->
- p(11) ->
- forall k:int. 0 <= k <= 11 -> p(k)
-
-
-(* status: Valid *)
-
-logic f : int -> int
-
-logic x:int
-
-goal g30_5 :
- f(x) <> f(30) ->
- f(x) <> f(31) ->
- 2 <= x ->
- f(x) <> f(32) ->
- f(x) <> f(33) ->
- f(x) <> f(100) ->
- f(x) <> f(0) ->
- 2 <= x <= 29
- or
- 34 <= x <= 99
- or
- 101 <= x
-
-
-(* status: Valid *)
-
-logic P,Q : int -> prop
-axiom a1: forall x:int. x <= 1 -> Q(x)
-axiom a2: forall x:int. P(x) -> Q(x)
-axiom a3: forall x:int. x >= 6 -> P(x)
-axiom a4: P(5)
-axiom a6: P(4)
-axiom a7: Q(2)
-axiom a8: Q(3)
-
-goal g31 : forall x:int. 0 <= x <= 7 -> Q(x)
-
-
-(* status: Valid *)
-goal g32: forall x:real. -1. <= x <= 1. -> (x< -1. or x> 1.) -> false
-*)
-
-(*
-$$$ac_arith
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts faisant intervenir des symboles associatifs commutatifs qui sont traités par l'algorithme AC(X) modulo la théorie de l'arithmétique.
-*)
-(*deactivated
-(* status: Valid *)
-logic ac f : int,int -> int
-goal g1 : forall a,b,c,x:int. c = a + x -> a = f(c,b) -> x=1 -> f(c,b)=c-1
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g2 :
- a = b ->
- f(a+1,a) = f(a,b+1)
-
-
-(* status: Valid *)
-logic a,b,c,x,beta,gamma,d:int
-
-logic ac f : int,int -> int
-
-goal g3 :
- f((f(a,b) + x),c) = gamma ->
- x = 0 ->
- f(a,c) = a ->
- f(a,d) = beta ->
- f(b,beta) = f(d,gamma)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-goal g4 : forall a,b,c,x:int. c = a + x -> a = f(c,b) -> x=0 -> f(c,b)=c
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g5 :
- a = b ->
- f(a+1,a) = f(a,b+1)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g6 :
- a = b ->
- f(a+1,a) = f(a+1,b)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g7 :
- a + 1 = b ->
- f(a+1,a) = f(a,b)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g8 :
- a + 1 = b + x ->
- x = 1 ->
- f(a,a) = f(a,b)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g9 : a = b -> b = a
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g10 :
- f(a,a) = a ->
- a = b ->
- f(a,b) + a =a + b
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g11 :
- a = b ->
- f(a+1,a+2) = f(a+1,b+2)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g12 :
- a + 1 = b + 2 ->
- f(a,a-1) = f(a,b)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g13 :
- 2 * a = 3 * b ->
- f(x,2 * a) = f(3 * b,x)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:real
-logic ac f : real,real -> real
-goal g14 :
- 2. * a = 3. * b ->
- f(x,2./3. * a) = f(b,x)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g15 :
- f(a,a) = a ->
- a = b ->
- f(a,b) + a =a + b
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,x,y:int
-
-goal g16:
- f(a,b) + x = b ->
- x = 0 ->
- f(a,f(b,y)) = f(b,y)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g17:
- f(a,b) = gamma ->
- x = 0 ->
- f(a,c) = beta + x ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g18:
- f(a,b) = gamma + x ->
- x = 0 ->
- f(a,c) = beta + x ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g19:
- f(a,b) = gamma ->
- f(a,c) = beta + x ->
- x = 0 ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g20:
- f(a,b) = gamma + x ->
- f(a,c) = beta + x ->
- x = 0 ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g21:
- f(a,b) = gamma + x ->
- f(a,c) = beta ->
- x = 0 ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g22:
- f(a,b) = gamma ->
- f(a,c) = beta ->
- x = 0 ->
- f(c,x + gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-(* axiome special pour corriger le pb de matching AC *)
-axiom neutre : forall u,v:int. f(u,f(v,0))= f(u,v)
-
-goal g23:
- f(a,b) = gamma ->
- f(a,c) = beta ->
- x = 0 ->
- f(c,gamma) = f(f(b,x),beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g24:
- f(a,b) = gamma ->
- f(a,c) = beta ->
- x = 0 ->
- f(c,gamma) = f(b + x,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g25:
- x = 0 ->
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(c,x + gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g26 :
- f(a,b+x) = gamma ->
- f(a,c) = beta ->
- x = 1 ->
- f(b + 1,beta) = f(c,gamma)
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g27 :
- f(a,b+x) = gamma ->
- f(a,c) = beta ->
- x = 0 ->
- f(b,beta) = f(c,gamma)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g28 :
- x = 0 ->
- f(a,b) + x = u ->
- f(a,c) = w ->
- f(u,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g29 :
- f(b,a) = f(b+x,f(a+x,a+x)) ->
- x = 1 ->
- f(b,c) = beta ->
- f(b+1,f(a+1, f(a+1, c))) = f(a,beta)
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g30 :
- f(b,a) = f(b+x,f(a+x,a+x)) ->
- f(b,c) = beta ->
- x = 1 ->
- f(b + 1,f(a + 1, f(a + 1, c))) = f(a,beta)
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g31 :
- x = 1 ->
- f(b,a) = f(b+x,f(a+x,a+x)) ->
- f(b,c) = beta ->
- f(b + 1,f(a + 1, f(a + 1, c))) = f(a,beta)
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g32 :
- x = 2 ->
- f(a,b) = f(a,f(b,c)) ->
- f(a,f(b,gamma)) = f(a,f(b,f(c,gamma)))
-
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g33 :
- x = 1 ->
- f(a,b) = f(b+x,f(a+x,a+x)) ->
- f(b + 1,f(a + 1, f(a + 1, c))) = f(b,f(a,c))
-
-$
-
-logic a,b,c, beta,gamma,x : int
-logic ac f : int,int -> int
-
-goal g34 :
- x = 1 ->
- f(a,b+x) = gamma ->
- f(a,c) = beta ->
- f(gamma,c) = f(beta, b + 1)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x,y:int
-
-goal g35 :
- x = 0 ->
- f(a,b) = u ->
- f(a,b) + x = v + y ->
- f(a,c)=w ->
- f(v+y,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g36 :
- x = 0 ->
- f(a,b) = u ->
- f(a,b) + x = v ->
- f(a,c)=w ->
- f(v,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g37:
- f(a,c) = w ->
- f(a,b) + x = v ->
- x = 0 ->
- f(v,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g38:
- f(a,b) = u -> (* ne sert pas! juste une pollution*)
- f(a,b) + x = v ->
- x = 0 ->
- f(a,c) = w ->
- f(v,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g39:
- f(a,b) = u ->
- x = 0 ->
- f(a,b) + x = v ->
- f(a,c) = w ->
- f(v,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g40:
- x = 0 ->
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(c,gamma) = f(b + x,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g41:
- x = 0 ->
- f(a,b) = gamma + x ->
- f(a,c) = beta + x ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,gamma,beta,x:int
-
-goal g42:
- f(a,b) = gamma + x ->
- x = 0 ->
- f(a,c) = beta ->
- f(c,gamma) = f(b,beta)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g43:
- f(a,c) = w ->
- f(a,b) + x = b ->
- x = 0 ->
- f(b,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,u,v,w,x:int
-
-goal g44:
- b = v ->
- f(a,c) = w ->
- f(a,b) + x = v ->
- x = 0 ->
- f(v,c) = f(w,b)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g45 :
- f(a+1,b) = gamma ->
- f(a+t,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- g(f(gamma,c),d) = x ->
- g(f(beta,b),e) = y ->
- t = 1 ->
- g(x,e) = g(y,d)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g46 :
- f(a+1,b) = gamma ->
- f(a+t,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- g(f(gamma,c),d) = x ->
- t = 1 ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g47 :
- f(a+t,b) = gamma ->
- f(a+t,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- g(f(gamma,c),d) = x ->
- t = 1 ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g48 :
- f(a,b) = gamma ->
- f(a+t,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- t = 0 ->
- g(f(gamma,c),d) = x ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g49 :
- f(a,b) = gamma ->
- f(a,c+t) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- g(f(gamma,c+t),d) = x ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g50 :
- f(a,b) = gamma ->
- f(a,c+t) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- g(f(gamma,c+1),d) = x ->
- g(f(beta,b),e) = y ->
- t = 1 ->
- g(x,e) = g(y,d)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y,t:int
-logic ac f,g : int,int -> int
-
-goal g51 :
- f(a,b) = gamma ->
- f(a,c+t) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- t = 1 ->
- g(f(gamma,c+t),d) = x ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-
-(* status: Valid *)
-
-logic a,b,c,gamma,beta,t2,t4:int
-logic ac f,g : int,int -> int
-
-goal g52 :
- f(g(a,b+t2),c+t4) = gamma ->
- g(a,b+t2) = beta ->
- 1 = t2 ->
- t4 = 2 * t2->
- f(beta,c+2)= gamma
-
-
-
-(* status: Valid *)
-
-logic a,b,c,gamma,beta,t3,t1:int
-logic ac f,g : int,int -> int
-
-goal g53 :
- f(g(a,b+1)+t1,c+2) + t3 = gamma ->
- g(a+t3,b+1) = beta ->
- t3 = t1 ->
- t1 = 0 ->
- f(beta,c+2)= gamma
-
-
-
-(* status: Valid *)
-
-logic a,b,c,gamma,beta,t3,t2,t4:int
-logic ac f : int,int -> int
-
-goal g54 :
- a = beta ->
- f(a,5) + t3 = gamma ->
- t3 = 0 ->
- f(a,5)= gamma
-
-
-
-(* status: Valid *)
-logic ac f : int,int -> int
-logic a,b,c,x : int
-
-goal g55 :
- f(a,b) = f(a,x + f(c,f(b,a))) ->
- x = 0 ->
- f(a,b) = f(a,f(c,f(a,b)))
-
-
-
-(* status: Valid *)
-logic ac f,h : int,int -> int
-logic a,b,c,d,x,y,z,beta,gamma : int
-
-goal g56 :
- y = 1 ->
- f(a,b) = gamma ->
- f(a,c+y) = beta ->
- h(f(f(a,b),c+1),d) = f(gamma,beta) ->
- h(f(gamma,c+y),d) = f(gamma,beta)
-
-
-
-(* status: Valid *)
-logic ac f,g,h : int,int -> int
-logic a,b,c,d,e,x,y,z,t,m,n,alpha,beta,gamma,delta : int
-
-goal g57 :
- f(a+x+y, b+z) = gamma ->
- f(a+x+1, c+y) = beta ->
- h(f(f(a+x+1,b),c+1),d+z) = f(beta,f(a+x+y, b+z)) ->
- h(f(beta,b+y-1),g(h(z,x),y)) = h(delta,h(delta,beta)) ->
- x + y = x + 1 ->
- z + 1 = y ->
- x = 100 ->
- h(d+z,h(delta,h(delta,beta))) = h(f(f(a+x+y, b+z),f(a+x+1, c+y)),g(h(x,z),y))
-
-
-(* status: Valid *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g58 : (forall v,w:int[v,w]. f(v,w) = w) -> a = b
-
-*)
-
-
-(*
-$$$modulo
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts d'arithmérique linéaire avec comme seul symbole d'arithmétique linéaire le \texttt{modulo}.
-Le test vérifie que les contraintes relatives au \texttt{make} du \texttt{mod} sont bien crées.
-*)
-
-(*deactivated
-(* status: Valid *)
-goal g1: forall a:int. a % 2 = 1 -> (a + 1) % 2 = 1 -> false
-
-
-(* status: Valid *)
-goal g2: forall a:int. a % 2 = 1 -> (a + 1) % 2 = 0
-
-
-(* status: Valid *)
-goal g3: forall a,b:int. a % 2 = 1 -> a = b -> b % 2 = 1
-
-
-(* status: Valid *)
-goal g4: forall a:int. a % 2 = (a + 0)% (1+1)
-
-
-(* status: Valid *)
-goal g5: forall a:int. a % 8 = 6 -> a % 4 = 2 and a % 2 = 0
-
-
-(* status: Valid *)
-goal g6: forall a:int. a % 10 = 12 -> false
-
-
-(* status: Valid *)
-goal g7: forall a,m:int. a%10 = m -> 0 <= m < 10
-
-
-(* status: Valid *)
-goal g9: forall a,m,n,k:int. k = m + n -> a % k = a % (m+n)
-
-
-(* status: Valid *)
-goal g10: forall a:int. a % 4 = 1 -> a % 4 <> 0 and a % 4 <> 2 and a % 4 <> 3
-
-
-(* status: Valid *)
-goal g11: forall a,b:int. a % b = 1 -> b = 10 -> a % 10 = 1
-
-
-(* status: Valid *)
-goal g12: forall a:int. a % 2 = (a + 2) % 2
-
-
-(* status: Valid *)
-goal g12: forall a,b:int. a % 2 = (a + 2*b) % 2
-
-*)
-
-(*
-$$$non_lineaire
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts d'arithmérique non linéaire.
-Le test vérifie que les axiomes sur l'arithmétique non linéaires d'intervalle sont correctement implémentés et que la coopération avec l'algorithme AC(X) est correcte et termine.
-*)
-
-(*deactivated
-(* status: Valid *)
-goal sum_po_7:
- forall n,i,s:int.
- n >= 0 -> 2*s = i*(i + 1) and i <= n -> i >= n -> 2 * s = n*(n + 1)
-
-
-
-(* status: Valid *)
-goal sum_po_3:
- forall n,i,s:int.
- n >= 0 -> 2 * s = i * (i + 1) and i <= n ->
- i < n -> 2 * (s + i + 1) = (i + 1) * (i + 2)
-
-
-logic x,y,z,t1,t2,t3,t4 :int
-goal g1:
- x * y = t1 * t2 ->
- x * z = t3 * t4 ->
- z * t1 * t2 = y * t3 * t4
-
-
-
-(* status: Valid *)
-
-logic x,y,z,t1,t2,t3,t4 :int
-goal g2:
- x * y = t1 * t2 ->
- x * z = t3 * t4 ->
- z * (t1 * t2) = (y * t3) * t4
-
-
-
-(* status: Valid *)
-
-logic x,y,z:int
-
-goal g3:
- x * y * z = 12 ->
- x = 2 ->
- y = 3 ->
- z = 2
-
-
-
-(* status: Valid *)
-
-goal g4: forall x,y,z:int.
- x*x*x * y*y * z = 23040 ->
- x = 4 ->
- y = 6 ->
- z = 10
-
-
-(* status: Valid *)
-goal g5: forall x,y,z:int.
- y = 6 ->
- x = 4 ->
- x*x*x * y*y * z = 23040 ->
- z = 10
-
-
-
-(* status: Valid *)
-goal g6: forall x,y,z:int.
- y = 6 ->
- x = 4 ->
- x*x*x * y*y * z = 23040 ->
- 4 * y * y * z * z = 360 * z * x
-
-
-(* status: Valid *)
-goal g7: forall x,y,z:int.
- 5*x + x*y = 4*z + 20 ->
- x = 4 ->
- y = z
-
-
-(* status: Valid *)
-goal g8: forall x,y,z:int.
- x * (5 + y) = 4* (z + 5) ->
- x = 4 ->
- y = z
-
-
-
-(* status: Valid *)
-goal g9 : forall x:int. x*x = 0 -> x = 0
-
-
-
-(* status: Valid *)
-goal g10 : forall x:int. x*x*x = 1 -> x = 1
-
-
-
-(* status: Valid *)
-logic x,z : int
-
-goal g11 : x*x <= 0 -> x + z <= 3 -> z <= 3
-
-
-
-(* status: Valid *)
-logic x,z : int
-
-goal g12 : x*x = 0 -> x + z = 3 -> z = 3
-
-
-
-(* status: Valid *)
-
-logic x,y,z:int
-
-goal g13 :
- z * y * x = 20 ->
- x * y = 4 ->
- z = 5
-
-
-(* status: Valid *)
-logic x,y,z:int
-logic ac f : int,int -> int
-goal g14 :
- 4 * f(2,3) = z * y * x ->
- x * y = 4 ->
- f(2,3) = z
-
-
-(* status: Valid *)
-logic a,b,c,d,x,y,z:int
-logic ac f : int,int -> int
-goal g15 :
- 4 * a*b*c*d = z * y * x ->
- x * y = 4 ->
- 4 * a*b*c*d = 4 * z
-
-
-
-(* status: Valid *)
-
-logic x,y:int
-
-goal g16: x*x <=0 -> x + y = 4 -> y = 4
-
-
-(* status: Valid *)
-
-logic x,y:int
-goal g17: x*x*x = -1 -> x + y = 4 -> y = 5
-
-
-
-(* status: Valid *)
-logic x:int
-goal g18: -1<= x <= 1 -> x*x <> 1 -> x = 0
-
-
-
-(* status: Valid *)
-logic x:int
-goal g19 : 2 <= x*x <= 9 -> x= -2 or x = -3 or 2 <= x <= 3
-
-
-
-(* status: Valid *)
-logic x:int
-goal g20 : x*x*x*x <= 16 -> -2 <= x <= 2
-
-
-
-(* status: Valid *)
-logic x:int
-goal g21 : x >= 0 -> x*x = 9 -> x = 3
-
-
-
-(* status: Valid *)
-logic x:int
-goal g22 : 10 <= x*x*x <= 27 -> x = 3
-
-
-
-(* status: Valid *)
-logic x:int
-goal g23 : x*x*x = 64 -> x = 4
-
-
-
-(* status: Valid *)
-logic x:int
-goal g24 : x*x*x = -1000 -> x = -10
-
-
-
-(* status: Valid *)
-logic y:real
-goal g25 : y*y = 9. -> -3. = y or y = 3.
-
-
-
-(* status: Valid *)
-(* prouvé grace à la cooperation des intervalles,
- de arith (solve et subst) et de AC (collapse) *)
-goal g26:
- forall x:int. x*x*x = x*x -> x*x = 1 -> x = 1
-
-
-
-(* status: Valid *)
-(* inconsistent *)
-goal g27:
- forall x:int. x*x*x = x*x -> x*x = 4 -> false
-
-
-
-
-(* status: Valid *)
-goal g28:
- forall x:int. x >= 0 -> x <= (x + 1) * (x + 1)
-
-*)
-
-
-(*
-$$$arith_div
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts d'arithmérique non linéaire faisant intervenir des divisions (entières ou non).
-Le test vérifie que les contraintes relatives au \texttt{make} du \texttt{div} sont bien crées et que les axiomes de la division d'intervalles sont corrects.
-*)
-
-(*deactivated
-(* status: Valid *)
-logic x,y:int
-goal g1: 2 <= x / y <= 4 -> y = 2 -> 4 <= x <= 9
-
-
-
-(* status: Valid *)
-logic x,y:int
-goal g2: 4 <= x <= 9 -> 2 <= x / 2 <= 4
-
-
-
-(* status: Valid *)
-logic x,y:int
-goal g3: 4 <= x <= 8 -> -2 <= y <= 2 -> y <> 0 -> -8 <= x / y <= 8
-
-
-
-(* status: Valid *)
-logic x:int
-goal g5 : x <> 0 -> x/x = 1
-
-
-
-(* status: Valid *)
-logic x,y,z,t:int
-goal g6 : -4*x+2*y-z*t <> 0 -> (12*x-6*y+3*z*t)/(8*x-4*y+2*z*t) = 1
-
-
-
-(* status: Valid *)
-logic x:int
-goal g7 : 0/0 = 0/0 -> true
-
-
-
-(* status: Valid *)
-logic x:int
-goal g8 : 0/0 = 0/0
-
-
-
-(* status: Valid *)
-
-logic x,y : int
-
-goal g9 : x<>0 -> x = y -> y/y = 1
-
-
-(* status: Valid *)
-logic x,y : int
-
-goal g10 : x > 0 -> y > 0 -> x/y >=0
-
-
-(* status: Valid *)
-logic x : int
-
-goal g11 : x<>0 -> x/x = 1
-
-
-(* status: Valid *)
-logic x,y,z:int
-
-goal g12:
-
-x <> 0 -> (-2*x) / x = -2
-
-
-(* status: Valid *)
-logic x,y,z:int
-
-goal g13:
-
-x <> 0 -> x / (-2*x) = -1
-
-
-(* status: Valid *)
-logic x,y,z:int
-
-goal g14:
-
-2*x + 2*y <> 0 -> (4*x + 4*y ) / (2*x + 2*y ) = 2
-
-
-(* status: Valid *)
-logic x,y,z:int
-
-goal g15:
-
-2*x + 2*y +1 <> 0 -> (4*x + 4*y + 2 ) / (2*x + 2*y + 1) = 2
-
-
-(* status: Valid *)
-goal g16 (*sqrt_po_8*):
- forall x,y:int.
- x <> 0 ->
- y = (x + 1) / 2 ->
- y = ((x / x) + x) / 2
-
-
-(* status: Valid *)
-goal g17 (*sqrt_po_8*):
- forall x,y:int.
- x <> 0 ->
- (x + 1) / 2 = ((x / x) + x) / 2
-
-
-(* status: Valid *)
-goal g18 (*sqrt_po_8*):
- forall x,y:int.
- x <> 0 ->
- y <> 0 ->
- (x + 1) / y = ((x / x) + x) / y
-
-
-(* status: Valid *)
-goal g19:
- forall x,y,z:int.
- x > 3 ->
- y > 0 ->
- z > 0 ->
- y > z ->
- z = ((x / y) + y) / 2 ->
- z > 1 and y > 2
-*)
-
-(*
-$$$arith_modulo_div
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts d'arithmérique non linéaire faisant intervenir des divisions (entières ou non) et des modulos.
-Le test vérifie que les contraintes relatives au \texttt{make} de \texttt{div} et \texttt{mod} sont bien crées et que les axiomes de la division d'intervalles sont corrects.
-*)
-
-(*deactivated
-(* status: Valid *)
-goal g0: forall a: int. a > 0 -> a / 2 < a
-
-
-(* status: Valid *)
-goal mult_po_9: forall a,b :int. a % 2 <> 1 -> (a / 2) * 2 * b = a * b
-
-
-(* status: Valid *)
-goal mult_po_8: forall a:int. a > 0 -> a % 2 <> 1 -> a / 2 >= 0
-
-
-(* status: Valid *)
-goal mult_po_6: forall a:int. a > 0 -> a % 2 = 1 -> a / 2 < a
-
-
-(* status: Valid *)
-goal mult_po_4: forall a,b:int. a > 0 -> a % 2 = 1 -> b + (a / 2) * (2 * b) = a * b
-
-
-(* status: Valid *)
-goal mult_po_3: forall a:int. a > 0 -> a % 2 = 1 -> a / 2 >= 0
-
-
-(* status: Valid *)
-goal mult_po_11: forall a:int. a > 0 -> a % 2 <> 1 -> a/2 < a
-
-*)
-
-
-(*
-$$$polynomes
-$cobj:La fonctionnalité à vérifier est que Alt-Ergo est capable de prouver des buts d'arithmérique non linéaire en utilisant la distributivité de la multiplication sur l'addition effectuée par le \texttt{make} des polynômes.
-*)
-
-(* deactivated
-(* status: Valid *)
-goal g1 : (*goal sqrt_po_10*)
- forall x,y:int.
- x > 3 ->
- y = (x + 1) / 2 ->
- x < (y + 1) * (y + 1)
-
-
-
-(* status: Valid *)
-
-goal g2 :
- forall x,y,z,t:int.
- 0 <= y + z <= 1 ->
- x + t + y + z = 1 ->
- y + z <> 0 ->
- x + t = 0
-*)
-
-
-(*
-$$$arith_false
-$cobj:La fonctionnalité à vérifier est que le raisonnement fait par la coopération du module d'intervalles et l'algorithme Fourier-Motzkin est correct et que Alt-Ergo ne prouve pas des buts faux faisant intervenir de l'arithmétique linéaire.
-*)
-
-(* status: Unknown *)
-goal g1: 1=2
-
-
-(* status: Unknown *)
-logic a:int
-goal g2: a+0 = a+1
-
-(*deactivated
-(* status: Unknown *)
-logic Q,P: prop
-
-goal g3:
- forall c,v:int. (Q and c<=v and v<=c) ->P
-*)
-
-(* status: Unknown *)
-logic f: int -> int
-goal g4:
- forall x,y:int. f(x-1) = x + 2 and f(y) = y - 2 and y + 1 = x
-
-(*deactivated
-(* status: Unknown *)
-logic f: int -> int
-goal g5:
- forall u,v,x,y:int.
- u<=v and v<=u and 2*x +1 <= 2*y and x=f(u) and y=f(v)
-
-
-(* status: Unknown *)
-logic P: prop
-goal g6:
- forall x:int. x=1 and (3<x -> P) -> P
-
-
-(* status: Unknown *)
-logic Q,P: prop
-goal g7:
- forall x:int. x=3 and (3<x -> P) -> P
-
-
-(* status: Unknown *)
-logic b,a,c: int
-
-goal g8: b<=c -> (b<>a)-> a+1<=b -> false
-
-
-(* status: Unknown *)
-goal g9: forall x:int. 0<=x<=1 -> x=0
-
-
-(* status: Unknown *)
-goal g10: forall x:int. 0<=x<=1 -> x=1
-
-
-(* status: Unknown *)
-
-goal g11:
-forall x,y:int. 9*x + 13*y + 1 = 0 -> false
-
-(* status: Unknown *)
- goal g12:
- forall diff:int.
- forall left:int.
- forall right:int.
- diff = right - left ->
- diff > 0 ->
- forall r6:int. r6 = diff / 2 ->
- forall r8:int. r8 = left + r6 ->
- right - r8 < diff
-
-(* status: Unknown *)
-
-logic a, b, c :int
-
-goal g13:
- 3*c -2 = 8*a and
- c <= 0 and
- - b - c <= 0 and
- 2*b + c - 2 <= 0
- -> false
-
-
-
-(* status: Unknown *)
-goal g14 :
- forall x,y,z,t:int. 30*x = 15*y + 10*z + t ->
- t = 5 -> false
-
-
-
-(* status: Unknown *)
-goal g15:
- forall a,min, max,k : int.
- min = a ->
- min <= k <= max ->
- max - min <= 10 ->
- max - min = 0 ->
- false
-
-
-
-(* status: Unknown *)
-goal g16 : forall x:real. x < 3.0 -> x <= 2.0
-
-
-
-(* status: Unknown *)
-logic p:int
-
-goal g17:
-(* 1 *) p <> 0 and p <> 1 and p <= 9 and
-(* 2 *) p >= 4 and p <= 10 and p <> 5 and
-(* 3 *) p >= 1 and p <= 4
- -> false
-*)
-
-(*
-$$$ac_arith_mult_false
-$cobj:La fonctionnalité à vérifier est que le raisonnement fait par la coopération du module d'intervalles et de l'algorithme AC(X) est correct et que Alt-Ergo ne prouve pas des buts faux faisant intervenir de l'arithmétique non linéaire.
-*)
-
-(*deactivated
-(* status: Unknown *)
-logic y:real
-goal g1 : y*y = 9.1 -> -3. = y or y = 3.
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g2 : 4 <= x*x <= 9 -> 2 <= x <= 3
-
-
-
-(* status: Unknown *)
-
-logic f : int -> int
-
-goal g3 :
- forall a,b,x,y,z,t:int.
- x * x = f(z) + 2 ->
- x * y = f(t) + 2 ->
- false
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g4 : 0 <= x*x <= 4 -> 0 <= x <= 2
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g5 : x*x = 25 -> x = 5
-
-*)
-
-(*
-$$$div_false
-$cobj:La fonctionnalité à vérifier est que les contraintes du \texttt{make} de la divisions sont bien crées, que le raisonnement fait par le module d'intervalles sur la division est correct et que Alt-Ergo ne prouve pas des buts faux faisant intervenir des divisions non linéaires.
-*)
-
-(*deactivated
-(* status: Unknown *)
-logic x,y:int
-goal g1: 2 <= x / y <= 4 -> y = 2 -> 4 <= x <= 8
-
-
-
-(* status: Unknown *)
-logic x,y:int
-goal g2: 4 <= x <= 8 -> -2 <= y <= 2 -> -8 <= x / y <= 8
-
-
-
-(* status: Unknown *)
-logic x,y:int
-goal g3: 0 / 0 = 0
-
-
-
-(* status: Unknown *)
-logic x,y:int
-goal g4: -1 <= x <= 1 -> 0 / x = 0
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g5 : x/x = 1
-
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g6 : 0/0 = 1
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g7 : 0/0 = 0/0 -> false
-
-
-
-(* status: Unknown *)
-logic x:int
-goal g8 : 0/0 <> 0/0
-
-
-
-(* status: Unknown *)
-logic x:int
-logic P,Q: int -> prop
-goal g9 : P(0/x) -> P(0)
-
-*)
-(* status: Unknown *)
-logic x:int
-logic P,Q: int -> prop
-goal g10 : P(0) -> P(x)
-
-(*deactivated
-(* status: Unknown *)
-logic x,y:int
-goal g11 : y >= 1 -> (x/y)*y = x
-
-
-
-(* status: Unknown *)
-logic P : int -> prop
-
-logic x,y : int
-
-goal g12 : y = 0 -> P(x/y) -> false
-
-
-
-(* status: Unknown *)
-logic x,y : int
-
-goal g13 : -1 < x/y <1 -> false
-
-
-
-(* status: Unknown *)
-logic x,y : int
-
-goal g14 : x > 0 -> y > 0 -> x/y >0
-
-
-
-(* status: Unknown *)
-logic x,y,z : int
-
-goal g15 : x>=0 -> y >=0 -> x/y>=0
-
-
-
-(* status: Unknown *)
-
-logic x,y,z : int
-
-goal g16 : x>=0 -> y >=0 -> x/y = z -> y = 0 -> x/y>=0
-
-*)
-
-(*
-$$$ac_arith_false
-$cobj:La fonctionnalité à vérifier est que le raisonnement fait par l'algorithme AC(X) modulo la théorie de l'arithmétique est correct et que Alt-Ergo ne prouve pas des buts faux faisant intervenir de l'arithmétique linéaire et des symboles associatifs commutatifs.
-*)
-
-(*deactivated
-
-(* status: Unknown *)
-logic a,b,c,x,beta,gamma,d:int
-
-logic ac f : int,int -> int
-
-goal g1 :
- f((f(a,b) + x),c) = gamma ->
- x = 1 ->
- f(a,c) = a ->
- f(a,d) = beta ->
- f(b,beta) = f(d,gamma)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,gamma,beta,x : int
-logic ac f : int , int -> int
-
-goal g2 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(x,beta) ->
- f(gamma,c) = f(beta,b)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,gamma,beta,x,u,v : int
-logic f : int , int -> int
-
-goal g3 :
- f(a,b) = u ->
- f(a,c) = v ->
- f(x,gamma) = u ->
- f(x,beta) = v ->
- f(gamma,c) = f(beta,b)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,gamma,beta,x,y: int
-logic ac f : int , int -> int
-
-goal g4 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(x,beta) ->
- f(x,f(gamma,c)) = f(y,f(beta,b))
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g5 :
- f(a+1,a) = f(a,b+1)
-
-
-
-(* status: Unknown *)
-logic a,b,c,x,beta,gamma,d:int
-
-logic ac f : int,int -> int
-
-goal g6 :
- f((f(a,b) + x),c) = gamma ->
- f(a,c) = a ->
- f(a,d) = beta ->
- f(b,beta) = f(d,gamma)
-
-
-
-(* status: Unknown *)
-
-logic ac f : int,int -> int
-goal g7 : forall a,b,c,x:int. c = a + x -> a = f(c,b) -> a=0 -> f(c,b)=c
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g8 :
- f(a+1,a) = f(a+1,b)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g9 :
- a = b ->
- f(a+1,a) = f(a,b)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g10 :
- a + 1 = b + x ->
- x = b ->
- f(a,a) = f(a,b)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g11 :
- f(a,a) = a ->
- f(a,b) + a =a + b->
- a = b
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g12 :
- a + 1 = b + 1 ->
- f(a,a-1) = f(a,b)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-goal g13 :
- 2 * a = 3 * b ->
- f(x,(2/3) * a) = f(b,x)
-
-
-
-(* status: Unknown *)
-
-logic a,b,c,x:int
-logic ac f : int,int -> int
-
-goal g15 :
- f(b,a) = a ->
- f(a,b) + a = a + b
-
-
-
-(* status: Unknown *)
-
-logic ac f : int,int -> int
-
-goal g16 : (forall v,w:int[v,w]. f(v,w) = w) -> (exists v,w:int. v <> w)
-
-*)
\ No newline at end of file
diff --git a/tests/tests_altergo_qualif.split b/tests/tests_altergo_qualif.split
deleted file mode 100644
index 0662db76f..000000000
--- a/tests/tests_altergo_qualif.split
+++ /dev/null
@@ -1,1238 +0,0 @@
-(** cc *)
-
-(* status: Valid *)
-type t
-logic a,b,c,d,e: t
-logic f,h : t -> t
-logic g: t , t -> t
-
-goal g1:
- forall x:t. h(x)=x and g(a,x)=a -> g(g(a,h(x)),x)=a
-
-(* status: Valid *)
-
-type t
-logic a,b,c,d,e,f: t
-
-goal g2:
- a=c and c=e and a<>b and b=d and d=f -> c<>f
-
-(* status: Valid *)
-
-type t
-logic a,b,c,d,e: t
-logic f : t -> t
-logic g,h: t , t -> t
-
-goal g3:
- forall x,y:t. f(f(f(a)))=a and f(f(f(f(f(a)))))=a and g(x,y)=x ->
- h(g(g(x,y),y),a)=h(x,f(a))
-
-(*deactivated
-(* status: Valid *)
-logic P,Q: int -> prop
-logic f: int -> int
-axiom a :
- forall x:int[P(f(x))].
- P(f(x)) -> Q(x)
-goal g4:
- forall a,b,c:int.
- P(a) -> a= f(b) -> a = f(c) ->
- Q(b) and Q(c)
-*)
-
-(*deactivated
-(* status: Valid *)
-logic P : int -> prop
-
-goal g5 : (exists x:int. P(x)) -> exists y:int. P(y)
-*)
-
-(* status: Valid *)
-logic f, g : int -> int
-logic h: int,int -> int
-logic a, b:int
-
-goal g6:
- h(g(a),g(b)) = g(b) ->
- f(h(g(a),g(b))) - f(g(b)) = 0
-
-
-(* status: Valid *)
-
-logic f, g : int -> int
-logic h: int,int -> int
-logic a, b:int
-
-goal g7:
- h(g(a),g(b)) = g(b) ->
- g(f(h(g(a),g(b))) - f(g(b))) = g(0)
-
-
-(* status: Valid *)
-logic h,g,f: int,int -> int
-logic a, b:int
-
-goal g8:
- h(g(a,a),g(b,b)) = g(b,b) ->
- a = b ->
- g(f(h(g(a,a),g(b,b)),b) - f(g(b,b),a),
- f(h(g(a,a),g(b,b)),a) - f(g(b,b),b)) = g(0,0)
-
-(* status: Valid *)
-logic h,g,f: int,int -> int
-logic a, b, c, d:int
-
-goal g8bis:
- h(d,c) = c ->
- a = b ->
- g(f(h(d,c),b) - f(c,a),
- f(h(d,c),a) - f(c,b)) = g(0,0)
-
-(* status: Valid *)
-
-logic h,g,f: int,int -> int
-logic a, b:int
-
-goal g9:
- a = b ->
- g(f(b,b) - f(b,a),
- f(a,b) - f(a,a)) = g(0,0)
-
-
-(* status: Valid *)
-
-logic f: int -> int
-logic a, b:int
-
-goal g10:
- a = b ->
- f(f(a) - f(b)) = f(0)
-
-
-(* status: Valid *)
-
-logic f: int -> int
-logic a, b:int
-
-goal g11:
- a = b ->
- f(f(a) - f(b)) = f(f(b)-f(a))
-
-
-(* status: Valid *)
-
-logic f: int -> int
-logic a, b:int
-
-goal g12:
- a = b ->
- f(0) = f(f(a) - f(b))
-
-
-
-
-
-
-(* ac_empty
- La fonctionnalité à vérifier est que l'algorithme AC(X) implémente bien ses spécifications et que Alt-Ergo est capable de prouver des buts faisant intervenir de l'égalité et des symboles associatifs-commutatifs.
-*)
-
-(*deactivated
-(* status: Valid *)
-logic ac m: int,int -> int
-logic t1,t2,t3,t4,t5,t6,t7,t8:int
-
-goal g1:
- m(m(m(m(m(m(m(t1,t2),t3),t4),t5),t6),t7),t8) =
- m(t1,m(t2,m(t3,m(t4,m(t5,m(t6,m(t7,t8)))))))
-
-
-(* status: Valid *)
-
-logic a, c, x, y, beta, gamma: int
-logic h: int -> int
-logic ac f: int, int -> int
-
-
-goal g2 :
- f(a,h(x)) = gamma ->
- f(a,c) = beta ->
- x = y ->
- f(a,f(h(x),c)) = f(h(y),beta)
-
-
-(* status: Valid *)
-
-type set
-logic ac u: set,set -> set
-
-axiom idem : forall x,X: set. u(u(x,x),X)=u(x,X)
-goal g3: forall r,s,t: set. u(t,u(t,s)) = u(s,t)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g4 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(a,b) = gamma
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-
-goal g5 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g6 :
- gamma = f(a,b)->
- f(a,c) = beta ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g7 :
- f(a,b) = gamma ->
- beta = f(a,c) ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g8 :
- gamma = f(a,b) ->
- beta = f(a,c) ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g9 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g10 :
- gamma = f(a,b)->
- f(a,c) = beta ->
- f(c,gamma) = f(b,beta)
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g11 :
- f(a,b) = gamma ->
- beta = f(a,c) ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g12 :
- gamma = f(a,b) ->
- beta = f(a,c) ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g13 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(b,f(lambda,beta)) = f(f(c,lambda),gamma)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g14 :
- gamma = f(a,b)->
- f(a,c) = beta ->
- f(gamma,f(lambda,f(b,beta))) = f(f(c,gamma),f(lambda,gamma))
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g15 :
- f(a,b) = gamma ->
- beta = f(a,c) ->
- f(f(b,beta),lambda) = f(lambda,f(c,gamma))
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g16 :
- gamma = f(a,b) ->
- beta = f(a,c) ->
- f(lambda,f(b,beta)) = f(c,f(lambda,gamma))
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g17 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(f(c,gamma),lambda) = f(f(lambda,b),beta)
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g18 :
- gamma = f(a,b)->
- f(a,c) = beta ->
- f(lambda,f(c,gamma)) = f(b,f(beta,lambda))
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g19 :
- f(a,b) = gamma ->
- beta = f(a,c) ->
- f(lambda,f(c,gamma)) = f(b,f(lambda,beta))
-
-
-(* status: Valid *)
-
-logic a,b,c, beta,gamma,lambda : int
-logic ac f : int,int -> int
-
-goal g20 :
- gamma = f(a,b) ->
- beta = f(a,c) ->
- f(c,f(gamma,lambda)) = f(f(b,beta),lambda)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g21 :
- a = aa ->
- f(a,b) = gamma ->
- f(aa,c) = beta ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g22 :
- gamma = f(a,b)->
- f(aa,c) = beta ->
- a = aa ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g23 :
- f(a,b) = gamma ->
- beta = f(aa,c) ->
- a = aa ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g24 :
- gamma = f(a,b) ->
- beta = f(aa,c) ->
- a = aa ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g25 :
- f(a,b) = gamma ->
- f(aa,c) = beta ->
- a = aa ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g26 :
- gamma = f(a,b)->
- f(aa,c) = beta ->
- a = aa ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-logic aa,a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g27 :
- f(a,b) = gamma ->
- beta = f(aa,c) ->
- a = aa ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-logic aa, a,b,c, beta,gamma : int
-logic ac f : int,int -> int
-
-goal g28 :
- gamma = f(a,b) ->
- beta = f(aa,c) ->
- a = aa ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g29 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(a,b) = gamma
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g30 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g31 :
- gamma = f(a,b)->
- f(a,c) = beta ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g32 :
- f(a,b) = gamma ->
- beta = f(a,c) ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g33 :
- gamma = f(a,b) ->
- beta = f(a,c) ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g34 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g35 :
- gamma = f(a,b)->
- f(a,c) = beta ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-type a
-
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g36 :
- f(a,b) = gamma ->
- beta = f(a,c) ->
- f(c,gamma) = f(b,beta)
-
-
-(* status: Valid *)
-
-type a
-logic a,b,c, beta,gamma : a
-logic ac f : a,a -> a
-
-goal g37 :
- gamma = f(a,b) ->
- beta = f(a,c) ->
- f(c,gamma) = f(b,beta)
-
-(* status: Valid *)
-
-(* c = beta *)
-logic a,b,c, gamma : int
-logic ac f : int,int -> int
-
-goal g38 :
- c = f(a,c) ->
- f(a,b) = gamma ->
- f(b,c) = f(c,gamma)
-
-
-(* status: Valid *)
-
-(* c = beta *)
-logic a,b,c, gamma : int
-logic ac f : int,int -> int
-
-goal g39 :
- f(a,c) = c ->
- f(a,b) = gamma ->
- f(b,c) = f(c,gamma)
-
-
-(* status: Valid *)
-
-(* gamma |-> b et beta |-> c *)
-logic a, b, c : int
-logic ac f : int,int -> int
-
-goal g40 :
- c = f(a,b) ->
- b = f(a,c) ->
- f(c,c) = f(b,b)
-
-
-(* status: Valid *)
-
-(* gamma |-> b et beta |-> c *)
-logic a, b, c : int
-logic ac f : int,int -> int
-
-goal g41 :
- f(a,b) = c ->
- f(a,c) = b ->
- f(b,b) = f(c,c)
-
-(* status: Valid *)
-
-logic a1, a2, a3, b1, b2, x,y,z ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g42 :
- f(a1,f(a2,f(a3,x))) = gamma ->
- f(b1,f(b2,f(y,z))) = beta -> (* boucle ici*)
- f(a1,f(a2,a3)) = f(b1,b2) ->
- f(gamma,f(y,z)) = f(beta,x)
-
-
-(* status: Valid *)
-
-logic a1, a2, a3, b1, b2, x,y,z ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g43 :
- f(a1,f(a2,f(a3,x))) = gamma ->
- f(b1,f(b2,f(y,z))) = beta -> (* boucle ici*)
- f(a1,f(a2,a3)) = f(b1,b2) ->
- f(gamma,f(y,z)) = f(beta,x)
-
-
-(* status: Valid *)
-
-(* une pc car f(a1,a2,a3) = f(b1,b2)*)
-logic a1, a2, a3, b1, b2, y ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g44 :
- f(a1,f(a2,a3)) = gamma ->
- f(b1,f(b2,y)) = beta -> (* boucle ici*)
- f(b1,b2) = f(a1,f(a2,a3)) ->
- f(gamma,y) = beta
-
-
-(* status: Valid *)
-
-(* pc sur a1 = a1
- ou seulement pc sur f(a1,a2,a3) = f(a1,b2)*)
-logic a1, a2, a3, b1, b2, x,y,z ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g45 :
- f(a1,f(a2,f(a3,x))) = gamma ->
- f(a1,f(b2,f(y,z))) = beta ->
- f(a1,f(a2,a3)) = f(a1,b2) ->
- f(gamma,f(y,z)) = f(beta,x)
-
-
-(* status: Valid *)
-
-(* pc sur a1 = a1
- ou seulement pc sur f(a1,a2,a3) = f(a1,b2)*)
-logic a1, a2, a3, b1, b2, x,y,z ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g46 :
- f(a1,f(a2,f(a3,x))) = gamma ->
- f(a1,f(b2,f(y,z))) = beta ->
- a3 = b2 ->
- f(gamma,f(y,z)) = f(beta,f(a2,x))
-
-
-(* status: Valid *)
-(* pc sur a1 = a1
- ou seulement pc sur f(a1,a2,a3) = f(a1,b2)*)
-logic a1, a11, a2, a3, b1, b2, x,y,z ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g47 :
- f(a1,f(a2,f(a3,x))) = gamma ->
- f(a1,f(b2,f(y,z))) = beta ->
- f(a2,a3) = b2 ->
- f(gamma,f(y,z)) = f(beta,x)
-
-
-(* status: Valid *)
-
-(* pc sur a1 = a1
- ou seulement pc sur f(a1,a2,a3) = f(a1,b2)*)
-
-logic a1, a11, a2, a3, b1, b2, x,y,z ,beta, gamma : int
-logic ac f : int,int -> int
-
-goal g48 :
- f(a1,f(a2,f(a3,x))) = gamma ->
- f(a11,f(b2,f(y,z))) = beta ->
- f(a2,f(a3,a1)) = f(b2,a11) ->
- f(gamma,f(y,z)) = f(beta,x)
-
-
-(* status: Valid *)
-
-logic a,b,c,s : int
-logic g : int -> int
-logic ac f : int,int -> int
-
-goal g49:
- f(b,c) = s ->
- f(g(s),c) = b ->
- f(g(s),s) = f(b,b)
-
-
-(* status: Valid *)
-
-logic a,b,c,s : int
-logic g : int -> int
-logic ac f : int,int -> int
-
-goal g50:
- f(b,c) = s ->
- f(g(s),c) = b ->
- g(s) = s ->
- f(s,s) = f(b,b)
-
-
-(* status: Valid *)
-
-logic a,b,c,gamma,beta,x: int
-logic ac f : int , int -> int
-
-goal g51 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(x,beta) ->
- f(x,f(gamma,c)) = f(x,f(beta,b))
-
-
-(* status: Valid *)
-
-logic a,b,c,gamma,beta,x: int
-logic ac f : int , int -> int
-
-goal g52 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(x,beta) ->
- f(a,f(gamma,c)) = f(a,f(beta,b))
-
-
-(* status: Valid *)
-
-logic a,b,c,gamma,beta,x,y : int
-logic ac f : int , int -> int
-
-goal g53 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(y,beta) ->
- f(x,f(gamma,c)) = f(y,f(beta,b))
-
-
-(* status: Valid *)
-
-logic a,b,x,y,z : int
-logic ac f: int,int -> int
-
-goal g54:
- f(a,x) = f(a,y) ->
- f(a,z) = b ->
- f(z,f(a,y)) = f(x,b) and f(z,f(a,x)) = f(y,b)
-
-
-
-
-
-
-(* status: Valid *)
-
-logic a,b,c,d,x,y,gamma,beta : int
-logic ac f,g:int,int -> int
-
-goal g55 :
- g(x,y) = f(a,b) ->
- f(g(x,y),d) = gamma ->
- f(a,c) = beta ->
- f(gamma,c) = f(beta,f(b,d))
-
-
-(* status: Valid *)
-
-logic a,b,c,x,gamma,beta,delta,omega : int
-logic ac f,g:int,int -> int
-
-goal g56 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- g(x,gamma)= delta ->
- g(x,beta) = omega ->
- g(beta,delta) = g(gamma,omega)
-
-
-(* status: Valid *)
-
-logic a,b,c,x,gamma,beta,delta,omega : int
-logic ac f,g:int,int -> int
-
-goal g57 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- g(x,gamma)= delta ->
- g(x,beta) = omega ->
- f(b,beta) = f(c,gamma)
-
-
-(* status: Valid *)
-
-logic a, b, c, x,y,z : int
-logic ac g : int, int -> int
-
-goal g58:
-
- g(a,b) = g(x,y) ->
- g(a,c)=g(x,z) ->
- g(b,g(x,z)) = g(c,g(x,y))
-
-
-(* status: Valid *)
-
-logic x,y,z,t,b : int
-logic ac f,g : int,int -> int
-
-goal g59:
- f(z,g(y,x)) = t ->
- y = b ->
- f(z,g(x,b)) = t
-
-
-(* status: Valid *)
-
-logic x,y,z,t,gamma,beta : int
-logic ac f,g : int,int -> int
-
-goal g60:
- f(x,g(y,z)) = gamma ->
- f(x,t) = beta ->
- f(gamma,t) = f(beta,g(y,z))
-
-
-(* status: Valid *)
-
-logic b, c,a, d,z, subst : int
-logic ac f : int, int -> int
-logic g : int -> int
-
-goal g61 :
- f(a,c) = a ->
- f(c, g (f (b, c))) = b ->
- g(f (b, c)) = f (b, c) ->
- f(b,b) = f(f(b,c),f(b,c))
-
-
-(* status: Valid *)
-
-logic b, c,a, d,z, s : int
-logic ac f : int, int -> int
-logic g : int -> int
-
-goal g62 :
- f(b,c) = s ->
- f(a,c) = a ->
- f(c,g(s)) = b ->
- g(s) = s ->
- f(b,b) = f(s,s)
-
-
-(* status: Valid *)
-
-logic b, c,a, d,z, s : int
-logic ac f : int, int -> int
-logic g : int -> int
-
-goal g63 :
- f(b,c) = s ->
- f(a,c) = a ->
- f(c,g(s)) = b ->
- g(s) = s ->
- f(b,b) = f(g(s),s)
-
-
-(* status: Valid *)
-
-logic b, c,a, d,z, s : int
-logic ac f : int, int -> int
-logic g : int -> int
-
-goal g64 :
- s = f(b,c) ->
- f(a,c) = a ->
- f(c,g(s)) = b ->
- g(s) = s ->
- f(b,b) = f(s,s)
-
-
-(* status: Valid *)
-
-logic a,b,c :int
-logic ac f :int,int-> int
-
-goal g65 : a = b -> f(c,a) = f(c,b)
-
-
-(* status: Valid *)
-
-logic a, b, c, d, x, y : int
-logic ac g : int, int -> int
-
-goal g66:
- g(x,g(a,b)) = g(c,g(y,d)) ->
- g(g(a,b),g(b,x)) = g(g(c,d),g(y,b))
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,f,g,h,x,y,z,t : int
-logic ac k : int, int -> int
-
-goal g67:
- k(a,b) =x ->
- k(b,g) =y ->
- k(k(a,c),e)=z ->
- k(g,h) =t ->
- k(z,(k(k(t,y),x)))=k(k(a,b),k(k(k(g,e),k(b,k(a,c))),k(h,g)))
-
-
-(* status: Valid *)
-
-logic a, b, c, d, x, y,t : int
-logic ac f : int, int -> int
-
-goal g68 :
- f(a,a) = a ->
- f(a,b) = c ->
- f(f(a,a),b) = a ->
- f(a,f(f(a,a),a)) = f(a,c)
-
-
-(* status: Valid *)
-
-logic a,b,aa,x : int
-logic ac f : int,int -> int
-
-goal g69:
- a = a ->
- b = b ->
- aa = aa ->
- a = aa -> f(a,b) = f(aa,b)
-
-
-(* status: Valid *)
-
-logic a,b,aa,x : int
-logic ac f : int,int -> int
-
-goal g70:
- f(a,b) = x -> a = aa -> a+1=aa+1
-
-
-(* status: Valid *)
-
-logic a,b,aa,x : int
-logic ac f : int,int -> int
-
-goal g71:
- f(a,b) = x -> a = aa -> f(a,b) = f(aa,b) = x
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y:int
-logic ac f,g : int,int -> int
-
-goal g72 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduite *)
- g(f(gamma,c),d) = x ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y:int
-logic ac f,g : int,int -> int
-
-goal g73 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduite *)
- f(f(gamma,c),d) = x ->
- f(f(beta,b),e) = y ->
- f(x,e) = f(y,d)
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y:int
-logic ac f,g : int,int -> int
-
-goal g74 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- (* f(gamma,c) = f(beta,b) est déduit *)
- g(f(f(a,c),b),d) = x ->
- g(f(beta,b),e) = y ->
- g(x,e) = g(y,d)
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta,x,y:int
-logic ac f : int,int -> int
-logic g : int,int -> int
-
-axiom commut : forall x,y:int. g(x,y) = g(y,x)
-goal g75 :
- f(a,b) = gamma ->
- f(a,c) = beta ->
- g(a,f(gamma,c)) = g(f(a,f(c,b)),a)
-
-
-
-(* status: Valid *)
-
-type set
-
-logic a,b :set
-logic ac union : set,set -> set
-
-axiom idem : forall x,X: set. union (union(x,x),X)=union(x,X)
-
-goal g76 : union(a,union(b,a)) = union(a,b)
-
-
-
-(* status: Valid *)
-logic a,b :int
-logic ac f : int,int -> int
-axiom idem : forall x,X: int. f (f(x,x),X)=f(x,X)
-
-goal g77 :
- f(a,f(b,a)) = f(a,b)
-
-
-
-(* status: Valid *)
-
-logic a,b :int
-logic ac f : int,int -> int
-
-axiom idem : forall x,X: int. f (f(x,x),X)=f(x,X)
-
-goal g78 :
- f(f(a,f(a,f(b,a))),f(a,b)) = f(f(a,b),f(b,b))
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,d,beta,gamma : int
-
-goal g79 :
- f(a,b) = gamma -> (* 1 *)
- f(a,d) = beta -> (* 2 *)
- f(a,c) = gamma -> (* 3 *)
- f(b,c) = beta -> (* 4 *)
-
- f(gamma , d) = f(beta , b) (* 1 & 2 *)
-and f(gamma , c) = f(gamma , b) (* 1 & 3 *)
-and f(gamma , c) = f(beta , a) (* 1 & 4 *)
-and f(beta , c) = f(gamma , d) (* 2 & 3 *)
-and true (* 2 & 4 *)
-and f(gamma , b) = f(beta , a) (* 3 & 4 *)
-
-
-(* status: Valid *)
-
-logic a,b,c,d, x, y , beta , gamma : int
-
-logic ac f : int,int -> int
-
-goal g80 :
- (*1*) f(f(a,b),c) = gamma ->
- (*2*) f(a,b) = x ->
- (*3*) f(x,y) = beta ->
- (*4*) f(gamma,y) = f(beta,c)
-
-
-(* status: Valid *)
-
-logic ac f : int,int -> int
-logic a,b,c,beta,gamma : int
-
-goal g81 :
- f(a,f(b,c)) = gamma ->
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(beta,gamma) = f(a,gamma)
-
-
-(* status: Valid *)
-
-logic a,b,c,d,e,gamma,beta:int
-logic ac f,g : int,int -> int
-
-goal g82 :
- f(f(a,a),f(a,b)) = f(f(a,a),b)->
- f(a,b) = gamma ->
- f(a,c) = beta ->
- f(gamma,c) = f(beta,b)
-*)
-
-
-
-
-(*
- case_split
- La fonctionnalité à vérifier est que l'algorithme CC(X) implémente bien ses spécifications et que Alt-Ergo est capable de prouver des buts demandant un raisonnement par analyse par cas.
-*)
-
-(*deactivated
-(* status: Valid *)
-goal g1 : forall x,y,z:int.
- -z <= 0 ->
- 3 * y - 8*x - 6 <= 0 ->
- -y + 12*x +3 <= 0 ->
- y*y*y <= 1
-
-
-(* status: Valid *)
-goal g2 : forall x,y,z:int.
- 3 * y - 8*x - 6 <= 0 ->
- -y + 12*x +3 <= 0 ->
- -y*y*y <= 0 ->
- false
-*)
-
-
-
-
-
-(*
- cc-false
- La fonctionnalité à vérifier est que l'algorithme CC(X) implémente bien ses spécifications et que Alt-Ergo ne prouve pas des buts faux faisant intervenir de l'égalité et des symboles de fonction non interprétés.
-*)
-
-
-(* status: Unknown *)
-type t
-logic a,b,c,d,e: t
-logic f,h : t -> t
-logic g: t , t -> t
-
-goal g1:
- forall x:t. h(x)=x and g(a,x)=a -> g(g(x,g(a,h(x))),x)=a
-
-(* status: Unknown *)
-type t
-logic a,b,c,d,e,f: t
-
-goal g2:
- a=c and c=e and a<>b and b=f and d <> b -> c<>d
-
-(* status: Unknown *)
-type t
-logic a,b,c,d,e: t
-logic f : t -> t
-logic g,h: t , t -> t
-
-goal g3:
- forall x,y:t. f(f(f(a)))=a and f(f(f(f(f(f(a))))))=a and g(x,y)=x ->
- h(g(g(x,y),y),a)=h(x,f(a))
-
-
-(*deactivated
-(* status: Unknown *)
-logic P,Q: int -> prop
-logic f: int -> int
-axiom a :
- forall x:int[P(f(x))].
- P(f(x)) -> Q(x)
-goal g4:
- forall a,b,c:int.
- P(a) -> a= f(b) -> a = f(f(c)) ->
- Q(b) and Q(c)
-*)
-
-
-(*deactivated
-(* ac-false
- La fonctionnalité à vérifier est que l'algorithme AC(X) implémente bien ses spécifications et que Alt-Ergo ne prouve pas des buts faux faisant intervenir de l'égalité et des symboles associatifs-commutatifs.
-*)
-
-(* status: Unknown *)
-
-logic a,b,c,gamma,beta,x : int
-logic ac f : int , int -> int
-
-goal g2 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(x,beta) ->
- f(gamma,c) = f(beta,b)
-*)
-
-(* status: Unknown *)
-
-logic a,b,c,gamma,beta,x,u,v : int
-logic f : int , int -> int
-
-goal g3 :
- f(a,b) = u ->
- f(a,c) = v ->
- f(x,gamma) = u ->
- f(x,beta) = v ->
- f(gamma,c) = f(beta,b)
-
-(*deactivated
-(* status: Unknown *)
-
-logic a,b,c,gamma,beta,x,y: int
-logic ac f : int , int -> int
-
-goal g4 :
- f(a,b) = f(x,gamma) ->
- f(a,c) = f(x,beta) ->
- f(x,f(gamma,c)) = f(y,f(beta,b))
-
-*)
\ No newline at end of file
diff --git a/tests/tests_arith.ml b/tests/tests_arith.ml
deleted file mode 100644
index a4bdb9190..000000000
--- a/tests/tests_arith.ml
+++ /dev/null
@@ -1,206 +0,0 @@
-open OUnit
-
-open Tests_lib
-open Scheduler
-
-let new_env =
- new_env [Variable.th_register; Uninterp.th_register; Arith.th_register]
-
-let register sched cl =
- let d = Scheduler.get_delayed sched in
- Solver.Delayed.register d cl;
- Scheduler.flush_delayed sched
-
-let merge sched cl1 cl2 =
- let d = Scheduler.get_delayed sched in
- Solver.Delayed.merge d Explanation.pexpfact cl1 cl2;
- Scheduler.flush_delayed sched
-
-let is_equal sched cl1 cl2 =
- Scheduler.stop_delayed sched;
- Scheduler.run_inf_step sched;
- let env = Scheduler.get_t sched in
- Solver.is_equal env cl1 cl2
-
-
-let solve0 () =
- let env = new_env () in
- let a = Variable.cst Arith.real "ar" in
- let b = Variable.cst Arith.real "br" in
- let _1 = Arith.cst Q.one in
- let a1 = Arith.add a _1 in
- let b1 = Arith.add b _1 in
- register env a1; register env b1;
- merge env a1 b1;
- assert_bool "a+1 = b+1 => a = b" (is_equal env a b)
-
-let solve1 () =
- let env = new_env () in
- let a,b = Shuffle.seq2 (Variable.cst Arith.real) ("ar","br") in
- let _1 = Arith.cst Q.one in
- let a1 = Arith.add a _1 in
- let b1 = Arith.add b _1 in
- let _2 = Arith.cst (Q.of_int 2) in
- let a2 = Arith.add a _2 in
- let b2 = Arith.add b _2 in
- Shuffle.seql' (register env) [a1; b1; a2; b2];
- merge env a1 b1;
- assert_bool "a+1 = b+1 => a+2 = b+2" (is_equal env a2 b2)
-
-let solve2 () =
- let env = new_env () in
- let a,b = Shuffle.seq2 (Variable.cst Arith.real) ("ar","br") in
- let _1 = Arith.cst Q.one in
- let a1 = Arith.add a _1 in
- let b1 = Arith.add b _1 in
- let _2 = Arith.cst (Q.of_int 2) in
- let a2 = Arith.add a _2 in
- let b2 = Arith.add b _2 in
- Shuffle.seql' (register env) [a1; b1; a2; b2];
- merge env a2 b1;
- assert_bool "a+2 = b+1 => a+1 = b" (is_equal env a1 b)
-
-let solve3 () =
- let env = new_env () in
- let a,b = Shuffle.seq2 (Variable.cst Arith.real) ("ar","br") in
- let _1 = Arith.cst Q.one in
- let b1 = Arith.add b _1 in
- let _2 = Arith.cst (Q.of_int 2) in
- let a2 = Arith.add a _2 in
- let _3 = Arith.cst (Q.of_int 3) in
- Shuffle.seql [
- (fun () ->
- Shuffle.seql' (register env) [b1;a2];
- merge env a2 b1;
- );
- (fun () ->
- Shuffle.seql' (register env) [a;_2];
- merge env a _2;
- );
- (fun () ->
- register env _3;
- );
- ];
- assert_bool "" (not (is_equal env b _2));
- assert_bool "a+2 = b+1 => a = 2 => b = 3" (is_equal env b _3)
-
-
-let solve4 () =
- let env = new_env () in
- let a,b,c =
- Shuffle.seq3 (Variable.cst Arith.real) ("ar","br","cr") in
- let t1 = Arith.cst (Q.of_int 2) in
- let t1 = Arith.add t1 c in
- let t1 = Arith.add a t1 in
- let t1' = (Arith.cst (Q.of_int 1)) in
- let t1' = Arith.add b t1' in
- let t2 = a in
- let t2' = Arith.cst (Q.of_int 2) in
- let t2' = Arith.add t2' b in
- let t3' = Arith.cst (Q.of_int (-3)) in
- Shuffle.seql [
- (fun () ->
- Shuffle.seql' (register env) [t1;t1'];
- merge env t1 t1');
- (fun () ->
- Shuffle.seql' (register env) [t2;t2'];
- merge env t2 t2');
- (fun () -> register env t3');
- ];
- assert_bool "a+(2+c) = b+1 => a = 2 + b => c = -3" (is_equal env c t3')
-
-
-let solve5 () =
- let env = new_env () in
- let a = Variable.cst Arith.real "ar" in
- let b = Variable.cst Arith.real "br" in
- let c = Variable.cst Arith.real "cr" in
- let t1 = Arith.sub b c in
- let t1 = Arith.add a t1 in
- let t1' = (Arith.cst (Q.of_int 2)) in
- let t2 = a in
- let t2' = Arith.cst (Q.of_int 2) in
- let t3 = Arith.add b c in
- let t3' = Arith.add b b in
- Shuffle.seql [
- (fun () ->
- Shuffle.seql' (register env) [t1;t1'];
- merge env t1 t1');
- (fun () ->
- Shuffle.seql' (register env) [t2;t2'];
- merge env t2 t2');
- (fun () ->
- Shuffle.seql' (register env) [t3;t3'];)
- ];
- assert_bool "a+(b-c) = 2 => a = 2 => b + c = 2b" (is_equal env t3 t3')
-
-
-let basic = "Arith.Basic" &: [solve0; solve1; solve2; solve3; solve4; solve5]
-
-let mult0 () =
- let env = new_env () in
- let a = Variable.cst Arith.real "ar" in
- let b = Variable.cst Arith.real "br" in
- let t1 = Arith.sub a b in
- let t1' = Arith.mult a b in
- let t2 = a in
- let t2' = Arith.cst (Q.of_int 1) in
- let t3 = Arith.mult_cst (Q.of_int 2) b in
- let t3' = Arith.cst (Q.of_int 1) in
- Shuffle.seql [
- (fun () ->
- Shuffle.seql' (register env) [t1;t1'];
- merge env t1 t1');
- (fun () ->
- Shuffle.seql' (register env) [t2;t2'];
- merge env t2 t2');
- (fun () ->
- Shuffle.seql' (register env) [t3;t3'];)
- ];
- assert_bool "a - b = a * b -> a = 1 -> 1 = 2b" (is_equal env t3 t3')
-
-(** test that mult normalization trigger the needed solve *)
-let mult1 () =
- let env = new_env () in
- let a = Variable.cst Arith.real "ar" in
- let b = Variable.cst Arith.real "br" in
- let c = Variable.cst Arith.real "cr" in
- let t1 = Arith.mult a b in
- let t1 = Arith.add a t1 in
- let t1' = Arith.add b c in
- let t1' = Arith.mult t1' a in
- let t2 = a in
- let t2' = Arith.cst (Q.of_int 2) in
- let t3 = c in
- let t3' = Arith.cst (Q.of_int 1) in
- Shuffle.seql [
- (fun () ->
- Shuffle.seql' (register env) [t1;t1'];
- merge env t1 t1');
- (fun () ->
- Shuffle.seql' (register env) [t2;t2'];
- merge env t2 t2');
- (fun () ->
- Shuffle.seql' (register env) [t3;t3'];)
- ];
- assert_bool "a + (a * b) = (b + c) * a -> a = 2 -> c = 1"
- (is_equal env t3 t3')
-
-let mult = "Arith.Mult" &: [mult0;mult1]
-
-
-let files = ["tests/tests_altergo_arith.split";
- "tests/tests_popop.split";
- ]
-
-let altergo = TestList (List.map Tests_lib.test_split files)
-
-let smtlib2sat =
- "smtlib2-lra-sat" >:::
- tests_smt2 Popop_of_smtlib2.Sat "tests/smtlib2/lra/sat/"
-
-let smtlib2unsat =
- "smtlib2-lra-unsat" >:::
- tests_smt2 Popop_of_smtlib2.Unsat "tests/smtlib2/lra/unsat/"
-
-let tests = TestList [basic;mult;altergo;smtlib2sat;smtlib2unsat]
diff --git a/tests/tests_arith_uninterp.ml b/tests/tests_arith_uninterp.ml
deleted file mode 100644
index d5ea12d1a..000000000
--- a/tests/tests_arith_uninterp.ml
+++ /dev/null
@@ -1,40 +0,0 @@
-open OUnit
-
-open Tests_lib
-open Scheduler
-
-let theories = [Variable.th_register; Uninterp.th_register; Arith.th_register]
-let run = Scheduler.run_exn ~nodec:() ~theories
-let ($$) f x = f x
-
-let solve6 () =
- let a = Variable.fresh Arith.real "ar" in
- let b = Variable.fresh Arith.real "br" in
- let c = Variable.fresh Arith.real "cr" in
- let f = Uninterp.fun1 Arith.real "fr" in
- let t3 = f c in
- let t3' = f b in
- let env = run $$ fun env ->
- let t1 = Arith.sub b c in
- let t1 = Arith.add a t1 in
- let t1' = Arith.cst (Q.of_int 2) in
- let t2 = a in
- let t2' = Arith.cst (Q.of_int 2) in
- register env t3';
- register env t3;
- register env t1;
- register env t1';
- register env t2;
- register env t2';
- merge env t1 t1';
- merge env t2 t2'
- in
- assert_bool "a+(b-c) = 2 => a = 2 => f b = f c"
- (Solver.Delayed.is_equal env t3 t3')
-
-
-
-let basic = "Arith.Uninterp.Basic" &: [solve6 ]
-
-
-let tests = TestList [basic]
diff --git a/tests/tests_bool.ml b/tests/tests_bool.ml
deleted file mode 100644
index 9f0fcac29..000000000
--- a/tests/tests_bool.ml
+++ /dev/null
@@ -1,85 +0,0 @@
-open OUnit
-
-open Tests_lib
-open Scheduler
-
-let theories = [Variable.th_register; Uninterp.th_register; Bool.th_register]
-
-let run = Scheduler.run_exn ~nodec:() ~theories
-let ($$) f x = f x
-
-let true_is_true () =
- let env = Scheduler.run_exn ~nodec:() ~theories (fun _ -> ()) in
- assert_bool "" (Bool.is_true env Bool._true);
- assert_bool "" (not (Bool.is_false env Bool._true))
-
-let not_true_is_false () =
- let not_true = Bool._not Bool._true in
- let env = run $$ fun env -> Solver.Delayed.register env not_true in
- assert_bool "" (Bool.is_false env not_true);
- assert_bool "" (not (Bool.is_true env not_true))
-
-let and_true_is_true () =
- let _t = Bool._true in
- let _and = Bool._and [_t;_t;_t] in
- let env = run $$ fun env -> Solver.Delayed.register env _and in
- assert_bool "" (Bool.is_true env _and);
- assert_bool "" (not (Bool.is_false env _and))
-
-let or_not_true_is_false () =
- let _f = (Bool._not Bool._true) in
- let _or = Bool._and [_f;_f;_f] in
- let env = run $$ fun env -> Solver.Delayed.register env _or in
- assert_bool "" (Bool.is_false env _or);
- assert_bool "" (not (Bool.is_true env _or))
-
-let merge_true () =
- let a = Variable.fresh Bool.ty "a" in
- let b = Variable.fresh Bool.ty "b" in
- let c = Variable.fresh Bool.ty "c" in
- let d = Variable.fresh Bool.ty "d" in
- let _and = Bool._and [a;b;c] in
- let env = run $$ fun env ->
- Solver.Delayed.register env _and;
- List.iter (Solver.Delayed.register env) [a;b;c;d];
- Shuffle.seql
- [(fun () -> merge env a b);
- (fun () -> merge env a c);
- ];
- merge env a d;
- Bool.set_true env Explanation.pexpfact d;
- in
- assert_bool "" (Bool.is_true env _and)
-
-
-
-let basic = "Bool.Basic" >::: [ "true_is_true" >:: true_is_true;
- "not_true_is_false" >:: not_true_is_false;
- "and_true_is_true" >:: and_true_is_true;
- "or_not_true_is_false" >:: or_not_true_is_false;
- "merge_true" >:: merge_true;
- (* "modus_ponens" >:: modus_ponens; *)
- ]
-
-let tests_dimacs expected dir =
- let files = Sys.readdir dir in
- Array.sort String.compare files;
- let files = Array.to_list files in
- List.map
- (fun s ->
- s >: TestCase (fun () ->
- let res = Dimacs.check_file (Filename.concat dir s) in
- begin match res with
- | Dimacs.Sat -> Debug.dprintf1 Tests_lib.debug "@[%s: Sat@]@\n" s
- | Dimacs.Unsat -> Debug.dprintf1 Tests_lib.debug "@[%s: Unsat@]@\n" s
- end;
- assert_bool s (res = expected);
- )) files
-
-let dimacssat =
- "dimacs-sat" >::: tests_dimacs Dimacs.Sat "tests/dimacs/sat/"
-
-let dimacsunsat =
- "dimacs-unsat" >::: tests_dimacs Dimacs.Unsat "tests/dimacs/unsat/"
-
-let tests = TestList [basic;dimacssat;dimacsunsat]
diff --git a/tests/tests_bv.ml b/tests/tests_bv.ml
deleted file mode 100644
index 16d05329e..000000000
--- a/tests/tests_bv.ml
+++ /dev/null
@@ -1,290 +0,0 @@
-open OUnit
-
-open Scheduler
-open Tests_lib
-
-
-let theories = [Variable.th_register; Bv.th_register]
-
-let run = Scheduler.run_exn ~nodec:() ~theories
-let ($$) f x = f x
-
-let rec propagate_all env = function
- | [] -> ()
- | x::rest -> register env x; propagate_all env rest
-
-let _42 = Z.of_int 42
-let _62 = Z.of_int 62
-let _63 = Z.of_int 63
-
-let tests_pretty_print () =
- (*
- let test_cst cst =
- assert_equal
- ~printer:(fun x -> x)
- ~msg:(Pp.sprintf "test_cst %a" Z.pp_print cst)
- (Z.format "[%b]" cst)
- (Pp.string_of_wnl Bv.D.print {Bv.aun=cst;Bv.azer=cst})
- in
- test_cst Z.zero;
- test_cst _62;
- test_cst _42;
- *)
- let test exp aun azer =
- assert_equal
- ~printer:(fun x -> x)
- exp
- (Pp.string_of_wnl Bv.D.print {Bv.aun;Bv.azer})
- in
- test "[0?]" Z.zero Z.one;
- test "[0]" Z.zero Z.zero ;
- test "[01]" Z.one Z.one ;
- test "[11]" Z.minus_one Z.minus_one;
- test "[?1]" Z.one Z.minus_one;
- test "[0??????]" Z.zero _63;
- test "[0XXXXX0]" _62 Z.zero
-
-let simpleprint var env str =
- let xd = Bv.D.get_dom_bv env Bv.dom var in
- Format.print_string str;
- Bv.D.print Format.std_formatter xd;
- Format.print_string "\n"
-
-type bvtestexp =
-|Tor of bvtestexp * bvtestexp
-|Tand of bvtestexp * bvtestexp
-|Txor of bvtestexp * bvtestexp
-|Tnot of bvtestexp
-|Tsl of bvtestexp * bvtestexp
-|Tsr of bvtestexp * bvtestexp
-|Tcst of int
-|Tvar of string
-|Tcl of Popop.Types.Cl.t
-
-let exmp1 =
- let x = Tvar "x" in
- let y = Tvar "y" in
- [(Tand (x,y), Tcst 0);
- (x,Tnot (Tcst 0))]
-
-let rec testexp_to_test (e: bvtestexp) env =
- match e with
- | Tor (b,c) ->
- let bb = testexp_to_test b env in
- let cc = testexp_to_test c env in
- propagate_all env [bb;cc];
- Bv.bor bb cc
- | Tand (b,c) ->
- let bb = testexp_to_test b env in
- let cc = testexp_to_test c env in
- propagate_all env [bb;cc];
- Bv.band bb cc
- | Txor (b,c) ->
- let bb = testexp_to_test b env in
- let cc = testexp_to_test c env in
- propagate_all env [bb;cc];
- Bv.bxor bb cc
- | Tsl (b,c) ->
- let bb = testexp_to_test b env in
- let cc = testexp_to_test c env in
- propagate_all env [bb;cc];
- Bv.bsl bb cc
- | Tsr(b,c) ->
- let bb = testexp_to_test b env in
- let cc = testexp_to_test c env in
- propagate_all env [bb;cc];
- Bv.bsr bb cc
- | Tnot c ->
- let cc = testexp_to_test c env in
- register env cc;
- Bv.bnot cc
- | Tcst n -> Bv.cnst n
- | Tvar s -> Variable.fresh Bv.ty s
- | Tcl c -> c
-
-let rec constraint_list el env =
- match el with
- | [] -> ()
- | (b,c) :: rest ->
- let bb = testexp_to_test b env in
- let cc = testexp_to_test c env in
- propagate_all env [bb;cc];
- merge env bb cc;
- assert_bool "inside" (is_equal env bb cc);
- constraint_list rest env
-
-let simple_tests num () =
- let x = Variable.fresh Bv.ty "x" in
- let y = Variable.fresh Bv.ty "y" in
- let t = Variable.fresh Bv.ty "t" in
- let z = Variable.fresh Bv.ty "z" in
- let r = Variable.fresh Bv.ty "r" in
- let cl_one = Bv.cnst (-1) in
- let cl_zero = Bv.cnst 0 in
- let initial env = propagate_all env [cl_one; cl_zero;x;y;t;z;r]
- in
- match num with
- | 1 -> (* x = Cst 1 *)
- let env = run $$ fun env ->
- initial env;
- merge env x cl_one
- in
- assert_bool "x = 1 " (is_equal env x cl_one)
-
- | 2 -> (* x|y = 0 *)
- let lside = Bv.bor x y in
- let env = run $$ fun env ->
- initial env;
- propagate_all env [lside];
- merge env lside cl_zero
- in
- assert_bool "x | y = 0" (is_equal env lside cl_zero);
- assert_bool "x = 0" (is_equal env x cl_zero);
- assert_bool "y = 0" (is_equal env y cl_zero)
-
- | 3 -> (* x & y = 1 *)
- let lside = Bv.band x y in
- let env = run $$ fun env ->
- initial env;propagate_all env [lside];
- merge env lside cl_one
- in
- assert_bool "x & y = 1" (is_equal env lside cl_one);
- assert_bool "x = 1" (is_equal env x cl_one);
- assert_bool "y = 1" (is_equal env y cl_one)
-
- | 4 -> (* x & 1 = 0 *)
- let lside = Bv.band x cl_one in
- let env = run $$ fun env ->
- initial env;
- propagate_all env [lside];
- merge env lside cl_zero;
- in
- assert_bool "x & 1 = 0" (is_equal env lside cl_zero);
- assert_bool "x = 0" (is_equal env x cl_zero)
-
- | 5 -> (* x | 0 = 1 *)
- let lside = Bv.bor x cl_zero in
- let env = run $$ fun env ->
- initial env;
- propagate_all env [lside];
- merge env lside cl_one
- in
- assert_bool "x | 0 = 1" (is_equal env lside cl_one);
- assert_bool "x = 1" (is_equal env x cl_one)
-
- | 6 -> (* x = not 0 *)
- let rside = Bv.bnot cl_zero in
- let env = run $$ fun env ->
- initial env;
- register env rside;
- register env cl_zero;
- register env x;
- merge env x rside
- in
- assert_bool "x = ¬ 0" (is_equal env rside x)
-
- | 7 ->
- let _ = run $$ fun env ->
- initial env;
- constraint_list exmp1 env
- in
- ()
- | 8 ->
- let exmp2 =
- [(Tand (Tcl x, Tcl y), Tcst 0);
- (Tcl x,Tnot (Tcst 0))] in
- let env = run $$ fun env ->
- initial env;
- constraint_list exmp2 env
- in
- assert_bool "x = 1" (is_equal env x cl_one);
- assert_bool "y = 0" (is_equal env y cl_zero)
-
- | 9 ->
- (*
- a- z ⊕ 101 = (x & y) | (t & y)
- b- y ⊕ x = 110
- c- t & x = 100
- d- z ⊕ t = 010
- e- t = 100
- *)
- let exmp =
- let x = Tcl x in
- let y = Tcl y in
- let z = Tcl z in
- let t = Tcl t in
- let zxor5 = Txor (z,Tcst 7) in
- let xandy = Tand (x,y) in
- let tandy = Tand (t,y) in
- let yorx = Tor (y, x) in
- let tandx = Tand (t,x) in
- let zxort = Txor (z,t) in
- [(zxor5, Tor (xandy,tandy));
- (yorx, Tcst 7);
- (tandx, Tcst 4);
- (zxort,Tcst 3);
- (t, Tcst 4);
- (x, Tcst 4)
- ] in
- let env = run $$ fun env ->
- initial env;
- constraint_list exmp env;
- in
- assert_bool "x = 100" (is_equal env x (Bv.cnst 4));
- assert_bool "y = 011" (is_equal env y (Bv.cnst 3));
- assert_bool "z = 100" (is_equal env z (Bv.cnst 7));
- assert_bool "t = 100" (is_equal env t (Bv.cnst 4));
- (* simpleprint x env "\nx="; *)
- (* simpleprint y env "y="; *)
- (* simpleprint z env "z="; *)
- (* simpleprint t env "t=" *)
-
- | 10 -> (* 100 >> 2 = r *)
- let exmp = [ Tsr (Tcst 4, Tcst 2), Tcl r] in
- let env = run $$ fun env ->
- initial env;
- constraint_list exmp env
- in
- assert_bool "r = 01" (is_equal env r (Bv.cnst 1));
-
- | 11 -> (* x << 1 = 1010 ==> x = ?101*)
- let exmp =
- [(Tsl (Tcl x, Tcst 1), Tcst 10);
- (Tand (Tcl x, Tcl cl_one), Tcst 5)] in
- let env = run $$ fun env ->
- initial env;
- constraint_list exmp env
- in
- assert_bool "x = 101" (is_equal env x (Bv.cnst 5));
-
- | 12 -> (* x >> 1 = 1010 ==> x = 01010?*)
- let exmp =
- [(Tsr (Tcl x, Tcst 1), Tcst 10);
- (Tor (Tcl x, Tcl cl_zero), Tcst 20)] in
- let env = run $$ fun env ->
- initial env;
- constraint_list exmp env
- in
- assert_bool "x = 10100" (is_equal env x (Bv.cnst 20));
-
- | _ -> failwith "No test by that number in tests_bv.ml"
-
-let rec gen_list seed op =
- match (op seed) with
- | None -> []
- | Some x -> seed :: (gen_list x op)
-
-let incr until seed =
- if seed > until then None
- else Some (seed + 1)
-
-let rec gen_tests = function
- | [] -> []
- | x :: rest ->
- (("Number " ^ (string_of_int x)) >::
- (simple_tests x)) :: gen_tests rest
-
-let basic = "Bv.Basic" >::: ((
- "pretty print" >:: tests_pretty_print) :: (gen_tests (gen_list 1 (incr 12))) )
-
-let tests = TestList[basic]
diff --git a/tests/tests_lib.ml b/tests/tests_lib.ml
deleted file mode 100644
index 68579ba69..000000000
--- a/tests/tests_lib.ml
+++ /dev/null
@@ -1,60 +0,0 @@
-open OUnit
-open Popop
-
-let debug = Debug.register_flag
- ~desc:" Run the test in verbose mode." "ounit"
-
-let test_file s =
- s >::
- fun () ->
- let d = Popop_of_altergo.read_file s in
- assert_bool "" (Popop_of_altergo.Valid = Popop_of_altergo.check_goal d)
-
-
-let test_split s =
- s >::: begin
- let l = Popop_of_altergo.read_split s in
- List.map (fun (res_attended,loc,d) ->
- TestCase (fun () ->
- let s = Pp.string_of_wnl Loc.gen_report_position loc in
- let actual_res =
- Loc.with_this_loc Popop_of_altergo.check_goal loc d in
- let b = (Popop_of_altergo.Valid = actual_res) in
- match res_attended with
- | "Valid" -> assert_bool s b
- | "Unknown" -> assert_bool s (not b)
- | _ -> invalid_arg "Unknown status")
-
- ) l
- end
-
-let tests_smt2 expected dir =
- let files = Sys.readdir dir in
- Array.sort String.compare files;
- let files = Array.to_list files in
- List.map
- (fun s ->
- s >: TestCase (fun () ->
- let cmds = Popop_of_smtlib2.read_file (Filename.concat dir s) in
- let res = Popop_of_smtlib2.check_file cmds in
- Debug.dprintf3 debug "@[%s: %a@]@\n"
- s Popop_of_smtlib2.print_status res;
- assert_bool s (res = expected);
- )) files
-
-let (&:) s l = s >::: (List.map (fun f -> TestCase f) l)
-
-
-let ty_ctr = Types.Ty.Constr.create "a"
-let ty = Types.Ty.ctr ty_ctr
-
-
-let register d cl =
- Solver.Delayed.register d cl;
- Solver.Delayed.flush d
-
-let merge d cl1 cl2 =
- Solver.Delayed.merge d Explanation.pexpfact cl1 cl2;
- Solver.Delayed.flush d
-
-let is_equal = Solver.Delayed.is_equal
diff --git a/tests/tests_popop.split b/tests/tests_popop.split
deleted file mode 100644
index ca05f6f68..000000000
--- a/tests/tests_popop.split
+++ /dev/null
@@ -1,25 +0,0 @@
-(* status: Valid *)
-goal mul0: forall x,y: int. x * y = y * x
-
-(* status: Valid *)
-goal mul0: forall x,y,z,t: int. z = x * y -> t * z - (y * x) * t = 0
-
-(* status: Valid *)
-goal mul0: forall x,y,z,t: int. z = x * y -> t * z - (y * x) * t + 2 = y -> z = 2*x
-
-(* status: Valid *)
-(** Problem with not reaccessing data in invariant after call to theory function *)
-logic f : int -> int
-logic t,u,x,y,z : int
-
-axiom a1: t=f(0)
-axiom a2: u=f(x+y)
-axiom a3: 2*x+2*y=0
-
-goal g22: t=u
-
-(* status: Valid *)
-(** Arith: contraction during merge, expdom needed *)
-logic y,z: int
-
-goal g23: (z + 3 = z + 2 -> y + 1 = y + 2) and (z + 3 = y + 2 -> y + 1 = z + 2)
diff --git a/tests/tests_utils.ml b/tests/tests_utils.ml
deleted file mode 100644
index 21983d56f..000000000
--- a/tests/tests_utils.ml
+++ /dev/null
@@ -1,261 +0,0 @@
-open OUnit
-
-let size = 10
-let size0 = size * 10
-
-module Trace : sig
- type t
- type r
-
- val mk: unit -> t
-
- val int: t -> int -> unit
- val bool: t -> bool -> unit
-
- val result: t -> r
- val equal: r -> r -> bool
-end = struct
- type t = Cryptokit.hash
- type r = string
-
- let mk = Cryptokit.Hash.sha1
-
- let int (t:t) i =
- let int32 t i =
- let add t i = t#add_byte (i land 255); i lsr 8 in
- add t (add t (add t (add t i))) in
- match Sys.word_size with
- | 32 -> ignore (int32 t i)
- | 64 -> ignore (int32 t (int32 t i))
- | _ -> assert false (** absurd: No other possible achitecture supported *)
-
- let bool t b = if b then t#add_byte 1 else t#add_byte 0
-
- let result t = t#result
- let equal = Stdlib.DStr.equal
-
-end
-
-module Patricia = Stdlib.DInt.M
-module Binary = Extmap.Make(Stdlib.DInt)
-module OCaml = Map.Make(Stdlib.DInt)
-
-(** utils *)
-let same_result = function
- | [] -> true
- | a::l ->
- List.for_all (fun b -> Trace.equal a b) l
-
-let run_trace f rnd genmap =
- let tr = Trace.mk () in
- let rnd = Random.State.copy rnd in
- (** todo choose different gen *)
- let iter k d = Trace.int tr k; Trace.int tr d in
- let fold acc k d = Trace.int tr acc; iter k d; (acc + 1) in
- let () = f ~iter ~fold ~rnd tr genmap in
- Trace.result tr
-
-let (!) rnd = (Random.State.int rnd 99999) - 9999
-
-let compare_trace f l =
- let rnd = Random.State.make [|Shuffle.int 1000|] in
- same_result (List.map (run_trace f rnd) l)
-
-let adds ~rnd ~add n empty =
- Util.foldi (fun m _ -> let x = !rnd in add x x m) empty 0 n
-
-let rms ~rnd ~rm n map =
- Util.foldi (fun m _ -> rm (!rnd) m) map 0 n
-
-(** Generic tests *)
-type genmap = (module Map.S with type key = int)
-
-let genmaps : genmap list = [(module Patricia);(module Binary);(module OCaml)]
-
-let empty ~iter ~fold:_ ~rnd:_ _tr (gm : genmap) =
- let module M = (val gm) in
- M.iter iter M.empty
-
-let singleton ~iter ~fold:_ ~rnd _tr (gm : genmap) =
- let module M = (val gm) in
- M.iter iter (M.singleton (!rnd) (!rnd))
-
-let iter ~iter ~fold:_ ~rnd _tr (gm : genmap) =
- let module M = (val gm) in
- M.iter iter (adds ~rnd ~add:M.add size0 M.empty)
-
-let fold ~iter:_ ~fold ~rnd tr (gm : genmap) =
- let module M = (val gm) in
- Trace.int tr (M.fold fold (adds ~rnd ~add:M.add size0 M.empty) 0)
-
-let remove ~iter ~fold:_ ~rnd _tr (gm : genmap) =
- let module M = (val gm) in
- let rnd' = Random.State.copy rnd in
- let m = adds ~rnd ~add:M.add size0 M.empty in
- M.iter iter m;
- let m = rms ~rnd:rnd' ~rm:M.remove size m in
- M.iter iter m
-
-let merge ~iter ~fold:_ ~rnd _tr (gm : genmap) =
- let module M = (val gm) in
- let m1 = adds ~rnd ~add:M.add size0 M.empty in
- let m2 = adds ~rnd ~add:M.add size0 M.empty in
- let merge k d1 d2 =
- let d = k * (Opt.get_def 1 d1) * (Opt.get_def 1 d2) in
- if d mod 2 = 0 then None else Some (d / 2) in
- M.iter iter (M.merge merge m1 m2)
-
-let test f () =
- assert_bool "compare" (compare_trace f genmaps)
-
-let gen = ["empty" >:: test empty;
- "singleton" >:: test singleton;
- "iter" >:: test iter;
- "fold" >:: test fold;
- "remove" >:: test remove;
- "merge" >:: test merge;
- ]
-
-(** Extended tests *)
-type 'a pint = int
-module type MapII = sig
- type 'a data
- include Map_intf.Map with type key = int and type 'a data := 'a pint
-end
-type extmap = (module MapII)
-
-
-
-module Int = struct
- include Stdlib.DInt
- let tag x = x
- end
-
-module Pat = Intmap.Make(Int)
-module HPat = Pat.Make(Int)
-
-
-let extmaps : extmap list = [(module Patricia);(module Binary);(module HPat)]
-
-let empty ~iter ~fold:_ ~rnd:_ tr (gm : extmap) =
- let module M = (val gm) in
- assert_bool "check_invariant" (M.check_invariant M.empty);
- M.iter iter M.empty
-
-let singleton ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let m = M.singleton (!rnd) (!rnd) in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-let iter ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let m = adds ~rnd ~add:M.add size0 M.empty in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-let fold ~iter:_ ~fold ~rnd tr (gm : extmap) =
- let module M = (val gm) in
- let m = adds ~rnd ~add:M.add size0 M.empty in
- assert_bool "check_invariant" (M.check_invariant m);
- Trace.int tr (M.fold fold m 0)
-
-let remove ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let rnd' = Random.State.copy rnd in
- let m = adds ~rnd ~add:M.add size0 M.empty in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m;
- let m = rms ~rnd:rnd' ~rm:M.remove size m in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-let merge ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let m1 = adds ~rnd ~add:M.add size0 M.empty in
- let m2 = adds ~rnd ~add:M.add size0 M.empty in
- let merge k d1 d2 =
- let d = k * (Opt.get_def 1 d1) * (Opt.get_def 1 d2) in
- if d mod 2 = 0 then None else Some (d / 2) in
- let m = M.merge merge m1 m2 in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-
-let union ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let m1 = adds ~rnd ~add:M.add size0 M.empty in
- let m2 = adds ~rnd ~add:M.add size M.empty in
- let m3 = adds ~rnd ~add:M.add size0 M.empty in
- let m1' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m1 m2 in
- let m2' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m3 m2 in
- let union k d1 d2 =
- let d = k * d1 * d2 in
- if d mod 2 = 0 then None else Some (d / 2) in
- let m = M.union union m1' m2' in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-let inter ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let m1 = adds ~rnd ~add:M.add size0 M.empty in
- let m2 = adds ~rnd ~add:M.add size M.empty in
- let m3 = adds ~rnd ~add:M.add size0 M.empty in
- let m1' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m1 m2 in
- let m2' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m3 m2 in
- let inter k d1 d2 =
- let d = k * d1 * d2 in
- if d mod 2 = 0 then None else Some (d / 2) in
- let m = M.inter inter m1' m2' in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-
-let union_merge ~iter ~fold:_ ~rnd _tr (gm : extmap) =
- let module M = (val gm) in
- let m1 = adds ~rnd ~add:M.add size0 M.empty in
- let m2 = adds ~rnd ~add:M.add size M.empty in
- let m3 = adds ~rnd ~add:M.add size0 M.empty in
- let m1' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m1 m2 in
- let m2' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m3 m2 in
- let union k d1 d2 =
- let d = k * (Opt.get_def 1 d1) * d2 in
- if d mod 2 = 0 then None else Some (d / 2) in
- let m = M.union_merge union m1' m2' in
- assert_bool "check_invariant" (M.check_invariant m);
- M.iter iter m
-
-
-let disjoint ~iter:_ ~fold:_ ~rnd tr (gm : extmap) =
- let module M = (val gm) in
- let m1 = adds ~rnd ~add:M.add (size0 * 10) M.empty in
- let m2 = adds ~rnd ~add:M.add (size * 10) M.empty in
- let m3 = adds ~rnd ~add:M.add (size0 * 10) M.empty in
- let m1' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m1 m2 in
- let m2' = M.union (fun _ d1 d2 -> Some (d1 + d2)) m3 m2 in
- let disjoint _ d1 d2 = not ((d1 - d2) mod (size0 * 10) = 0) in
- Trace.bool tr (M.disjoint disjoint m1' m2');
- let disjoint _ _ _ = false in
- Trace.bool tr (M.disjoint disjoint m1' m2')
-
-let disjointe ~iter:_ ~fold:_ ~rnd tr (gm : extmap) =
- let module M = (val gm) in
- Trace.bool tr (M.set_disjoint M.empty M.empty)
-
-let test f () =
- assert_bool "compare" (compare_trace f extmaps)
-
-let ext = ["empty" >:: test empty;
- "singleton" >:: test singleton;
- "iter" >:: test iter;
- "fold" >:: test fold;
- "remove" >:: test remove;
- "merge" >:: test merge;
- "union" >:: test union;
- "inter" >:: test inter;
- "union_merge" >:: test union_merge;
- "disjoint" >:: test disjoint;
- "disjointe" >:: test disjointe;
- ]
-
-let tests = "Map" >::: gen@ext
diff --git a/witan.opam b/witan.opam
new file mode 100644
index 000000000..003c44222
--- /dev/null
+++ b/witan.opam
@@ -0,0 +1,42 @@
+opam-version: "1.2"
+name: "witan"
+license: "LGPL v3"
+version: "dev"
+author: ["François Bobot" "Guillaume Bury" "Simon Cruanes" "Stéphane Graham-Lengrand"]
+maintainer: ["guillaume.bury@gmail.com"]
+build: [
+ [make "build-install"]
+]
+build-doc: [
+ [make "doc"]
+]
+build-test: [
+ [make "test"]
+]
+install: [
+ [make "install"]
+]
+remove: [
+ [make "uninstall"]
+]
+depends: [
+ "containers" {>= "2.1"}
+ "dolmen"
+ "spelll"
+ "cmdliner"
+ "gen"
+ "jbuilder" {build}
+ "zarith"
+ "ppx_deriving" { > "4.1.5" }
+ "ppx_optcomp"
+ "ocamlgraph"
+ "ocaml-migrate-parsetree"
+ "ounit" {test}
+]
+available: [
+ ocaml-version >= "4.03.0"
+]
+tags: [ "sat" "smt" "mcsat" ]
+homepage: "https://github.com/Gbury/witan"
+dev-repo: "https://github.com/Gbury/witan.git"
+bug-reports: "https://github.com/Gbury/witan/issues/"
--
GitLab