From 1cf614694bbe3e36798b7b101d8850424b2e92e5 Mon Sep 17 00:00:00 2001 From: OCamlPro-mattiasdrp Date: Wed, 27 May 2020 18:11:59 +0200 Subject: [PATCH 01/68] examples and initial draft report --- examples/smt2/arith/arith1.smt2 | 5 + examples/smt2/array/array1.smt2 | 10 ++ examples/smt2/bool/bool1.smt2 | 8 ++ examples/smt2/bool/bool2.ae | 4 + examples/smt2/rapport.md | 196 ++++++++++++++++++++++++++++++++ examples/smt2/uf/uf1.smt2 | 8 ++ src/bin/common/parse_command.ml | 4 +- 7 files changed, 233 insertions(+), 2 deletions(-) create mode 100644 examples/smt2/arith/arith1.smt2 create mode 100644 examples/smt2/array/array1.smt2 create mode 100644 examples/smt2/bool/bool1.smt2 create mode 100644 examples/smt2/bool/bool2.ae create mode 100644 examples/smt2/rapport.md create mode 100644 examples/smt2/uf/uf1.smt2 diff --git a/examples/smt2/arith/arith1.smt2 b/examples/smt2/arith/arith1.smt2 new file mode 100644 index 000000000..12c26b179 --- /dev/null +++ b/examples/smt2/arith/arith1.smt2 @@ -0,0 +1,5 @@ +(set-logic ALL) +(declare-const x Int) +(assert (not (<= x 42))) +(check-sat) +(get-model) diff --git a/examples/smt2/array/array1.smt2 b/examples/smt2/array/array1.smt2 new file mode 100644 index 000000000..70553bca1 --- /dev/null +++ b/examples/smt2/array/array1.smt2 @@ -0,0 +1,10 @@ +(declare-const x Int) +(declare-const y Int) +(declare-const z Int) +(declare-const a1 (Array Int Int)) +(declare-const a2 (Array Int Int)) +(declare-const a3 (Array Int Int)) +(assert (= (select a1 x) x)) +(assert (= (store a1 x y) a1)) +(check-sat) +(get-model) diff --git a/examples/smt2/bool/bool1.smt2 b/examples/smt2/bool/bool1.smt2 new file mode 100644 index 000000000..13d24d109 --- /dev/null +++ b/examples/smt2/bool/bool1.smt2 @@ -0,0 +1,8 @@ +(set-logic QF_UF) +(set-option :produce-models true) ; enable model generation +(declare-const p Bool) +(declare-const q Bool) +(assert (!(=> (not p) q) :named ass1)) +(check-sat) +(get-model) +(exit) diff --git a/examples/smt2/bool/bool2.ae b/examples/smt2/bool/bool2.ae new file mode 100644 index 000000000..6d069ee8a --- /dev/null +++ b/examples/smt2/bool/bool2.ae @@ -0,0 +1,4 @@ +logic x : bool +logic y : bool +goal g: + ("model:":x) and ("model:":y) diff --git a/examples/smt2/rapport.md b/examples/smt2/rapport.md new file mode 100644 index 000000000..d7fd2634c --- /dev/null +++ b/examples/smt2/rapport.md @@ -0,0 +1,196 @@ +Expériences menées sur z3, cvc4 et alt-ergo pour la génération de modèle en cas de SAT + +- z3 : `z3 fichier.smt2` + - le fichier doit contenir `(get-model)` après chaque `(check-sat)` dont on veut un modèle + - l'option `produce-models` doit être à `true` (comportement par défaut) et peut l'être avec la commande `(set-option :produce-models true)` +- cvc4 : `cvc4 --produce-models fichier.smt2` +- alt-ergo : + - `alt-ergo -mdefault --sat-solver Tableaux fichier.smt2` (fonctionne uniquement si les termes sont étiquetés par `"model:"` mais n'affiche que le dernier terme étiqueté, visiblement) + - `alt-ergo -mcomplete --sat-solver Tableaux fichier.smt2` (affiche le premier modèle complet trouvé) + - `alt-ergo -mall --sat-solver Tableaux fichier.smt2` (affiche l'ensemble des modèles complets trouvés, déclenche une assertion failure de temps en temps) + - `alt-ergo --interpretation 1 --sat-solver Tableaux fichier.smt2` (déclenche un calcul de modèle et l'affiche à la fin de l'exécution) + - `alt-ergo --interpretation 2 --sat-solver Tableaux fichier.smt2` (déclenche un calcul de modèle à chaque tour d'instantiation d'axiome) + - `alt-ergo --interpretation 3 --sat-solver Tableaux fichier.smt2` (déclenche un calcul de modèle à chaque décision booléenne dans le solveur SAT) + +Premier exemple: + +``` +(set-logic QF_UF) +(set-option :produce-models true) ; enable model generation +(declare-const p Bool) +(declare-const q Bool) +(assert (!(=> (not p) q) :named ass1)) +(check-sat) +(get-model) +(exit) +``` + +`z3 examples/smt2/bool/bool1.smt2` : + +``` +sat +(model + (define-fun p () Bool + false) + (define-fun q () Bool + true) +) +``` + +`cvc4 examples/smt2/bool/bool1.smt2` : + +``` +sat +(model +(define-fun p () Bool false) +(define-fun q () Bool true) +(define-fun ass1 () Bool true) +) +``` + +`./alt-ergo examples/smt2/bool/bool1.smt2 --sat-solver Tableaux -mcomplete` + +``` +;[Warning] (set-option not yet supported) +;[Warning] (get-model not yet supported) +; File "examples/smt2/bool/bool1.smt2", line 6, characters 1-12:I don't know (0.0072) (1 steps) (goal g) +unknown + +Model + +Propositional: + true + p + +Theory: + p = FT:[true] + true <> false + +Relation: +``` + +`./alt-ergo examples/smt2/bool/bool1.smt2 --sat-solver Tableaux -mall` + +``` +;[Warning] (set-option not yet supported) +;[Warning] (get-model not yet supported) +--- SAT model found --- + true + p +--- / SAT model --- +--- SAT model found --- + true + q + (not p) +--- / SAT model --- +Fatal error: exception File "src/lib/reasoners/fun_sat.ml", line 1641, characters 6-12: Assertion failed +``` + +`z3 examples/smt2/uf/uf1.smt2` : + +``` +sat +(model + (define-fun a () Int + 21) + (define-fun b () Int + 22) + (define-fun f ((x!0 Int)) Int + 1) +) +``` + +`./alt-ergo examples/smt2/uf/uf1.smt2 --sat-solver Tableaux -mcomplete` +``` +;[Warning] (get-model not yet supported) +; File "examples/smt2/uf/uf1.smt2", line 7, characters 1-12:I don't know (0.0072) (3 steps) (goal g) +unknown + +Model + +Propositional: + true + (1 = f(10)) + (a <= (b - 1)) + (20 <= (a - 1)) + +Theory: + f(10) = X1(arith):[1 [int]] + true <> false + +Relation: +``` + +`./alt-ergo examples/smt2/uf/uf1.smt2 --sat-solver Tableaux -mall` + +``` +;[Warning] (get-model not yet supported) +--- SAT model found --- + true + (1 = f(10)) + (a <= (b - 1)) + (20 <= (a - 1)) +--- / SAT model --- +; File "examples/smt2/uf/uf1.smt2", line 7, characters 1-12:I don't know (0.0057) (3 steps) (goal g) +unknown +``` + +`z3 examples/smt2/array/array1.smt2` + +``` +sat +(model + (define-fun y () Int + 0) + (define-fun a1 () (Array Int Int) + (store ((as const (Array Int Int)) 1) 0 0)) + (define-fun x () Int + 0) + (define-fun z () Int + 0) + (define-fun a2 () (Array Int Int) + ((as const (Array Int Int)) 0)) + (define-fun a3 () (Array Int Int) + ((as const (Array Int Int)) 0)) +) +``` + +`./alt-ergo examples/smt2/array/array1.smt2 --sat-solver Tableaux -mcomplete` + +``` +;[Warning] (get-model not yet supported) +; File "examples/smt2/array/array1.smt2", line 9, characters 1-12:I don't know (0.0072) (3 steps) (goal g) +unknown + +Model + +Propositional: + true + (a1 = a1[x<-y]) + (x = a1[x]) + +Theory: + a1[x<-y][x] = a1[x] = x = FT:[y] + a1[x<-y] = FT:[a1] + true <> false + +Relation: + a1[x<-y][x] ∈ ]-inf;+inf[ + a1[x] ∈ ]-inf;+inf[ + x ∈ ]-inf;+inf[ + y ∈ ]-inf;+inf[ +``` + +`./alt-ergo examples/smt2/array/array1.smt2 --sat-solver Tableaux -mall` + + +``` +;[Warning] (get-model not yet supported) +--- SAT model found --- + true + (a1 = a1[x<-y]) + (x = a1[x]) +--- / SAT model --- +; File "examples/smt2/array/array1.smt2", line 9, characters 1-12:I don't know (0.0067) (3 steps) (goal g) +unknown +``` diff --git a/examples/smt2/uf/uf1.smt2 b/examples/smt2/uf/uf1.smt2 new file mode 100644 index 000000000..6fcd42afe --- /dev/null +++ b/examples/smt2/uf/uf1.smt2 @@ -0,0 +1,8 @@ +(declare-fun f (Int) Int) +(declare-fun a () Int) ; a is a constant +(declare-const b Int) ; syntax sugar for (declare-fun b () Int) +(assert (> a 20)) +(assert (> b a)) +(assert (= (f 10) 1)) +(check-sat) +(get-model) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index fdb9b091e..6b80ceb41 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -1093,13 +1093,13 @@ let parse_sat_opt = Arg.(value & flag & info ["no-sat-learning"] ~docs ~doc) in let no_tableaux_cdcl_in_instantiation = - let doc = "When satML is used, this disables the use of a tableaux-like\ + let doc = "When satML is used, this disables the use of a tableaux-like \ method for instantiations with the CDCL solver." in Arg.(value & flag & info ["no-tableaux-cdcl-in-instantiation"] ~docs ~doc) in let no_tableaux_cdcl_in_theories = - let doc = "When satML is used, this disables the use of a tableaux-like\ + let doc = "When satML is used, this disables the use of a tableaux-like \ method for theories with the CDCL solver." in Arg.(value & flag & info ["no-tableaux-cdcl-in-theories"] ~docs ~doc) in From ef69040b5bd4ab1d65a492d552aca1d8769e6ee9 Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Sun, 27 Dec 2020 17:55:24 +0100 Subject: [PATCH 02/68] attempt to fix CI: Seq dep missing to compile lib_usage test file --- rsc/extra/test_lib.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rsc/extra/test_lib.sh b/rsc/extra/test_lib.sh index 6ef1283ce..fcd771711 100755 --- a/rsc/extra/test_lib.sh +++ b/rsc/extra/test_lib.sh @@ -23,7 +23,7 @@ echo "content of lib == $x" # Compile the lib_usage caml file cd $git_repo/examples ocamlfind ocamlopt -linkpkg -package \ - stdlib-shims,num,zarith,ocplib-simplex,psmt2-frontend,unix,str,zip,dynlink,cmdliner \ + stdlib-shims,num,zarith,ocplib-simplex,psmt2-frontend,unix,str,zip,dynlink,cmdliner,seq \ -o lib_usage \ -I $lib_path AltErgoLib.cmxa \ lib_usage.ml From 8191b229309153109c83d06dce7abc40dd14c7ed Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 9 Oct 2020 09:57:30 +0200 Subject: [PATCH 03/68] change version to models --- alt-ergo-lib.opam | 2 +- alt-ergo-parsers.opam | 2 +- alt-ergo.opam | 2 +- altgr-ergo.opam | 2 +- dune-project | 2 +- src/lib/util/version.ml | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/alt-ergo-lib.opam b/alt-ergo-lib.opam index e90d5eced..ac75bcc3f 100644 --- a/alt-ergo-lib.opam +++ b/alt-ergo-lib.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "dev" +version: "models" synopsis: "The Alt-Ergo SMT prover library" description: """ This is the core library used in the Alt-Ergo SMT solver. diff --git a/alt-ergo-parsers.opam b/alt-ergo-parsers.opam index 295a78d12..6a2237fde 100644 --- a/alt-ergo-parsers.opam +++ b/alt-ergo-parsers.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "dev" +version: "models" synopsis: "The Alt-Ergo SMT prover parser library" description: """ This is the parser library used in the Alt-Ergo SMT solver. diff --git a/alt-ergo.opam b/alt-ergo.opam index f32a4eb31..a7068ad5b 100644 --- a/alt-ergo.opam +++ b/alt-ergo.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "dev" +version: "models" synopsis: "The Alt-Ergo SMT prover" description: """ Alt-Ergo is an automatic theorem prover of mathematical formulas. It was developed at LRI, and is now maintained at OCamlPro. diff --git a/altgr-ergo.opam b/altgr-ergo.opam index 6574ccd3b..445412c70 100644 --- a/altgr-ergo.opam +++ b/altgr-ergo.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "dev" +version: "models" synopsis: "The GUI for the Alt-Ergo SMT prover" description: """ Altgr-Ergo is the graphical interface for the Alt-Ergo SMT prover. diff --git a/dune-project b/dune-project index ecb144523..b4018f328 100644 --- a/dune-project +++ b/dune-project @@ -5,7 +5,7 @@ (generate_opam_files true) (name alt-ergo) -(version dev) +(version models) (authors "Alt-Ergo developers") (maintainers "Alt-Ergo developers") (source (github OCamlPro/alt-ergo)) diff --git a/src/lib/util/version.ml b/src/lib/util/version.ml index 67710c686..30d76e9e5 100644 --- a/src/lib/util/version.ml +++ b/src/lib/util/version.ml @@ -29,7 +29,7 @@ (* WARNING: a "cut" is performed on the following file in the Makefile. DO NOT CHANGE its format *) -let _version="dev" +let _version="models" let _release_commit = "(not released)" From 201986ea016ea1e06ed386f37accb7b920c0bfd7 Mon Sep 17 00:00:00 2001 From: OCamlPro-mattiasdrp Date: Thu, 28 May 2020 15:35:48 +0200 Subject: [PATCH 04/68] models generation: add some examples --- examples/smt2/arith/arith1.ae | 2 ++ examples/smt2/arith/arith1.smt2 | 2 +- examples/smt2/arith/arith2.smt2 | 6 ++++++ examples/smt2/bool/bool1.smt2 | 11 +++++++++-- examples/smt2/bool/bool2.ae | 4 ++-- examples/smt2/bool/bool2.smt2 | 7 +++++++ src/lib/structures/expr.ml | 2 +- 7 files changed, 28 insertions(+), 6 deletions(-) create mode 100644 examples/smt2/arith/arith1.ae create mode 100644 examples/smt2/arith/arith2.smt2 create mode 100644 examples/smt2/bool/bool2.smt2 diff --git a/examples/smt2/arith/arith1.ae b/examples/smt2/arith/arith1.ae new file mode 100644 index 000000000..9374e14ca --- /dev/null +++ b/examples/smt2/arith/arith1.ae @@ -0,0 +1,2 @@ +logic x : int +goal g : ("model:":x) < 42 diff --git a/examples/smt2/arith/arith1.smt2 b/examples/smt2/arith/arith1.smt2 index 12c26b179..aaab4262a 100644 --- a/examples/smt2/arith/arith1.smt2 +++ b/examples/smt2/arith/arith1.smt2 @@ -1,5 +1,5 @@ (set-logic ALL) (declare-const x Int) -(assert (not (<= x 42))) +(assert (<= x 42)) (check-sat) (get-model) diff --git a/examples/smt2/arith/arith2.smt2 b/examples/smt2/arith/arith2.smt2 new file mode 100644 index 000000000..ebb7fe0b3 --- /dev/null +++ b/examples/smt2/arith/arith2.smt2 @@ -0,0 +1,6 @@ +(set-logic ALL) +(declare-const x Int) +(declare-const y Int) +(assert (and (<= x 42) (>= x 0) (>= y 42) (= (+ x y) 50))) +(check-sat) +(get-model) diff --git a/examples/smt2/bool/bool1.smt2 b/examples/smt2/bool/bool1.smt2 index 13d24d109..9f690aa59 100644 --- a/examples/smt2/bool/bool1.smt2 +++ b/examples/smt2/bool/bool1.smt2 @@ -1,8 +1,15 @@ (set-logic QF_UF) -(set-option :produce-models true) ; enable model generation +; (set-option :produce-models true) ; enable model generation (declare-const p Bool) (declare-const q Bool) -(assert (!(=> (not p) q) :named ass1)) +; (declare-const t Int) +(define-fun nq () Bool q) +(assert (=> (not p) (not nq))) (check-sat) (get-model) +(get-assignment) +(assert q) +(check-sat) +(get-model) +(get-assignment) (exit) diff --git a/examples/smt2/bool/bool2.ae b/examples/smt2/bool/bool2.ae index 6d069ee8a..5d5b3e45c 100644 --- a/examples/smt2/bool/bool2.ae +++ b/examples/smt2/bool/bool2.ae @@ -1,4 +1,4 @@ logic x : bool logic y : bool -goal g: - ("model:":x) and ("model:":y) +goal g2: + ("model:":(x and ("model:":y))) diff --git a/examples/smt2/bool/bool2.smt2 b/examples/smt2/bool/bool2.smt2 new file mode 100644 index 000000000..ae6d3fff7 --- /dev/null +++ b/examples/smt2/bool/bool2.smt2 @@ -0,0 +1,7 @@ +(set-logic QF_UF) +(declare-const x Bool) +(declare-const y Bool) +(assert (or x (not x))) +(check-sat) +(get-model) +(get-assignment) diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index c03b99624..e349f89f5 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -640,7 +640,7 @@ let add_label = let add_aux lbl t = Labels.replace labels t lbl in fun lbl e -> match e with - | { f = Sy.Form _; _ } -> () + | { f = Sy.Form _; _ } -> (* add_aux lbl e *) assert false | { f = Sy.Lit _; _ } | { ty = Ty.Tbool; _ } -> add_aux lbl e; add_aux lbl (neg e) From 3659aa714a5a7a5d5c558d0033c7d3c97acc2e13 Mon Sep 17 00:00:00 2001 From: OCamlPro-mattiasdrp Date: Wed, 10 Jun 2020 14:51:43 +0200 Subject: [PATCH 05/68] parent f3ad875887004a069e3e9d9e2f906f2f9dfa040f author OCamlPro-mattiasdrp 1591793503 +0200 committer OCamlPro-mattiasdrp 1593523267 +0200 Rebase from next --- examples/smt2/arith/arith1.ae | 7 ++++++- examples/smt2/array/array1.smt2 | 2 -- examples/smt2/uf/uf1.smt2 | 8 +++----- src/parsers/native_lexer.mll | 3 ++- src/parsers/native_parser.mly | 8 +++++--- 5 files changed, 16 insertions(+), 12 deletions(-) diff --git a/examples/smt2/arith/arith1.ae b/examples/smt2/arith/arith1.ae index 9374e14ca..e336834c0 100644 --- a/examples/smt2/arith/arith1.ae +++ b/examples/smt2/arith/arith1.ae @@ -1,2 +1,7 @@ logic x : int -goal g : ("model:":x) < 42 +logic f : int -> int + +(*axiom A1: forall x:int. f(x) < 100*) + +check_sat g : + x <= 42 and x >= 0 and f(x) >= 42 and x + f(x) = 50 diff --git a/examples/smt2/array/array1.smt2 b/examples/smt2/array/array1.smt2 index 70553bca1..5de38ab1d 100644 --- a/examples/smt2/array/array1.smt2 +++ b/examples/smt2/array/array1.smt2 @@ -1,9 +1,7 @@ (declare-const x Int) (declare-const y Int) -(declare-const z Int) (declare-const a1 (Array Int Int)) (declare-const a2 (Array Int Int)) -(declare-const a3 (Array Int Int)) (assert (= (select a1 x) x)) (assert (= (store a1 x y) a1)) (check-sat) diff --git a/examples/smt2/uf/uf1.smt2 b/examples/smt2/uf/uf1.smt2 index 6fcd42afe..dc47d8fc3 100644 --- a/examples/smt2/uf/uf1.smt2 +++ b/examples/smt2/uf/uf1.smt2 @@ -1,8 +1,6 @@ (declare-fun f (Int) Int) -(declare-fun a () Int) ; a is a constant -(declare-const b Int) ; syntax sugar for (declare-fun b () Int) -(assert (> a 20)) -(assert (> b a)) -(assert (= (f 10) 1)) +(declare-const a Int) +(declare-const b Int) +(assert (= (f a) (f b))) (check-sat) (get-model) diff --git a/src/parsers/native_lexer.mll b/src/parsers/native_lexer.mll index 198f28097..39bb7297b 100644 --- a/src/parsers/native_lexer.mll +++ b/src/parsers/native_lexer.mll @@ -54,7 +54,8 @@ "false" , FALSE; "forall" , FORALL; "function" , FUNC; - "goal" , GOAL; + "check_valid", CHECK_VALID; + "check_sat" , CHECK_SAT; "if" , IF; "in" , IN; "int" , INT; diff --git a/src/parsers/native_parser.mly b/src/parsers/native_parser.mly index 503964496..76dce939b 100644 --- a/src/parsers/native_parser.mly +++ b/src/parsers/native_parser.mly @@ -44,7 +44,7 @@ %token AND LEFTARROW RIGHTARROW AC AT AXIOM CASESPLIT REWRITING %token BAR HAT %token BOOL COLON COMMA PV DISTINCT DOT SHARP ELSE OF EOF EQUAL -%token EXISTS FALSE VOID FORALL FUNC GE GOAL GT CHECK CUT +%token EXISTS FALSE VOID FORALL FUNC GE CHECK_VALID CHECK_SAT GT CHECK CUT %token IF IN INT BITV MAPS_TO %token LE LET LEFTPAR LEFTSQ LEFTBR LOGIC LRARROW XOR LT MINUS %token NOT NOTEQ OR PERCENT PLUS PRED PROP @@ -147,9 +147,12 @@ decl: | REWRITING name = ident COLON body = list1_lexpr_sep_pv { mk_rewriting ($startpos, $endpos) name body } -| GOAL name = ident COLON body = lexpr +| CHECK_VALID name = ident COLON body = lexpr { mk_goal ($startpos, $endpos) name body } +| CHECK_SAT name = ident COLON body = lexpr + { mk_goal ($startpos, $endpos) name (mk_not ($startpos, $endpos) body) } + theory_elts: | /* */ { [] } | th_elt = theory_elt th_rest = theory_elts { th_elt :: th_rest } @@ -553,4 +556,3 @@ list1_string_sep_comma: named_ident: | id = ID { id, "" } | id = ID str = STRING { id, str } - From 65579f1e6aa38065c1361c7a5c0c1d6667c678bd Mon Sep 17 00:00:00 2001 From: OCamlPro-mattiasdrp Date: Thu, 2 Jul 2020 20:12:28 +0200 Subject: [PATCH 06/68] check sat handled on the lowest possible level, need to work on unsat instead of valid as a result --- examples/smt2/bool/bool2.ae | 14 +++- src/bin/common/solving_loop.ml | 2 +- src/bin/gui/annoted_ast.ml | 9 ++- src/lib/frontend/parsed_interface.ml | 3 +- src/lib/frontend/parsed_interface.mli | 1 + src/lib/frontend/typechecker.ml | 11 ++- src/lib/structures/parsed.ml | 103 ++++++++++++++++++++++++++ src/lib/structures/parsed.mli | 3 + src/lib/structures/typed.ml | 5 +- src/lib/structures/typed.mli | 4 +- src/parsers/native_lexer.mll | 5 +- src/parsers/native_parser.mly | 2 +- 12 files changed, 146 insertions(+), 16 deletions(-) diff --git a/examples/smt2/bool/bool2.ae b/examples/smt2/bool/bool2.ae index 5d5b3e45c..53fd360a8 100644 --- a/examples/smt2/bool/bool2.ae +++ b/examples/smt2/bool/bool2.ae @@ -1,4 +1,10 @@ -logic x : bool -logic y : bool -goal g2: - ("model:":(x and ("model:":y))) +logic x: bool +logic y: bool +goal ga1: x and y +goal ga2: x and not x +goal go1: x or y +goal go2: x or not x +check_sat ga1: x and y +check_sat ga2: x and not x +check_sat go1: x or y +check_sat go2: x or not x diff --git a/src/bin/common/solving_loop.ml b/src/bin/common/solving_loop.ml index 2813c7b08..2a42d08ec 100644 --- a/src/bin/common/solving_loop.ml +++ b/src/bin/common/solving_loop.ml @@ -87,7 +87,7 @@ let main () = begin match kind with | Typed.Check | Typed.Cut -> { state with local = []; } - | _ -> { state with global = []; local = []; } + | Typed.Thm | Typed.Sat -> { state with global = []; local = []; } end | Typed.TAxiom (_, s, _, _) when Typed.is_global_hyp s -> let cnf = Cnf.make state.global td in diff --git a/src/bin/gui/annoted_ast.ml b/src/bin/gui/annoted_ast.ml index a8ccf5277..b9a648747 100644 --- a/src/bin/gui/annoted_ast.ml +++ b/src/bin/gui/annoted_ast.ml @@ -824,7 +824,8 @@ let rec print_typed_decl fmt td = match td.Typed.c with fprintf fmt "axiom %s : %a" s print_tform tf | TRewriting (_, s, rwtl) -> fprintf fmt "rewriting %s : %a" s print_rwt_list rwtl - | TGoal (_, Thm, s, tf) -> fprintf fmt "goal %s : %a" s print_tform tf + | TGoal (_, Thm, s, tf) -> fprintf fmt "check valid %s : %a" s print_tform tf + | TGoal (_, Sat, s, tf) -> fprintf fmt "check sat %s : %a" s print_tform tf | TGoal (_, Check, s, tf) -> fprintf fmt "check %s : %a" s print_tform tf | TGoal (_, Cut, s, tf) -> fprintf fmt "cut %s : %a" s print_tform tf | TLogic (_, ls, ty) -> @@ -1837,7 +1838,11 @@ let rec add_atyped_decl errors (buffer:sbuffer) ?(indent=0) ?(tags=[]) d = | _ -> AFop (AOPnot, [aaform]) in let goal_str = - match gs with Thm -> "goal" | Check -> "check" | Cut -> "cut" in + match gs with + | Thm -> "check valid" + | Sat -> "check sat" + | Check -> "check" + | Cut -> "cut" in let tags = d.tag :: d.ptag :: tags in append_buf buffer ~tags (sprintf "%s %s :" goal_str s); append_buf buffer "\n"; diff --git a/src/lib/frontend/parsed_interface.ml b/src/lib/frontend/parsed_interface.ml index f43949d84..d955f96bb 100644 --- a/src/lib/frontend/parsed_interface.ml +++ b/src/lib/frontend/parsed_interface.ml @@ -70,6 +70,8 @@ let mk_non_ground_predicate_def loc named_ident args expr = let mk_goal loc name expr = Goal (loc, name, expr) +let mk_check_sat loc name expr = + Check_sat (loc, name, expr) (** Declaration of theories, generic axioms and rewriting rules **) @@ -315,4 +317,3 @@ let mk_algebraic_test loc expr cstr = let mk_algebraic_project loc ~guarded expr cstr = mk_localized loc (PPproject (guarded, expr, cstr)) - diff --git a/src/lib/frontend/parsed_interface.mli b/src/lib/frontend/parsed_interface.mli index 8c393dc1e..5b44e4b70 100644 --- a/src/lib/frontend/parsed_interface.mli +++ b/src/lib/frontend/parsed_interface.mli @@ -50,6 +50,7 @@ val mk_non_ground_predicate_def : val mk_goal : Loc.t -> string -> lexpr -> decl +val mk_check_sat : Loc.t -> string -> lexpr -> decl (** Declaration of theories, generic axioms and rewriting rules **) diff --git a/src/lib/frontend/typechecker.ml b/src/lib/frontend/typechecker.ml index aee6ca085..a124cac0d 100644 --- a/src/lib/frontend/typechecker.ml +++ b/src/lib/frontend/typechecker.ml @@ -1958,9 +1958,9 @@ let type_goal acc env_g loc sort n goal = let rec type_and_intro_goal acc env sort n f = - let b = (* smtfile() || smt2file() || satmode()*) false in + (* let b = (\* smtfile() || smt2file() || satmode()*\) false in *) let axioms, (goal, env_g) = - intro_hypothesis env (not b) f in + intro_hypothesis env (match sort with Sat -> false | _ -> true) f in let loc = f.pp_loc in let acc = List.fold_left @@ -1993,6 +1993,7 @@ let type_one_th_decl env e = | Logic (loc, _, _, _) | Rewriting(loc, _, _) | Goal(loc, _, _) + | Check_sat(loc, _, _) | Predicate_def(loc,_,_,_) | Function_def(loc,_,_,_,_) | TypeDecl ((loc, _, _, _)::_) @@ -2210,6 +2211,12 @@ let rec type_decl (acc, env) d assertion_stack = let f = alpha_renaming_env env f in type_and_intro_goal acc env Thm n f, env + | Check_sat(_loc, n, f) -> + Options.tool_req 1 "TR-Typing-CheckSatDecl$_F$"; + (*let f = move_up f in*) + let f = alpha_renaming_env env f in + type_and_intro_goal acc env Sat n f, env + | Predicate_def(loc,n,l,e) | Function_def(loc,n,l,_,e) -> check_duplicate_params l; diff --git a/src/lib/structures/parsed.ml b/src/lib/structures/parsed.ml index 56f129ca0..a09df76cf 100644 --- a/src/lib/structures/parsed.ml +++ b/src/lib/structures/parsed.ml @@ -37,15 +37,53 @@ type constant = | ConstFalse | ConstVoid +let pp_const fmt = + let open Format in + function + | ConstBitv s -> fprintf fmt "%s" s + | ConstInt s -> fprintf fmt "%s" s + | ConstReal v -> fprintf fmt "%s" (Num.string_of_num v) + | ConstTrue -> fprintf fmt "true" + | ConstFalse -> fprintf fmt "false" + | ConstVoid -> fprintf fmt "void" + type pp_infix = | PPand | PPor | PPxor | PPimplies | PPiff | PPlt | PPle | PPgt | PPge | PPeq | PPneq | PPadd | PPsub | PPmul | PPdiv | PPmod | PPpow_int | PPpow_real +let pp_inf_op fmt = + let open Format in + function + | PPand -> fprintf fmt "and" + | PPor -> fprintf fmt "or" + | PPxor -> fprintf fmt "xor" + | PPimplies -> fprintf fmt "implies" + | PPiff -> fprintf fmt "iff" + | PPlt -> fprintf fmt "lt" + | PPle -> fprintf fmt "le" + | PPgt -> fprintf fmt "gt" + | PPge -> fprintf fmt "ge" + | PPeq -> fprintf fmt "eq" + | PPneq -> fprintf fmt "neq" + | PPadd -> fprintf fmt "add" + | PPsub -> fprintf fmt "sub" + | PPmul -> fprintf fmt "mul" + | PPdiv -> fprintf fmt "div" + | PPmod -> fprintf fmt "mod" + | PPpow_int -> fprintf fmt "pow_int" + | PPpow_real -> fprintf fmt "pow_real" + type pp_prefix = | PPneg | PPnot +let pp_pre_op fmt = + let open Format in + function + | PPneg -> fprintf fmt "-" + | PPnot -> fprintf fmt "not" + type ppure_type = | PPTint | PPTbool @@ -99,6 +137,70 @@ and pp_desc = | PPisConstr of lexpr * string | PPproject of bool * lexpr * string +let rec pp_lexpr fmt {pp_desc; _} = + let open Format in + match pp_desc with + | PPvar s -> + fprintf fmt "%s" s + | PPapp (s, lel) -> + fprintf fmt "%s %a" s (pp_print_list pp_lexpr) lel + | PPmapsTo (s, le) -> + fprintf fmt "[%s -> %a]" s pp_lexpr le + | PPinInterval (le, b1, le1, le2, b2) -> + fprintf fmt "%a in %c %a, %a %c" + pp_lexpr le + (if b1 then ']' else '[') + pp_lexpr le1 + pp_lexpr le2 + (if b2 then ']' else '[') + | PPdistinct lel -> + fprintf fmt "distincts (%a)" (pp_print_list pp_lexpr) lel + | PPconst c-> + fprintf fmt "%a" pp_const c + | PPinfix (le1, op, le2) -> + fprintf fmt "(%a %a %a)" pp_lexpr le1 pp_inf_op op pp_lexpr le2 + | PPprefix (op, le) -> + fprintf fmt "%a %a" pp_pre_op op pp_lexpr le + | PPget (arr, ind) -> + fprintf fmt "%a[%a]" pp_lexpr arr pp_lexpr ind + | PPset (arr, ind, v) -> + fprintf fmt "%a[%a] <- %a" pp_lexpr arr pp_lexpr ind pp_lexpr v + | PPdot (le, s) -> + fprintf fmt "%a.%s" pp_lexpr le s + | PPrecord l -> + fprintf fmt "{%a}" + (pp_print_list (fun fmt (s, le) -> fprintf fmt "%s = %a" s pp_lexpr le)) l + | PPwith (le, l) -> + fprintf fmt "{%a with %a}" pp_lexpr le + (pp_print_list (fun fmt (s, le) -> fprintf fmt "%s = %a" s pp_lexpr le)) l + | PPextract (le1, le2, le3) -> + fprintf fmt "Extract (%a, %a, %a)" pp_lexpr le1 pp_lexpr le2 pp_lexpr le3 + | PPconcat (le1, le2) -> + fprintf fmt "%a^%a" pp_lexpr le1 pp_lexpr le2 + | PPif (cond, bthen, belse) -> + fprintf fmt "if %a then %a else %a" + pp_lexpr cond pp_lexpr bthen pp_lexpr belse + | _ -> assert false + (* Used for an experiment so not complete but will be completed *) + (* | PPforall of + * (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr + * | PPexists of + * (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr + * | PPforall_named of + * (string * string * ppure_type) list * (lexpr list * bool) list * + * lexpr list * lexpr + * | PPexists_named of + * (string * string * ppure_type) list * (lexpr list * bool) list * + * lexpr list * lexpr + * | PPnamed of string * lexpr + * | PPlet of (string * lexpr) list * lexpr + * | PPcheck of lexpr + * | PPcut of lexpr + * | PPcast of lexpr * ppure_type + * | PPmatch of lexpr * (pattern * lexpr) list + * | PPisConstr of lexpr * string + * | PPproject of bool * lexpr * string *) + (* Declarations. *) type plogic_type = @@ -118,6 +220,7 @@ type decl = | Axiom of Loc.t * string * Util.axiom_kind * lexpr | Rewriting of Loc.t * string * lexpr list | Goal of Loc.t * string * lexpr + | Check_sat of Loc.t * string * lexpr | Logic of Loc.t * Symbols.name_kind * (string * string) list * plogic_type | Predicate_def of Loc.t * (string * string) * diff --git a/src/lib/structures/parsed.mli b/src/lib/structures/parsed.mli index 8cc767d57..2b9776fcd 100644 --- a/src/lib/structures/parsed.mli +++ b/src/lib/structures/parsed.mli @@ -96,6 +96,8 @@ and pp_desc = | PPisConstr of lexpr * string | PPproject of bool * lexpr * string +val pp_lexpr : Format.formatter -> lexpr -> unit + (* Declarations. *) type plogic_type = @@ -115,6 +117,7 @@ type decl = | Axiom of Loc.t * string * Util.axiom_kind * lexpr | Rewriting of Loc.t * string * lexpr list | Goal of Loc.t * string * lexpr + | Check_sat of Loc.t * string * lexpr | Logic of Loc.t * Symbols.name_kind * (string * string) list * plogic_type | Predicate_def of Loc.t * (string * string) * diff --git a/src/lib/structures/typed.ml b/src/lib/structures/typed.ml index 13b48e548..5c973beb9 100644 --- a/src/lib/structures/typed.ml +++ b/src/lib/structures/typed.ml @@ -151,12 +151,13 @@ let print_rwt pp fmt r = (** Goal sort *) -type goal_sort = Cut | Check | Thm +type goal_sort = Cut | Check | Thm | Sat let print_goal_sort fmt = function | Cut -> Format.fprintf fmt "cut" | Check -> Format.fprintf fmt "check" | Thm -> Format.fprintf fmt "thm" + | Sat -> Format.fprintf fmt "sat" (** Logic type *) @@ -331,7 +332,7 @@ and print_formula fmt f = fprintf fmt "if %a then %a else %a" print_formula cond print_formula f1 print_formula f2 | TFop(op, [f1; f2]) -> - fprintf fmt "%a %s %a" print_formula f1 (string_of_op op) print_formula f2 + fprintf fmt "(%a %s %a)" print_formula f1 (string_of_op op) print_formula f2 | TFforall { qf_bvars = l; qf_triggers = t; qf_form = f; _ } -> fprintf fmt "forall %a [%a]. %a" print_binders l print_triggers t print_formula f diff --git a/src/lib/structures/typed.mli b/src/lib/structures/typed.mli index ea03e419e..ac6352bce 100644 --- a/src/lib/structures/typed.mli +++ b/src/lib/structures/typed.mli @@ -243,7 +243,9 @@ type goal_sort = | Check (** Check if some intermediate assertion is prouvable *) | Thm - (** The goal to be proved *) + (** The goal to be proved valid *) + | Sat + (** The goal to be proved satisfiable *) (** Goal sort. Used in typed declarations. *) val fresh_hypothesis_name : goal_sort -> string diff --git a/src/parsers/native_lexer.mll b/src/parsers/native_lexer.mll index 39bb7297b..af7005914 100644 --- a/src/parsers/native_lexer.mll +++ b/src/parsers/native_lexer.mll @@ -45,6 +45,8 @@ "bool" , BOOL; "case_split" , CASESPLIT; "check" , CHECK; + "check_sat" , CHECK_SAT; + "check_valid", CHECK_VALID; "cut" , CUT; "distinct" , DISTINCT; "else" , ELSE; @@ -54,8 +56,7 @@ "false" , FALSE; "forall" , FORALL; "function" , FUNC; - "check_valid", CHECK_VALID; - "check_sat" , CHECK_SAT; + "goal" , CHECK_VALID; "if" , IF; "in" , IN; "int" , INT; diff --git a/src/parsers/native_parser.mly b/src/parsers/native_parser.mly index 76dce939b..da483746c 100644 --- a/src/parsers/native_parser.mly +++ b/src/parsers/native_parser.mly @@ -151,7 +151,7 @@ decl: { mk_goal ($startpos, $endpos) name body } | CHECK_SAT name = ident COLON body = lexpr - { mk_goal ($startpos, $endpos) name (mk_not ($startpos, $endpos) body) } + { mk_check_sat ($startpos, $endpos) name body } theory_elts: | /* */ { [] } From 65856901277b8f4f89b719d7f1ca603730380708 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Tue, 1 Sep 2020 11:13:31 +0200 Subject: [PATCH 07/68] first prototype for models in Why3, lots of hard coded stuff that needs to be well understood before making it work for every case --- src/bin/common/input_frontend.ml | 2 +- src/bin/common/parse_command.ml | 20 +++- src/bin/common/solving_loop.ml | 1 - src/bin/text/main_text.ml | 3 + src/lib/dune | 2 +- src/lib/frontend/frontend.ml | 12 +- src/lib/frontend/input.ml | 3 +- src/lib/frontend/input.mli | 4 +- src/lib/models/models.ml | 26 +++++ src/lib/models/populate.ml | 17 +++ src/lib/reasoners/shostak.ml | 6 +- src/lib/reasoners/uf.ml | 185 +++++++++++++++++++++---------- src/lib/structures/parsed.ml | 85 ++++++++++---- src/lib/structures/parsed.mli | 4 + src/lib/util/options.ml | 5 +- src/lib/util/options.mli | 8 +- 16 files changed, 279 insertions(+), 104 deletions(-) create mode 100644 src/lib/models/models.ml create mode 100644 src/lib/models/populate.ml diff --git a/src/bin/common/input_frontend.ml b/src/bin/common/input_frontend.ml index 60c835fed..20ee92ff4 100644 --- a/src/bin/common/input_frontend.ml +++ b/src/bin/common/input_frontend.ml @@ -15,7 +15,7 @@ open AltErgoParsers (* === LEGACY input method === *) let register_legacy () = - let module M : Input.S = struct + let module M : Input.S with type parsed = Parsed.decl = struct (* Parsing *) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 6b80ceb41..8646cdf2d 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -286,6 +286,7 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation `Ok() let mk_output_opt interpretation model unsat_core output_format + why3_counterexample = set_infer_output_format output_format; let output_format = match output_format with @@ -296,6 +297,7 @@ let mk_output_opt interpretation model unsat_core output_format set_model model; set_unsat_core unsat_core; set_output_format output_format; + set_why3_counterexample why3_counterexample; `Ok() let mk_profiling_opt cumulative_time_profiling profiling @@ -377,10 +379,10 @@ let mk_sat_opt get_bottom_classes disable_flat_formulas_simplification `Ok() | `Error m -> `Error (false, m) -let mk_term_opt disable_ites inline_lets rewriting term_like_pp +let mk_term_opt disable_ites inline_lets rewriting no_term_like_pp = set_rewriting rewriting; - set_term_like_pp term_like_pp; + set_term_like_pp (not no_term_like_pp); set_disable_ites disable_ites; set_inline_lets inline_lets; `Ok() @@ -919,6 +921,11 @@ let parse_output_opt = let doc = "Experimental support for computing and printing unsat-cores." in Arg.(value & flag & info ["u"; "unsat-core"] ~doc) in + let why3_counterexample = + let doc = "Experimental support for computing and printing \ + counter-examples for Why3." in + Arg.(value & flag & info ["w"; "why3-ce"] ~doc) in + let output_format = let doc = Format.sprintf @@ -937,7 +944,8 @@ let parse_output_opt = in Term.(ret (const mk_output_opt $ - interpretation $ model $ unsat_core $ output_format + interpretation $ model $ unsat_core $ + output_format $ why3_counterexample )) let parse_profiling_opt = @@ -1148,12 +1156,12 @@ let parse_term_opt = let doc = "Use rewriting instead of axiomatic approach." in Arg.(value & flag & info ["rwt"; "rewriting"] ~docs ~doc) in - let term_like_pp = + let no_term_like_pp = let doc = "Output semantic values as terms." in - Arg.(value & flag & info ["term-like-pp"] ~docs ~doc) in + Arg.(value & flag & info ["no-term-like-pp"] ~docs ~doc) in Term.(ret (const mk_term_opt $ - disable_ites $ inline_lets $ rewriting $ term_like_pp + disable_ites $ inline_lets $ rewriting $ no_term_like_pp )) let parse_theory_opt = diff --git a/src/bin/common/solving_loop.ml b/src/bin/common/solving_loop.ml index 2a42d08ec..52e763471 100644 --- a/src/bin/common/solving_loop.ml +++ b/src/bin/common/solving_loop.ml @@ -127,7 +127,6 @@ let main () = Printer.print_err "%a" Errors.report e; exit 1 in - let all_used_context = FE.init_all_used_context () in if Options.get_timelimit_per_goal() then FE.print_status FE.Preprocess 0; diff --git a/src/bin/text/main_text.ml b/src/bin/text/main_text.ml index cddc3b72a..d5e7d3969 100644 --- a/src/bin/text/main_text.ml +++ b/src/bin/text/main_text.ml @@ -45,3 +45,6 @@ let () = AltErgoLib.Printer.init_output_format (); Signals_profiling.init_signals (); Solving_loop.main () + + (* let fun_decls = Seq.filter (function Parsed.Function_def _ -> true | _ -> false) parsed in *) + Models.sorts parsed; diff --git a/src/lib/dune b/src/lib/dune index 91399d1e2..f0ce31441 100644 --- a/src/lib/dune +++ b/src/lib/dune @@ -37,7 +37,7 @@ Polynome Records Records_rel Satml_frontend_hybrid Satml_frontend Satml Sat_solver Sat_solver_sig Sig Sig_rel Theory Uf Use ; structures - Commands Errors Explanation Fpa_rounding + Commands Errors Explanation Fpa_rounding Models Parsed Profiling Satml_types Symbols Expr Var Ty Typed Xliteral ; util diff --git a/src/lib/frontend/frontend.ml b/src/lib/frontend/frontend.ml index 04db3410b..b72133bc6 100644 --- a/src/lib/frontend/frontend.ml +++ b/src/lib/frontend/frontend.ml @@ -311,13 +311,15 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout (Some d) -> - let loc = d.st_loc in - Printer.print_status_timeout ~validity_mode - (Some loc) (Some time) (Some steps) (get_goal_name d); + if not (Options.get_why3_counterexample ()) then + let loc = d.st_loc in + Printer.print_status_timeout ~validity_mode + (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout None -> - Printer.print_status_timeout ~validity_mode - None (Some time) (Some steps) None; + if not (Options.get_why3_counterexample ()) then + Printer.print_status_timeout ~validity_mode + None (Some time) (Some steps) None; | Preprocess -> Printer.print_status_preprocess ~validity_mode diff --git a/src/lib/frontend/input.ml b/src/lib/frontend/input.ml index 0de01f09a..37f3cfc22 100644 --- a/src/lib/frontend/input.ml +++ b/src/lib/frontend/input.ml @@ -15,7 +15,7 @@ module type S = sig (* Parsing *) - type parsed + type parsed = Parsed.decl val parse_file : content:string -> format:string option -> parsed Seq.t @@ -41,4 +41,3 @@ let register name ((module M : S) as m) = let find name = try List.assoc name !input_methods with Not_found -> raise (Method_not_registered name) - diff --git a/src/lib/frontend/input.mli b/src/lib/frontend/input.mli index 90ea3ef12..eaf6c07fc 100644 --- a/src/lib/frontend/input.mli +++ b/src/lib/frontend/input.mli @@ -31,7 +31,7 @@ module type S = sig (** {5 Parsing} *) - type parsed + type parsed = Parsed.decl (** The type of a parsed statement. *) val parse_file : content:string -> format:string option -> parsed Seq.t @@ -59,5 +59,3 @@ val register : string -> (module S) -> unit val find : string -> (module S) (** Find an input method by name. @raise Method_not_registered if the name is not registered. *) - - diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml new file mode 100644 index 000000000..694fc23a7 --- /dev/null +++ b/src/lib/models/models.ml @@ -0,0 +1,26 @@ +module Sorts = Map.Make(String) + +let h = ref Sorts.empty + +let sorts parsed = + let open Parsed in + Format.eprintf "@["; + Seq.iter (fun d -> match d with + | Parsed.Axiom (_, _, _, le) -> begin + match le.pp_desc with + | PPapp("sort", f) + | PPforall_named (_, _, _, {pp_desc = PPapp("sort", f); _}) -> + begin + match f with + | [{pp_desc = PPapp(t, _); _}; {pp_desc = PPapp(f, args); _}] -> + h := Sorts.add f (List.length args, t) !h + | _ -> () + end + | _ -> () + end + | _ -> () + ) parsed + +let get_type s = + try let (_, t) = Sorts.find s !h in Some t + with Not_found -> None diff --git a/src/lib/models/populate.ml b/src/lib/models/populate.ml new file mode 100644 index 000000000..9c1ff1b1c --- /dev/null +++ b/src/lib/models/populate.ml @@ -0,0 +1,17 @@ +module Sorts = Map.Make(String) + +let sorts parsed = + let open Parsed in + Seq.iter (fun d -> match d with + | Axiom (_, _, _, { + pp_desc = + PPapp("sort", [ + {pp_desc = PPapp(t, []); _}; + {pp_desc=PPapp(f, []); _} + ]); _ + }) -> + Format.eprintf "@{sort: %s : %s@}@ " f t + | _ -> () + (* Format.eprintf "blah@." *) + ) parsed; + Format.eprintf "@]@."; diff --git a/src/lib/reasoners/shostak.ml b/src/lib/reasoners/shostak.ml index 8f04107bf..8c9951c2e 100644 --- a/src/lib/reasoners/shostak.ml +++ b/src/lib/reasoners/shostak.ml @@ -379,7 +379,7 @@ struct open Printer let print fmt r = - if get_term_like_pp () then + if get_term_like_pp () then begin match r.v with | X1 t -> fprintf fmt "%a" X1.print t | X2 t -> fprintf fmt "%a" X2.print t @@ -390,7 +390,8 @@ struct | X7 t -> fprintf fmt "%a" X7.print t | Term t -> fprintf fmt "%a" Expr.print t | Ac t -> fprintf fmt "%a" AC.print t - else + end + else begin match r.v with | X1 t -> fprintf fmt "X1(%s):[%a]" X1.name X1.print t | X2 t -> fprintf fmt "X2(%s):[%a]" X2.name X2.print t @@ -401,6 +402,7 @@ struct | X7 t -> fprintf fmt "X7(%s):[%a]" X7.name X7.print t | Term t -> fprintf fmt "FT:[%a]" Expr.print t | Ac t -> fprintf fmt "Ac:[%a]" AC.print t + end let print_sbt msg sbs = let c = ref 0 in diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index c83d72e7b..125ca218a 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1098,6 +1098,8 @@ module Profile = struct let iter = P.iter + let fold = P.fold + let empty = P.empty let is_empty = P.is_empty @@ -1112,6 +1114,13 @@ module SMT2LikeModelOutput = struct let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr + let x_print_why3 fmt (_ , ppr) = + fprintf fmt "%s" + (match ppr with + | "True" -> "true" + | "False" -> "false" + | _ -> ppr) + let print_args fmt l = match l with | [] -> assert false @@ -1122,70 +1131,115 @@ module SMT2LikeModelOutput = struct List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l let print_symb ty fmt f = - match f, ty with - | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> - fprintf fmt "%a__%s" Sy.print f (Hstring.view name) - - | _ -> Sy.print fmt f - - let output_constants_model cprofs = - (*printf "; constants:@.";*) - Profile.iter - (fun (f, _xs_ty, ty) st -> - match Profile.V.elements st with - | [[], rep] -> - (*printf " (%a %a) ; %a@." - (print_symb ty) f x_print rep Ty.print ty*) - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "(%a %a)@ " (print_symb ty) f x_print rep - | _ -> assert false - )cprofs - - let output_functions_model fprofs = - if not (Profile.is_empty fprofs) then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - (*printf "@.; functions:@.";*) + match f, ty with + | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> + fprintf fmt "%a__%s" Sy.print f (Hstring.view name) + + | _ -> Sy.print fmt f + + let output_constants_model cprofs = + (*printf "; constants:@.";*) Profile.iter (fun (f, _xs_ty, ty) st -> - (*printf " ; fun %a : %a -> %a@." - (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) - Profile.V.iter - (fun (xs, rep) -> - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "((%a %a) %a)@ " - (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one x) xs; - )st; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; - ) fprofs; - Printer.print_fmt (get_fmt_mdl ()) "@]"; - end - - let output_arrays_model arrays = - if not (Profile.is_empty arrays) then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - (*printf "; arrays:@.";*) + match Profile.V.elements st with + | [[], rep] -> + (*printf " (%a %a) ; %a@." + (print_symb ty) f x_print rep Ty.print ty*) + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) + "(s(%d): %a, rep: %a)@ " (List.length _xs_ty) (print_symb ty) f x_print rep + | _ -> assert false + ) cprofs + + let pp_type fmt t = + let open Ty in + Format.fprintf fmt "%s" (match t with + | Tint -> "Int" + | Treal -> "Real" + | Tbool -> "Bool" + | Text (_, t) -> Hstring.view t + | _ -> asprintf "%a" print t + ) + + let get_qtmk f qtmks = + try Models.Sorts.find f qtmks + with Not_found -> f + + let output_constants_why3_counterexample cprofs fprofs = + (* Models.Sorts.iter (fun f (nbargs, t) -> + * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !Models.h; *) + Printer.print_fmt ~flushed:false (get_fmt_mdl()) "@[(model@,"; + let qtmks = Profile.fold + (fun (f, _xs_ty, ty) st acc -> + Profile.V.fold + (fun (xs, rep) acc -> + let s = asprintf "%a" (print_symb ty) f in + let rep = asprintf "%a" x_print rep in + match Models.get_type s, Models.get_type rep with + | Some ts, Some tr when String.equal ts tr -> + Models.Sorts.add + rep (Format.asprintf "(%s %a)" s print_args xs) + acc + | _ -> acc; + ) st acc; + ) fprofs Models.Sorts.empty in Profile.iter - (fun (f, xs_ty, ty) st -> - match xs_ty with - [_] -> - (*printf " ; array %a : %a -> %a@." - (print_symb ty) f Ty.print tyi Ty.print ty;*) + (fun (f, _xs_ty, ty) st -> + match Profile.V.elements st with + | [[], rep] -> + let rep = Format.asprintf "%a" x_print_why3 rep in + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) + "(define-fun %a () %a %s)@ " + (print_symb ty) f pp_type ty (get_qtmk rep qtmks) + | _ -> assert false + ) cprofs + + let output_functions_model fprofs = + if not (Profile.is_empty fprofs) then begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; + (*printf "@.; functions:@.";*) + Profile.iter + (fun (f, _xs_ty, ty) st -> + (*printf " ; fun %a : %a -> %a@." + (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; Profile.V.iter (fun (xs, rep) -> Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "((%a %a) %a)@ " + "((s: %a, args: %a) rep: %a)@ " (print_symb ty) f print_args xs x_print rep; List.iter (fun (_,x) -> assert_has_depth_one x) xs; )st; Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; - | _ -> assert false + ) fprofs; + Printer.print_fmt (get_fmt_mdl ()) "@]"; + end - ) arrays; - Printer.print_fmt (get_fmt_mdl ()) "@]"; - end + let output_arrays_model arrays = + if not (Profile.is_empty arrays) then begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; + (*printf "; arrays:@.";*) + Profile.iter + (fun (f, xs_ty, ty) st -> + match xs_ty with + [_] -> + (*printf " ; array %a : %a -> %a@." + (print_symb ty) f Ty.print tyi Ty.print ty;*) + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; + Profile.V.iter + (fun (xs, rep) -> + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) + "((%a %a) %a)@ " + (print_symb ty) f print_args xs x_print rep; + List.iter (fun (_,x) -> assert_has_depth_one x) xs; + )st; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; + | _ -> assert false + + ) arrays; + Printer.print_fmt (get_fmt_mdl ()) "@]"; + end -end + end (* of module SMT2LikeModelOutput *) let is_a_good_model_value (x, _) = @@ -1273,12 +1327,27 @@ let output_concrete_model ({ make; _ } as env) = ) make (Profile.empty, Profile.empty, Profile.empty, ME.empty) in - if i > 0 then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "(@ "; - SMT2LikeModelOutput.output_constants_model constants; - SMT2LikeModelOutput.output_functions_model functions; - SMT2LikeModelOutput.output_arrays_model arrays; - Printer.print_fmt (get_fmt_mdl ()) ")"; + if i > 0 then + if Options.get_why3_counterexample() then begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[unknown@ "; + SMT2LikeModelOutput.output_constants_why3_counterexample + constants functions; + Printer.print_fmt (get_fmt_mdl ()) "@])"; + (* Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[ME@ "; + * ME.iter (fun t r -> + * Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "%a -> %a@ " + * Expr.print t X.print r) make; + * Printer.print_fmt (get_fmt_mdl ()) "@])"; *) + end + else begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[(@ "; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Constants@ "; + SMT2LikeModelOutput.output_constants_model constants; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Functions@ "; + SMT2LikeModelOutput.output_functions_model functions; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Arrays@ "; + SMT2LikeModelOutput.output_arrays_model arrays; + Printer.print_fmt (get_fmt_mdl ()) "@])"; end let save_cache () = diff --git a/src/lib/structures/parsed.ml b/src/lib/structures/parsed.ml index a09df76cf..6570d04c6 100644 --- a/src/lib/structures/parsed.ml +++ b/src/lib/structures/parsed.ml @@ -93,6 +93,38 @@ type ppure_type = | PPTvarid of string * Loc.t | PPTexternal of ppure_type list * string * Loc.t +let pp_sep_comma fmt () = Format.fprintf fmt "," + +let pp_sep_space fmt () = Format.fprintf fmt " " + +let rec pp_ppure_type fmt t = + Format.fprintf fmt "%s" + (match t with + | PPTint -> "int" + | PPTbool -> "bool" + | PPTreal -> "real" + | PPTunit -> "unit" + | PPTbitv i -> Format.asprintf "bitv[%d]" i + | PPTvarid (s, _) -> Format.asprintf "varid[%s]" s + | PPTexternal (ppl, s, _) -> + Format.asprintf "%a %s" pp_ppure_type_list ppl s + ) + +and pp_ppure_type_list fmt tl = + Format.fprintf fmt "@[%a@]" + (Format.pp_print_list ~pp_sep:pp_sep_comma (fun fmt t -> + Format.fprintf fmt "%a" pp_ppure_type t)) tl + +and pp_str_ppure_type_list fmt tl = + Format.fprintf fmt "@[%a@]" + (Format.pp_print_list ~pp_sep:pp_sep_comma (fun fmt (s, t) -> + Format.fprintf fmt "(%s, %a)" s pp_ppure_type t)) tl + +and pp_str_str_ppure_type_list fmt tl = + Format.fprintf fmt "@[%a@]" + (Format.pp_print_list ~pp_sep:pp_sep_comma (fun fmt (s1, s2, t) -> + Format.fprintf fmt "(%s, %s, %a)" s1 s2 pp_ppure_type t)) tl + type pattern = { pat_loc : Loc.t; pat_desc : string * string list } @@ -143,7 +175,7 @@ let rec pp_lexpr fmt {pp_desc; _} = | PPvar s -> fprintf fmt "%s" s | PPapp (s, lel) -> - fprintf fmt "%s %a" s (pp_print_list pp_lexpr) lel + fprintf fmt "PPapp(%s, %a)" s (pp_print_list ~pp_sep:pp_sep_space pp_lexpr) lel | PPmapsTo (s, le) -> fprintf fmt "[%s -> %a]" s pp_lexpr le | PPinInterval (le, b1, le1, le2, b2) -> @@ -158,9 +190,9 @@ let rec pp_lexpr fmt {pp_desc; _} = | PPconst c-> fprintf fmt "%a" pp_const c | PPinfix (le1, op, le2) -> - fprintf fmt "(%a %a %a)" pp_lexpr le1 pp_inf_op op pp_lexpr le2 + fprintf fmt "inf: (%a %a %a)" pp_lexpr le1 pp_inf_op op pp_lexpr le2 | PPprefix (op, le) -> - fprintf fmt "%a %a" pp_pre_op op pp_lexpr le + fprintf fmt "pre: %a %a" pp_pre_op op pp_lexpr le | PPget (arr, ind) -> fprintf fmt "%a[%a]" pp_lexpr arr pp_lexpr ind | PPset (arr, ind, v) -> @@ -180,26 +212,35 @@ let rec pp_lexpr fmt {pp_desc; _} = | PPif (cond, bthen, belse) -> fprintf fmt "if %a then %a else %a" pp_lexpr cond pp_lexpr bthen pp_lexpr belse - | _ -> assert false (* Used for an experiment so not complete but will be completed *) - (* | PPforall of - * (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr - * | PPexists of - * (string * ppure_type) list * (lexpr list * bool) list * lexpr list * lexpr - * | PPforall_named of - * (string * string * ppure_type) list * (lexpr list * bool) list * - * lexpr list * lexpr - * | PPexists_named of - * (string * string * ppure_type) list * (lexpr list * bool) list * - * lexpr list * lexpr - * | PPnamed of string * lexpr - * | PPlet of (string * lexpr) list * lexpr - * | PPcheck of lexpr - * | PPcut of lexpr - * | PPcast of lexpr * ppure_type - * | PPmatch of lexpr * (pattern * lexpr) list - * | PPisConstr of lexpr * string - * | PPproject of bool * lexpr * string *) + | PPforall (spptl, lebl, lel, le) -> + fprintf fmt "forall %a. [%a] [%a] %a" + pp_str_ppure_type_list spptl pp_lexprl_bool_list lebl + pp_lexpr_list lel pp_lexpr le + | PPexists (_spptl, _lebl, _lel, _le) -> fprintf fmt "exists" + | PPforall_named (sspptl, lebl, lel, le) -> + fprintf fmt "foralln %a. [%a] [%a] %a" + pp_str_str_ppure_type_list sspptl pp_lexprl_bool_list lebl + pp_lexpr_list lel pp_lexpr le + | PPexists_named (_spptl, _lebl, _lel, _le) -> fprintf fmt "existsn" + | PPnamed (s, le) -> fprintf fmt "Named: %s %a" s pp_lexpr le + | PPlet (_slel, _le) -> fprintf fmt "let" + | PPcheck le -> fprintf fmt "check %a" pp_lexpr le + | PPcut le -> fprintf fmt "cut %a" pp_lexpr le + | PPcast (le, ppt) -> fprintf fmt "cast %a -> %a" pp_lexpr le pp_ppure_type ppt + | PPmatch (_le, _plel) -> fprintf fmt "match" + | PPisConstr (le, s) -> fprintf fmt "isConstr: %a %s" pp_lexpr le s + | PPproject (b, le, s) -> fprintf fmt "project: %b %a %s" b pp_lexpr le s + +and pp_lexpr_list fmt tl = + Format.fprintf fmt "@[%a@]" + (Format.pp_print_list ~pp_sep:pp_sep_comma (fun fmt e -> + Format.fprintf fmt "%a" pp_lexpr e)) tl + +and pp_lexprl_bool_list fmt tl = + Format.fprintf fmt "@[%a@]" + (Format.pp_print_list ~pp_sep:pp_sep_comma (fun fmt (lel, b) -> + Format.fprintf fmt "(%a, %b)" pp_lexpr_list lel b)) tl (* Declarations. *) diff --git a/src/lib/structures/parsed.mli b/src/lib/structures/parsed.mli index 2b9776fcd..f44076709 100644 --- a/src/lib/structures/parsed.mli +++ b/src/lib/structures/parsed.mli @@ -52,6 +52,9 @@ type ppure_type = | PPTvarid of string * Loc.t | PPTexternal of ppure_type list * string * Loc.t +val pp_ppure_type : Format.formatter -> ppure_type -> unit +val pp_ppure_type_list : Format.formatter -> ppure_type list -> unit + type pattern = { pat_loc : Loc.t; pat_desc : string * string list } @@ -97,6 +100,7 @@ and pp_desc = | PPproject of bool * lexpr * string val pp_lexpr : Format.formatter -> lexpr -> unit +val pp_lexpr_list : Format.formatter -> lexpr list -> unit (* Declarations. *) diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 4504acec3..6c927bb41 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -300,12 +300,14 @@ let model = ref MNone let output_format = ref Native let infer_output_format = ref true let unsat_core = ref false +let why3_counterexample = ref false let set_interpretation b = interpretation := b let set_model b = model := b let set_output_format b = output_format := b let set_infer_output_format f = infer_output_format := f = None let set_unsat_core b = unsat_core := b +let set_why3_counterexample b = why3_counterexample := b let get_interpretation () = !interpretation let get_model () = !model = MDefault || !model = MComplete @@ -314,6 +316,7 @@ let get_all_models () = !model = MAll let get_output_format () = !output_format let get_infer_output_format () = !infer_output_format let get_unsat_core () = !unsat_core || !save_used_context || !debug_unsat_core +let get_why3_counterexample () = !why3_counterexample (** Profiling options *) @@ -430,7 +433,7 @@ let get_tableaux_cdcl () = !tableaux_cdcl let disable_ites = ref false let inline_lets = ref false let rewriting = ref false -let term_like_pp = ref false +let term_like_pp = ref true let set_disable_ites b = disable_ites := b let set_inline_lets b = inline_lets := b diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 308dbaae6..33c308e90 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -189,6 +189,8 @@ val set_input_format : input_format -> unit A negative value (-1, -2, or -3) will disable interpretation display. *) val set_interpretation : int -> unit +val set_why3_counterexample : bool -> unit + (** Set [max_split] accessible with {!val:get_max_split} *) val set_max_split : Numbers.Q.t -> unit @@ -197,9 +199,9 @@ val set_max_split : Numbers.Q.t -> unit Possible values are : {ul {- Default} {- Complete} {- All}} *) -val set_model : model -> unit + val set_model : model -> unit -(** Set [nb_triggers] accessible with {!val:get_nb_triggers} *) + (** Set [nb_triggers] accessible with {!val:get_nb_triggers} *) val set_nb_triggers : int -> unit (** Set [no_ac] accessible with {!val:get_no_ac} *) @@ -701,6 +703,8 @@ val get_all_models : unit -> bool val get_interpretation : unit -> int (** Default to [0] *) +val get_why3_counterexample : unit -> bool + (** Value specifying the default output format. possible values are {ul {- native} {- smtlib2} {- why3}} . *) From fbe1dcddd87142d3fbf12d947913ca4c448600cb Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 17 Dec 2020 11:35:56 +0100 Subject: [PATCH 08/68] Change interpretation option, use mdl-formatter to compute but not print model and interpretation --- src/bin/common/parse_command.ml | 56 +++++-- src/lib/frontend/frontend.ml | 13 +- src/lib/reasoners/fun_sat.ml | 45 ++--- src/lib/reasoners/satml_frontend.ml | 2 +- src/lib/reasoners/uf.ml | 244 ++++++++++++++-------------- src/lib/util/options.ml | 13 +- src/lib/util/options.mli | 54 ++++-- 7 files changed, 259 insertions(+), 168 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 8646cdf2d..8e65290a8 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -57,6 +57,29 @@ let instantiation_heuristic_conv = Arg.conv ~docv:"VAL" (instantiation_heuristic_parser, instantiation_heuristic_printer) +let interpretation_parser = function + | "none" -> Ok INone + | "first" -> Ok IFirst + | "before_inst" -> Ok IBefore_inst + | "before_dec" -> Ok IBefore_dec + | "before_end" -> Ok IBefore_end + | s -> + Error + (`Msg ("Option --interpretation does not accept the argument \"" ^ s)) + +let interpretation_to_string = function + | INone -> "none" + | IFirst -> "first" + | IBefore_inst -> "before_inst" + | IBefore_dec -> "before_dec" + | IBefore_end -> "before_end" + +let interpretation_printer fmt interpretation = + Format.fprintf fmt "%s" (interpretation_to_string interpretation) + +let interpretation_conv = + Arg.conv ~docv:"MDL" (interpretation_parser, interpretation_printer) + (* When adding another parser, remember to change this list too as it is used in the documentation *) let formats_list = @@ -462,10 +485,11 @@ let mk_opts file () () () () () () halt_opt (gc) () () () () () () () () `Ok true end -let mk_fmt_opt std_fmt err_fmt +let mk_fmt_opt std_fmt err_fmt mdl_fmt = set_std_fmt (value_of_fmt std_fmt); set_err_fmt (value_of_fmt err_fmt); + set_fmt_mdl (value_of_fmt mdl_fmt); `Ok() (* Custom sections *) @@ -896,15 +920,19 @@ let parse_output_opt = let docs = s_output in let interpretation = - let doc = - "Experimental support for counter-example generation. Possible \ - values are 1, 2, or 3 to compute an interpretation before returning \ - Unknown, before instantiation (1), or before every decision (2) or \ - instantiation (3). A negative value (-1, -2, or -3) will disable \ - interpretation display. Note that $(b, --max-split) limitation will \ - be ignored in model generation phase." in + let doc = Format.sprintf + "Experimental support for counter-example generation. \ + $(docv) must be %s. %s shows the first computed interpretation. \ + %s compute an interpretation before every decision, \ + %s before every instantiation and %s only before returning unknown. \ + Note that $(b, --max-split) limitation will \ + be ignored in model generation phase." + (Arg.doc_alts + ["none"; "first"; "before_dec"; "before_inst"; "before_end"]) + (Arg.doc_quote "first") (Arg.doc_quote "before_dec") + (Arg.doc_quote "before_inst") (Arg.doc_quote "before_end") in let docv = "VAL" in - Arg.(value & opt int (get_interpretation ()) & + Arg.(value & opt interpretation_conv INone & info ["interpretation"] ~docv ~docs ~doc) in let model = @@ -1246,8 +1274,16 @@ let parse_fmt_opt = Arg.(value & opt formatter_conv Stderr & info ["err-formatter"] ~docs ~doc) in + let mdl_formatter = + let doc = Format.sprintf + "Set the model formatter used by default to output model and + interpretation. Possible values are %s." + (Arg.doc_alts ["stdout"; "stderr"; ""]) in + Arg.(value & opt formatter_conv Stdout & info ["mdl-formatter"] ~docs ~doc) + in + Term.(ret (const mk_fmt_opt $ - std_formatter $ err_formatter + std_formatter $ err_formatter $ mdl_formatter )) let main = diff --git a/src/lib/frontend/frontend.ml b/src/lib/frontend/frontend.ml index b72133bc6..faad89ac6 100644 --- a/src/lib/frontend/frontend.ml +++ b/src/lib/frontend/frontend.ml @@ -279,6 +279,15 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct | Query(g,_,_) -> Some g | _ -> None in + let why3_counterexample = + let why3_output = + match Options.get_output_format () with + | Why3 -> true + | Smtlib2 | Native | Unknown _ -> false + in + why3_output || Options.get_why3_counterexample () + in + let time = Time.value() in match status with | Unsat (d, dep) -> @@ -311,13 +320,13 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout (Some d) -> - if not (Options.get_why3_counterexample ()) then + if not why3_counterexample then let loc = d.st_loc in Printer.print_status_timeout ~validity_mode (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout None -> - if not (Options.get_why3_counterexample ()) then + if not why3_counterexample then Printer.print_status_timeout ~validity_mode None (Some time) (Some steps) None; diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index c7ff5a783..374285f91 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -358,7 +358,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct "(%a or %a), %a" E.print f1.E.ff E.print f2.E.ff Ex.print ex) d; print_dbg ~debug:(get_verbose () || get_debug_sat ()) - "[sat] --------------------- Delta -" *) + "[sat] --------------------- Delta -" *) let gamma g = if get_debug_sat () && get_verbose () then begin @@ -1209,9 +1209,16 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct "[all-models] No SAT models found" - let compute_concrete_model env origin = - if abs (get_interpretation ()) <> origin then env - else + let compute_concrete_model env compute = + let compute = + if Options.get_first_interpretation () then + match !latest_saved_env with + | Some _ -> false + | None -> true + else compute + in + if not compute then env + else begin try (* to push pending stuff *) let env = do_case_split env (Options.get_case_split_policy ()) in @@ -1223,11 +1230,11 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct Options.tool_req 2 "TR-Sat-Conflict-2"; env.heuristics := Heuristics.bump_activity !(env.heuristics) expl; raise (IUnsat (expl, classes)) - + end let return_cached_model return_function = - let i = abs(get_interpretation ()) in - assert (i = 1 || i = 2 || i = 3); + let i = get_interpretation () in + assert i; assert (not !terminated_normally); terminated_normally := true; (* to avoid loops *) begin @@ -1249,15 +1256,14 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let () = at_exit (fun () -> - let i = abs(get_interpretation ()) in - if not !terminated_normally && (i = 1 || i = 2 || i = 3) then + if not !terminated_normally && (get_interpretation ()) then return_cached_model (fun () -> ()) ) - let return_answer env orig return_function = + let return_answer env compute return_function = update_all_models_option env; - let env = compute_concrete_model env orig in + let env = compute_concrete_model env compute in let uf = Ccx.Main.get_union_find (Th.get_case_split_env env.tbox) in Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); Uf.output_concrete_model uf; @@ -1268,13 +1274,12 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let switch_to_model_gen env = not !terminated_normally && not !(env.model_gen_mode) && - let i = abs (get_interpretation ()) in - (i = 1 || i = 2 || i = 3) + get_interpretation () let do_switch_to_model_gen env = - let i = abs (get_interpretation ()) in - assert (i = 1 || i = 2 || i = 3); + let i = get_interpretation () in + assert i; if not !(env.model_gen_mode) && Stdlib.(<>) (Options.get_timelimit_interpretation ()) 0. then begin @@ -1318,7 +1323,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct | E.Let _ | E.Iff _ | E.Xor _ -> Printer.print_err "Currently, arbitrary formulas in Hyps - are not Th-reduced"; +are not Th-reduced"; assert false | E.Not_a_form -> assert false @@ -1399,7 +1404,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let greedy_instantiation env = match get_instantiation_heuristic () with | INormal -> - return_answer env 1 + return_answer env (get_before_end_interpretation ()) (fun e -> raise (I_dont_know e)) | IAuto | IGreedy -> let gre_inst = @@ -1426,13 +1431,13 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env else - return_answer env 1 + return_answer env (get_before_end_interpretation ()) (fun e -> raise (I_dont_know e)) let normal_instantiation env try_greedy = Debug.print_nb_related env; let env = do_case_split env Util.BeforeMatching in - let env = compute_concrete_model env 2 in + let env = compute_concrete_model env (get_before_inst_interpretation ()) in let env = new_inst_level env in let mconf = {Util.nb_triggers = get_nb_triggers (); @@ -1526,7 +1531,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct and back_tracking env = try - let env = compute_concrete_model env 3 in + let env = compute_concrete_model env (get_before_dec_interpretation ()) in if env.delta == [] || Options.get_no_decisions() then back_tracking (normal_instantiation env true) else diff --git a/src/lib/reasoners/satml_frontend.ml b/src/lib/reasoners/satml_frontend.ml index a952d4100..76337721c 100644 --- a/src/lib/reasoners/satml_frontend.ml +++ b/src/lib/reasoners/satml_frontend.ml @@ -1036,7 +1036,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct Errors.run_error (Errors.Unsupported_feature msg) in let open Options in - if get_interpretation () <> 0 then fails "interpretation"; + if get_interpretation () then fails "interpretation"; if get_save_used_context () then fails "save_used_context"; if get_unsat_core () then fails "unsat_core"; if get_all_models () then fails "all_models"; diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index 125ca218a..df04865e3 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1131,115 +1131,115 @@ module SMT2LikeModelOutput = struct List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l let print_symb ty fmt f = - match f, ty with - | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> - fprintf fmt "%a__%s" Sy.print f (Hstring.view name) - - | _ -> Sy.print fmt f + match f, ty with + | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> + fprintf fmt "%a__%s" Sy.print f (Hstring.view name) + + | _ -> Sy.print fmt f + + let output_constants_model cprofs = + (*printf "; constants:@.";*) + Profile.iter + (fun (f, _xs_ty, ty) st -> + match Profile.V.elements st with + | [[], rep] -> + (*printf " (%a %a) ; %a@." + (print_symb ty) f x_print rep Ty.print ty*) + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) + "(s(%d): %a, rep: %a)@ " (List.length _xs_ty) (print_symb ty) f x_print rep + | _ -> assert false + ) cprofs + + let pp_type fmt t = + let open Ty in + Format.fprintf fmt "%s" (match t with + | Tint -> "Int" + | Treal -> "Real" + | Tbool -> "Bool" + | Text (_, t) -> Hstring.view t + | _ -> asprintf "%a" print t + ) - let output_constants_model cprofs = - (*printf "; constants:@.";*) + let get_qtmk f qtmks = + try Models.Sorts.find f qtmks + with Not_found -> f + + let output_constants_why3_counterexample cprofs fprofs = + (* Models.Sorts.iter (fun f (nbargs, t) -> + * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !Models.h; *) + Printer.print_fmt ~flushed:false (get_fmt_mdl()) "@[(model@,"; + let qtmks = Profile.fold + (fun (f, _xs_ty, ty) st acc -> + Profile.V.fold + (fun (xs, rep) acc -> + let s = asprintf "%a" (print_symb ty) f in + let rep = asprintf "%a" x_print rep in + match Models.get_type s, Models.get_type rep with + | Some ts, Some tr when String.equal ts tr -> + Models.Sorts.add + rep (Format.asprintf "(%s %a)" s print_args xs) + acc + | _ -> acc; + ) st acc; + ) fprofs Models.Sorts.empty in + Profile.iter + (fun (f, _xs_ty, ty) st -> + match Profile.V.elements st with + | [[], rep] -> + let rep = Format.asprintf "%a" x_print_why3 rep in + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) + "(define-fun %a () %a %s)@ " + (print_symb ty) f pp_type ty (get_qtmk rep qtmks) + | _ -> assert false + ) cprofs + + let output_functions_model fprofs = + if not (Profile.is_empty fprofs) then begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; + (*printf "@.; functions:@.";*) Profile.iter (fun (f, _xs_ty, ty) st -> - match Profile.V.elements st with - | [[], rep] -> - (*printf " (%a %a) ; %a@." - (print_symb ty) f x_print rep Ty.print ty*) - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "(s(%d): %a, rep: %a)@ " (List.length _xs_ty) (print_symb ty) f x_print rep - | _ -> assert false - ) cprofs - - let pp_type fmt t = - let open Ty in - Format.fprintf fmt "%s" (match t with - | Tint -> "Int" - | Treal -> "Real" - | Tbool -> "Bool" - | Text (_, t) -> Hstring.view t - | _ -> asprintf "%a" print t - ) - - let get_qtmk f qtmks = - try Models.Sorts.find f qtmks - with Not_found -> f - - let output_constants_why3_counterexample cprofs fprofs = - (* Models.Sorts.iter (fun f (nbargs, t) -> - * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !Models.h; *) - Printer.print_fmt ~flushed:false (get_fmt_mdl()) "@[(model@,"; - let qtmks = Profile.fold - (fun (f, _xs_ty, ty) st acc -> - Profile.V.fold - (fun (xs, rep) acc -> - let s = asprintf "%a" (print_symb ty) f in - let rep = asprintf "%a" x_print rep in - match Models.get_type s, Models.get_type rep with - | Some ts, Some tr when String.equal ts tr -> - Models.Sorts.add - rep (Format.asprintf "(%s %a)" s print_args xs) - acc - | _ -> acc; - ) st acc; - ) fprofs Models.Sorts.empty in + (*printf " ; fun %a : %a -> %a@." + (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; + Profile.V.iter + (fun (xs, rep) -> + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) + "((s: %a, args: %a) rep: %a)@ " + (print_symb ty) f print_args xs x_print rep; + List.iter (fun (_,x) -> assert_has_depth_one x) xs; + )st; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; + ) fprofs; + Printer.print_fmt (get_fmt_mdl ()) "@]"; + end + + let output_arrays_model arrays = + if not (Profile.is_empty arrays) then begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; + (*printf "; arrays:@.";*) Profile.iter - (fun (f, _xs_ty, ty) st -> - match Profile.V.elements st with - | [[], rep] -> - let rep = Format.asprintf "%a" x_print_why3 rep in - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "(define-fun %a () %a %s)@ " - (print_symb ty) f pp_type ty (get_qtmk rep qtmks) - | _ -> assert false - ) cprofs - - let output_functions_model fprofs = - if not (Profile.is_empty fprofs) then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - (*printf "@.; functions:@.";*) - Profile.iter - (fun (f, _xs_ty, ty) st -> - (*printf " ; fun %a : %a -> %a@." - (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) + (fun (f, xs_ty, ty) st -> + match xs_ty with + [_] -> + (*printf " ; array %a : %a -> %a@." + (print_symb ty) f Ty.print tyi Ty.print ty;*) Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; Profile.V.iter (fun (xs, rep) -> Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "((s: %a, args: %a) rep: %a)@ " + "((%a %a) %a)@ " (print_symb ty) f print_args xs x_print rep; List.iter (fun (_,x) -> assert_has_depth_one x) xs; )st; Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; - ) fprofs; - Printer.print_fmt (get_fmt_mdl ()) "@]"; - end + | _ -> assert false - let output_arrays_model arrays = - if not (Profile.is_empty arrays) then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - (*printf "; arrays:@.";*) - Profile.iter - (fun (f, xs_ty, ty) st -> - match xs_ty with - [_] -> - (*printf " ; array %a : %a -> %a@." - (print_symb ty) f Ty.print tyi Ty.print ty;*) - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - Profile.V.iter - (fun (xs, rep) -> - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "((%a %a) %a)@ " - (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one x) xs; - )st; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; - | _ -> assert false - - ) arrays; - Printer.print_fmt (get_fmt_mdl ()) "@]"; - end + ) arrays; + Printer.print_fmt (get_fmt_mdl ()) "@]"; + end - end +end (* of module SMT2LikeModelOutput *) let is_a_good_model_value (x, _) = @@ -1267,9 +1267,15 @@ let model_repr_of_term t env mrepr = let output_concrete_model ({ make; _ } as env) = - let i = get_interpretation () in - let abs_i = abs i in - if abs_i = 1 || abs_i = 2 || abs_i = 3 then + if get_interpretation () then + let why3_counterexample = + let why3_output = + match Options.get_output_format () with + | Why3 -> true + | Smtlib2 | Native | Unknown _ -> false + in + why3_output || Options.get_why3_counterexample () + in let functions, constants, arrays, _ = ME.fold (fun t _mk ((fprofs, cprofs, carrays, mrepr) as acc) -> @@ -1327,27 +1333,27 @@ let output_concrete_model ({ make; _ } as env) = ) make (Profile.empty, Profile.empty, Profile.empty, ME.empty) in - if i > 0 then - if Options.get_why3_counterexample() then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[unknown@ "; - SMT2LikeModelOutput.output_constants_why3_counterexample - constants functions; - Printer.print_fmt (get_fmt_mdl ()) "@])"; - (* Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[ME@ "; - * ME.iter (fun t r -> - * Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "%a -> %a@ " - * Expr.print t X.print r) make; - * Printer.print_fmt (get_fmt_mdl ()) "@])"; *) - end - else begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[(@ "; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Constants@ "; - SMT2LikeModelOutput.output_constants_model constants; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Functions@ "; - SMT2LikeModelOutput.output_functions_model functions; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Arrays@ "; - SMT2LikeModelOutput.output_arrays_model arrays; - Printer.print_fmt (get_fmt_mdl ()) "@])"; + if why3_counterexample then begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[unknown@ "; + SMT2LikeModelOutput.output_constants_why3_counterexample + constants functions; + Printer.print_fmt (get_fmt_mdl ()) "@])"; + + (* Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[ME@ "; + * ME.iter (fun t r -> + * Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "%a -> %a@ " + * Expr.print t X.print r) make; + * Printer.print_fmt (get_fmt_mdl ()) "@])"; *) + end + else begin + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[(@ "; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Constants@ "; + SMT2LikeModelOutput.output_constants_model constants; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Functions@ "; + SMT2LikeModelOutput.output_functions_model functions; + Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Arrays@ "; + SMT2LikeModelOutput.output_arrays_model arrays; + Printer.print_fmt (get_fmt_mdl ()) "@])"; end let save_cache () = diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 6c927bb41..1f797914f 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -63,6 +63,7 @@ let set_fmt_usc f = fmt_usc := f type model = MNone | MDefault | MAll | MComplete type instantiation_heuristic = INormal | IAuto | IGreedy +type interpretation = INone | IFirst | IBefore_inst | IBefore_dec | IBefore_end type input_format = Native | Smtlib2 | Why3 (* | SZS *) | Unknown of string type output_format = input_format @@ -295,7 +296,7 @@ let get_timelimit_per_goal () = !timelimit_per_goal (** Output options *) -let interpretation = ref 0 +let interpretation = ref INone let model = ref MNone let output_format = ref Native let infer_output_format = ref true @@ -309,7 +310,15 @@ let set_infer_output_format f = infer_output_format := f = None let set_unsat_core b = unsat_core := b let set_why3_counterexample b = why3_counterexample := b -let get_interpretation () = !interpretation +let get_interpretation () = + !interpretation = IFirst || + !interpretation = IBefore_dec || + !interpretation = IBefore_inst || + !interpretation = IBefore_end +let get_first_interpretation () = !interpretation = IFirst +let get_before_dec_interpretation () = !interpretation = IBefore_dec +let get_before_inst_interpretation () = !interpretation = IBefore_inst +let get_before_end_interpretation () = !interpretation = IBefore_end let get_model () = !model = MDefault || !model = MComplete let get_complete_model () = !model = MComplete let get_all_models () = !model = MAll diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 33c308e90..59f70fa75 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -37,9 +37,13 @@ (** Type used to describe the type of models wanted *) type model = MNone | MDefault | MAll | MComplete + (** Type used to describe the type of heuristic for instantiation wanted *) type instantiation_heuristic = INormal | IAuto | IGreedy +(** Type used to describe the type of interpretation wanted *) +type interpretation = INone | IFirst | IBefore_inst | IBefore_dec | IBefore_end + (** Type used to describe the type of input wanted by {!val:set_input_format} *) type input_format = @@ -183,11 +187,11 @@ val set_input_format : input_format -> unit (** Set [interpretation] accessible with {!val:get_interpretation} Possible values are : - {ol {- Unknown} {- Before instantiation} - {- Before every decision or instantiation}} - - A negative value (-1, -2, or -3) will disable interpretation display. *) -val set_interpretation : int -> unit + {ol {- First} {- Before every instantiation} + {- Before every decision and instantiation} + {- Before end}} +*) +val set_interpretation : interpretation -> unit val set_why3_counterexample : bool -> unit @@ -199,9 +203,9 @@ val set_max_split : Numbers.Q.t -> unit Possible values are : {ul {- Default} {- Complete} {- All}} *) - val set_model : model -> unit +val set_model : model -> unit - (** Set [nb_triggers] accessible with {!val:get_nb_triggers} *) +(** Set [nb_triggers] accessible with {!val:get_nb_triggers} *) val set_nb_triggers : int -> unit (** Set [no_ac] accessible with {!val:get_no_ac} *) @@ -676,7 +680,7 @@ val get_timelimit_per_goal : unit -> bool {ul {- None} {- Default} {- Complete : shows a complete model} {- All : shows all models}} - Which are used in the two setters below. This option answers + Which are used in the two getters below. This option answers [true] if the model is set to Default or Complete *) val get_model : unit -> bool @@ -686,22 +690,44 @@ val get_model : unit -> bool val get_complete_model : unit -> bool (** Default to [false] *) -(** [true] if the model is set to all models? *) +(** [true] if the model is set to all models *) val get_all_models : unit -> bool (** Default to [false] *) (** Experimental support for counter-example generation. Possible values are : - {ol {- Unknown} {- Before instantiation} - {- Before every decision or instantiation}} + {ol {- First} {- Before every instantiation} + {- Before every decision and instantiation} + {- Before end}} - A negative value (-1, -2, or -3) will disable interpretation display. + Which are used in the four getters below. This option answers + [true] if the interpretation is set to First, Before_end, Before_dec + or Before_inst. Note that {!val:get_max_split} limitation will be ignored in model generation phase. *) -val get_interpretation : unit -> int -(** Default to [0] *) +val get_interpretation : unit -> bool +(** Default to [false] *) + +(** [true] if the interpretation is set to first interpretation *) +val get_first_interpretation : unit -> bool +(** Default to [false] *) + +(** [true] if the interpretation is set to compute interpretation + before every decision *) +val get_before_dec_interpretation : unit -> bool +(** Default to [false] *) + +(** [true] if the interpretation is set to compute interpretation + before every instantiation *) +val get_before_inst_interpretation : unit -> bool +(** Default to [false] *) + +(** [true] if the interpretation is set to compute interpretation + before the solver return unknown *) +val get_before_end_interpretation : unit -> bool +(** Default to [false] *) val get_why3_counterexample : unit -> bool From 09fd0365ee57207fa6e66e8e2b4c9f26c136cdf6 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 9 Oct 2020 11:04:55 +0200 Subject: [PATCH 09/68] Style check --- src/bin/text/main_text.ml | 3 --- src/lib/reasoners/uf.ml | 3 ++- src/lib/structures/parsed.ml | 6 ++++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/bin/text/main_text.ml b/src/bin/text/main_text.ml index d5e7d3969..cddc3b72a 100644 --- a/src/bin/text/main_text.ml +++ b/src/bin/text/main_text.ml @@ -45,6 +45,3 @@ let () = AltErgoLib.Printer.init_output_format (); Signals_profiling.init_signals (); Solving_loop.main () - - (* let fun_decls = Seq.filter (function Parsed.Function_def _ -> true | _ -> false) parsed in *) - Models.sorts parsed; diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index df04865e3..50f86c847 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1146,7 +1146,8 @@ module SMT2LikeModelOutput = struct (*printf " (%a %a) ; %a@." (print_symb ty) f x_print rep Ty.print ty*) Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "(s(%d): %a, rep: %a)@ " (List.length _xs_ty) (print_symb ty) f x_print rep + "(s(%d): %a, rep: %a)@ " + (List.length _xs_ty) (print_symb ty) f x_print rep | _ -> assert false ) cprofs diff --git a/src/lib/structures/parsed.ml b/src/lib/structures/parsed.ml index 6570d04c6..9803c92cb 100644 --- a/src/lib/structures/parsed.ml +++ b/src/lib/structures/parsed.ml @@ -175,7 +175,8 @@ let rec pp_lexpr fmt {pp_desc; _} = | PPvar s -> fprintf fmt "%s" s | PPapp (s, lel) -> - fprintf fmt "PPapp(%s, %a)" s (pp_print_list ~pp_sep:pp_sep_space pp_lexpr) lel + fprintf fmt "PPapp(%s, %a)" s + (pp_print_list ~pp_sep:pp_sep_space pp_lexpr) lel | PPmapsTo (s, le) -> fprintf fmt "[%s -> %a]" s pp_lexpr le | PPinInterval (le, b1, le1, le2, b2) -> @@ -227,7 +228,8 @@ let rec pp_lexpr fmt {pp_desc; _} = | PPlet (_slel, _le) -> fprintf fmt "let" | PPcheck le -> fprintf fmt "check %a" pp_lexpr le | PPcut le -> fprintf fmt "cut %a" pp_lexpr le - | PPcast (le, ppt) -> fprintf fmt "cast %a -> %a" pp_lexpr le pp_ppure_type ppt + | PPcast (le, ppt) -> + fprintf fmt "cast %a -> %a" pp_lexpr le pp_ppure_type ppt | PPmatch (_le, _plel) -> fprintf fmt "match" | PPisConstr (le, s) -> fprintf fmt "isConstr: %a %s" pp_lexpr le s | PPproject (b, le, s) -> fprintf fmt "project: %b %a %s" b pp_lexpr le s From e7b13ffdf3454c4d8d970059ae84f071401cc1b4 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 16 Oct 2020 11:49:52 +0200 Subject: [PATCH 10/68] Move the printing of counterexample from uf.ml to models.ml --- src/lib/models/models.ml | 335 +++++++++++++++++++++++++++++++++ src/lib/models/models.mli | 40 ++++ src/lib/reasoners/fun_sat.ml | 4 +- src/lib/reasoners/uf.ml | 346 ++++++----------------------------- src/lib/reasoners/uf.mli | 17 +- 5 files changed, 453 insertions(+), 289 deletions(-) create mode 100644 src/lib/models/models.mli diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 694fc23a7..1aac8ecf3 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -1,3 +1,27 @@ +(******************************************************************************) +(* *) +(* Alt-Ergo: The SMT Solver For Software Verification *) +(* Copyright (C) 2020-2020 --- OCamlPro SAS *) +(* *) +(* This file is distributed under the terms of the license indicated *) +(* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) +(* present, please contact us to clarify licensing. *) +(* *) +(******************************************************************************) + +open Format +open Options + +module X = Shostak.Combine + +module Ac = Shostak.Ac +module Ex = Explanation + +module Sy = Symbols +module E = Expr +module ME = Expr.Map +module SE = Expr.Set + module Sorts = Map.Make(String) let h = ref Sorts.empty @@ -24,3 +48,314 @@ let sorts parsed = let get_type s = try let (_, t) = Sorts.find s !h in Some t with Not_found -> None + +module Profile = struct + + module P = Map.Make + (struct + type t = Sy.t * Ty.t list * Ty.t + + let (|||) c1 c2 = if c1 <> 0 then c1 else c2 + + let compare (a1, b1, c1) (a2, b2, c2) = + let l1_l2 = List.length b1 - List.length b2 in + let c = l1_l2 ||| (Ty.compare c1 c2) ||| (Sy.compare a1 a2) in + if c <> 0 then c + else + let c = ref 0 in + try + List.iter2 + (fun ty1 ty2 -> + let d = Ty.compare ty1 ty2 in + if d <> 0 then begin c := d; raise Exit end + ) b1 b2; + 0 + with + | Exit -> assert (!c <> 0); !c + | Invalid_argument _ -> assert false + end) + + module V = Set.Make + (struct + type t = (E.t * (X.r * string)) list * (X.r * string) + let compare (l1, (v1,_)) (l2, (v2,_)) = + let c = X.hash_cmp v1 v2 in + if c <> 0 then c + else + let c = ref 0 in + try + List.iter2 + (fun (_,(x,_)) (_,(y,_)) -> + let d = X.hash_cmp x y in + if d <> 0 then begin c := d; raise Exit end + ) l1 l2; + !c + with + | Exit -> !c + | Invalid_argument _ -> List.length l1 - List.length l2 + end) + + let add p v mp = + let prof_p = try P.find p mp with Not_found -> V.empty in + if V.mem v prof_p then mp + else P.add p (V.add v prof_p) mp + + let iter = P.iter + + let fold = P.fold + + let empty = P.empty + + let is_empty = P.is_empty +end + +let assert_has_depth_one (e, _) = + match X.term_extract e with + | Some t, true -> assert (E.depth t = 1); + | _ -> () + +module AECounterExample = struct + + let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr + + let print_args fmt l = + match l with + | [] -> assert false + | [_,e] -> + fprintf fmt "%a" x_print e; + | (_,e) :: l -> + fprintf fmt "%a" x_print e; + List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l + + let print_symb ty fmt f = + match f, ty with + | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> + fprintf fmt "%a__%s" Sy.print f (Hstring.view name) + + | _ -> Sy.print fmt f + + let output_constants_counterexample fmt cprofs = + (*printf "; constants:@.";*) + Profile.iter + (fun (f, _xs_ty, ty) st -> + match Profile.V.elements st with + | [[], rep] -> + (*printf " (%a %a) ; %a@." + (print_symb ty) f x_print rep Ty.print ty*) + Printer.print_fmt ~flushed:false fmt + "(s(%d): %a, rep: %a)@ " + (List.length _xs_ty) (print_symb ty) f x_print rep + | _ -> assert false + ) cprofs + + let output_functions_counterexample fmt fprofs = + if not (Profile.is_empty fprofs) then begin + Printer.print_fmt ~flushed:false fmt "@[@ "; + (*printf "@.; functions:@.";*) + Profile.iter + (fun (f, _xs_ty, ty) st -> + (*printf " ; fun %a : %a -> %a@." + (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) + Printer.print_fmt ~flushed:false fmt "@[@ "; + Profile.V.iter + (fun (xs, rep) -> + Printer.print_fmt ~flushed:false fmt + "((s: %a, args: %a) rep: %a)@ " + (print_symb ty) f print_args xs x_print rep; + List.iter (fun (_,x) -> assert_has_depth_one x) xs; + )st; + Printer.print_fmt ~flushed:false fmt "@]@ "; + ) fprofs; + Printer.print_fmt fmt "@]"; + end + + let output_arrays_counterexample fmt arrays = + if not (Profile.is_empty arrays) then begin + Printer.print_fmt ~flushed:false fmt "@[@ "; + (*printf "; arrays:@.";*) + Profile.iter + (fun (f, xs_ty, ty) st -> + match xs_ty with + [_] -> + (*printf " ; array %a : %a -> %a@." + (print_symb ty) f Ty.print tyi Ty.print ty;*) + Printer.print_fmt ~flushed:false fmt "@[@ "; + Profile.V.iter + (fun (xs, rep) -> + Printer.print_fmt ~flushed:false fmt + "((%a %a) %a)@ " + (print_symb ty) f print_args xs x_print rep; + List.iter (fun (_,x) -> assert_has_depth_one x) xs; + )st; + Printer.print_fmt ~flushed:false fmt "@]@ "; + | _ -> assert false + + ) arrays; + Printer.print_fmt fmt "@]"; + end + +end +(* of module AECounterExample *) + +let debug = false + +module SmtlibCounterExample = struct + + let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr + + let x_print_why3 fmt (_ , ppr) = + fprintf fmt "%s" + (match ppr with + | "True" -> "true" + | "False" -> "false" + | _ -> ppr) + + let print_args fmt l = + match l with + | [] -> assert false + | [_,e] -> + fprintf fmt "%a" x_print e; + | (_,e) :: l -> + fprintf fmt "%a" x_print e; + List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l + + let print_symb ty fmt f = + match f, ty with + | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> + fprintf fmt "%a__%s" Sy.print f (Hstring.view name) + + | _ -> Sy.print fmt f + + let pp_type fmt t = + let open Ty in + Format.fprintf fmt "%s" (match t with + | Tint -> "Int" + | Treal -> "Real" + | Tbool -> "Bool" + | Text (_, t) -> Hstring.view t + | Trecord { args = lv; name = n; record_constr = cstr ; _} -> + asprintf "%a %s %s" print_list lv (Hstring.view n) (Hstring.view cstr) + | _ -> asprintf "%a" print t + ) + + let get_qtmk f qtmks = + try Sorts.find f qtmks + with Not_found -> f + + let output_constants_counterexample fmt cprofs fprofs = + (* Sorts.iter (fun f (nbargs, t) -> + * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !h; *) + Printer.print_fmt ~flushed:false (get_fmt_mdl()) "@[(model@,"; + let qtmks = Profile.fold + (fun (f, xs_ty, ty) st acc -> + if debug then + Printer.print_dbg "f:%a / xs_ty:%a / ty:%a" + Sy.print f + (Printer.pp_list_no_space Ty.print) xs_ty + Ty.print ty; + + Profile.V.fold + (fun (xs, rep) acc -> + + let print_xs fmt (e,(r,xs)) = + fprintf fmt "(%a / %a / %s), " E.print e X.print r xs + in + let print_rep fmt (r,rep) = + fprintf fmt "(%a %s) " X.print r rep + in + if debug then + Printer.print_dbg ~header:false "xs:%a / rep:%a" + (Printer.pp_list_no_space print_xs) xs + print_rep rep; + let s = asprintf "%a" (print_symb ty) f in + let rep = asprintf "%a" x_print rep in + + match get_type s, get_type rep with + | Some ts, Some tr when String.equal ts tr -> + (* Printer.print_dbg "s: %s(%s) / rep: %s (%s)" + s ts rep tr; *) + if debug then Printer.print_dbg "s:%s(:%s) / rep:%s(:%s)" + s ts rep tr; + Sorts.add + rep (Format.asprintf "(%s %a)" s print_args xs) + acc + | Some ts, Some tr -> + if debug then Printer.print_dbg "s:%s(:%s) / rep:%s(:%s)" + s ts rep tr; + acc; + | Some ts, None -> + if debug then Printer.print_dbg "s:%s(:%s) / rep:%s(:_)" + s ts rep; + acc; + | None, Some tr -> + if debug then Printer.print_dbg "s:%s(:_) / rep:%s(:%s)" + s rep tr; + acc; + | None, None -> + if debug then Printer.print_dbg "s:%s(:_) / rep:%s(:_)" + s rep; + acc; + ) st acc; + ) fprofs Sorts.empty in + if debug then + Printer.print_dbg "CPROFS"; + Profile.iter + (fun (f, xs_ty, ty) st -> + match Profile.V.elements st with + | [[], rep] -> + let rep = Format.asprintf "%a" x_print_why3 rep in + if debug then + Printer.print_dbg ~header:false "rep:%s / lsit lenght %d" + rep (List.length xs_ty); + + Printer.print_fmt ~flushed:false fmt + "(define-fun %a () %a %s)@ " + (print_symb ty) f pp_type ty (get_qtmk rep qtmks) + | _ -> assert false + ) cprofs + +end +(* of module SmtlibCounterExample *) + +module Why3CounterExample = struct + let output_constraints fmt constraints = + let print_constraints fmt _constraint = + (* TODO *) + fprintf fmt "" + in + Printer.print_fmt fmt ";; Constraints@ %a" + (Printer.pp_list_no_space print_constraints) constraints +end +(* of module Why3CounterExample *) + +let output_concrete_model fmt functions constants arrays = + if get_interpretation () then + if + Options.get_output_format () == Why3 || + Options.get_output_format () == Smtlib2 || + (Options.get_why3_counterexample ()) then begin + + if Options.get_output_format () == Why3 || + (Options.get_why3_counterexample ()) then begin + (* TODO : add a printer to output constraint with assertions *) + Why3CounterExample.output_constraints fmt [] + end; + + Printer.print_fmt ~flushed:false fmt "@[unknown@ "; + SmtlibCounterExample.output_constants_counterexample fmt + constants functions; + + Printer.print_fmt fmt "@])"; + end + else if Options.get_output_format () == Native then begin + Printer.print_fmt ~flushed:false fmt "@[(@ "; + Printer.print_fmt ~flushed:false fmt "Constants@ "; + AECounterExample.output_constants_counterexample fmt constants; + Printer.print_fmt ~flushed:false fmt "Functions@ "; + AECounterExample.output_functions_counterexample fmt functions; + Printer.print_fmt ~flushed:false fmt "Arrays@ "; + AECounterExample.output_arrays_counterexample fmt arrays; + Printer.print_fmt fmt "@])"; + end + else + Printer.print_fmt fmt "Output format not recognised" \ No newline at end of file diff --git a/src/lib/models/models.mli b/src/lib/models/models.mli new file mode 100644 index 000000000..7f2ff43f0 --- /dev/null +++ b/src/lib/models/models.mli @@ -0,0 +1,40 @@ +(******************************************************************************) +(* *) +(* Alt-Ergo: The SMT Solver For Software Verification *) +(* Copyright (C) 2020-2020 --- OCamlPro SAS *) +(* *) +(* This file is distributed under the terms of the license indicated *) +(* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) +(* present, please contact us to clarify licensing. *) +(* *) +(******************************************************************************) + +(** {1 Models module} *) + +module Sorts : Map.S with type key = string + +val sorts : Parsed.decl Seq.t -> unit + +module Profile : sig + + module P : Map.S with type key = + Symbols.t * Ty.t list * Ty.t + module V : Set.S with type elt = + (Expr.t * (Shostak.Combine.r * string)) list * + (Shostak.Combine.r * string) + + val add : P.key -> V.elt -> V.t P.t -> V.t P.t + val iter : (P.key -> 'a -> unit) -> 'a P.t -> unit + val fold : (P.key -> 'a -> 'b -> 'b) -> 'a P.t -> 'b -> 'b + val empty : 'a P.t + val is_empty : 'a P.t -> bool +end + +(** Print the given counterexample on the given formatter with the + corresponding format setted with Options.get_output_format *) +val output_concrete_model : + Format.formatter -> + Profile.V.t Profile.P.t -> + Profile.V.t Profile.P.t -> + Profile.V.t Profile.P.t -> + unit diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 374285f91..c1f6e9db5 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1248,7 +1248,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct | Some env -> let cs_tbox = Th.get_case_split_env env.tbox in let uf = Ccx.Main.get_union_find cs_tbox in - Uf.output_concrete_model uf + Uf.output_concrete_model (get_fmt_mdl ()) uf end; return_function () @@ -1266,7 +1266,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let env = compute_concrete_model env compute in let uf = Ccx.Main.get_union_find (Th.get_case_split_env env.tbox) in Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); - Uf.output_concrete_model uf; + Uf.output_concrete_model (get_fmt_mdl ()) uf; terminated_normally := true; return_function env diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index 50f86c847..f12565cfb 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1045,211 +1045,14 @@ let assign_next env = Debug.check_invariants "assign_next" env; res, env -module Profile = struct - - module P = Map.Make - (struct - type t = Sy.t * Ty.t list * Ty.t - - let (|||) c1 c2 = if c1 <> 0 then c1 else c2 - - let compare (a1, b1, c1) (a2, b2, c2) = - let l1_l2 = List.length b1 - List.length b2 in - let c = l1_l2 ||| (Ty.compare c1 c2) ||| (Sy.compare a1 a2) in - if c <> 0 then c - else - let c = ref 0 in - try - List.iter2 - (fun ty1 ty2 -> - let d = Ty.compare ty1 ty2 in - if d <> 0 then begin c := d; raise Exit end - ) b1 b2; - 0 - with - | Exit -> assert (!c <> 0); !c - | Invalid_argument _ -> assert false - end) - - module V = Set.Make - (struct - type t = (E.t * (X.r * string)) list * (X.r * string) - let compare (l1, (v1,_)) (l2, (v2,_)) = - let c = X.hash_cmp v1 v2 in - if c <> 0 then c - else - let c = ref 0 in - try - List.iter2 - (fun (_,(x,_)) (_,(y,_)) -> - let d = X.hash_cmp x y in - if d <> 0 then begin c := d; raise Exit end - ) l1 l2; - !c - with - | Exit -> !c - | Invalid_argument _ -> List.length l1 - List.length l2 - end) - - let add p v mp = - let prof_p = try P.find p mp with Not_found -> V.empty in - if V.mem v prof_p then mp - else P.add p (V.add v prof_p) mp - - let iter = P.iter - - let fold = P.fold - - let empty = P.empty - - let is_empty = P.is_empty -end - -let assert_has_depth_one (e, _) = - match X.term_extract e with - | Some t, true -> assert (E.const_term t); - | _ -> () - -module SMT2LikeModelOutput = struct - - let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr - - let x_print_why3 fmt (_ , ppr) = - fprintf fmt "%s" - (match ppr with - | "True" -> "true" - | "False" -> "false" - | _ -> ppr) - - let print_args fmt l = - match l with - | [] -> assert false - | [_,e] -> - fprintf fmt "%a" x_print e; - | (_,e) :: l -> - fprintf fmt "%a" x_print e; - List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l - - let print_symb ty fmt f = - match f, ty with - | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> - fprintf fmt "%a__%s" Sy.print f (Hstring.view name) - - | _ -> Sy.print fmt f - - let output_constants_model cprofs = - (*printf "; constants:@.";*) - Profile.iter - (fun (f, _xs_ty, ty) st -> - match Profile.V.elements st with - | [[], rep] -> - (*printf " (%a %a) ; %a@." - (print_symb ty) f x_print rep Ty.print ty*) - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "(s(%d): %a, rep: %a)@ " - (List.length _xs_ty) (print_symb ty) f x_print rep - | _ -> assert false - ) cprofs - - let pp_type fmt t = - let open Ty in - Format.fprintf fmt "%s" (match t with - | Tint -> "Int" - | Treal -> "Real" - | Tbool -> "Bool" - | Text (_, t) -> Hstring.view t - | _ -> asprintf "%a" print t - ) - - let get_qtmk f qtmks = - try Models.Sorts.find f qtmks - with Not_found -> f - - let output_constants_why3_counterexample cprofs fprofs = - (* Models.Sorts.iter (fun f (nbargs, t) -> - * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !Models.h; *) - Printer.print_fmt ~flushed:false (get_fmt_mdl()) "@[(model@,"; - let qtmks = Profile.fold - (fun (f, _xs_ty, ty) st acc -> - Profile.V.fold - (fun (xs, rep) acc -> - let s = asprintf "%a" (print_symb ty) f in - let rep = asprintf "%a" x_print rep in - match Models.get_type s, Models.get_type rep with - | Some ts, Some tr when String.equal ts tr -> - Models.Sorts.add - rep (Format.asprintf "(%s %a)" s print_args xs) - acc - | _ -> acc; - ) st acc; - ) fprofs Models.Sorts.empty in - Profile.iter - (fun (f, _xs_ty, ty) st -> - match Profile.V.elements st with - | [[], rep] -> - let rep = Format.asprintf "%a" x_print_why3 rep in - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "(define-fun %a () %a %s)@ " - (print_symb ty) f pp_type ty (get_qtmk rep qtmks) - | _ -> assert false - ) cprofs - - let output_functions_model fprofs = - if not (Profile.is_empty fprofs) then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - (*printf "@.; functions:@.";*) - Profile.iter - (fun (f, _xs_ty, ty) st -> - (*printf " ; fun %a : %a -> %a@." - (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - Profile.V.iter - (fun (xs, rep) -> - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "((s: %a, args: %a) rep: %a)@ " - (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one x) xs; - )st; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; - ) fprofs; - Printer.print_fmt (get_fmt_mdl ()) "@]"; - end - - let output_arrays_model arrays = - if not (Profile.is_empty arrays) then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - (*printf "; arrays:@.";*) - Profile.iter - (fun (f, xs_ty, ty) st -> - match xs_ty with - [_] -> - (*printf " ; array %a : %a -> %a@." - (print_symb ty) f Ty.print tyi Ty.print ty;*) - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[@ "; - Profile.V.iter - (fun (xs, rep) -> - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) - "((%a %a) %a)@ " - (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one x) xs; - )st; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@]@ "; - | _ -> assert false - - ) arrays; - Printer.print_fmt (get_fmt_mdl ()) "@]"; - end - -end -(* of module SMT2LikeModelOutput *) +(**** Counter examples functions ****) let is_a_good_model_value (x, _) = match X.leaves x with [] -> true | [y] -> X.equal x y | _ -> false - let model_repr_of_term t env mrepr = try ME.find t mrepr, mrepr with Not_found -> @@ -1266,96 +1069,69 @@ let model_repr_of_term t env mrepr = let e = X.choose_adequate_model t rep cls in e, ME.add t e mrepr +let compute_concrete_model ({ make; _ } as env) = + ME.fold + (fun t _mk ((fprofs, cprofs, carrays, mrepr) as acc) -> + let { E.f; xs; ty; _ } = + match E.term_view t with + | E.Not_a_term _ -> assert false + | E.Term tt -> tt + in + if X.is_solvable_theory_symbol f ty + || E.is_fresh t || E.is_fresh_skolem t + || E.equal t E.vrai || E.equal t E.faux + then + acc + else + let xs, tys, mrepr = + List.fold_left + (fun (xs, tys, mrepr) x -> + let rep_x, mrepr = model_repr_of_term x env mrepr in + assert (is_a_good_model_value rep_x); + (x, rep_x)::xs, + (E.type_info x)::tys, + mrepr + ) ([],[], mrepr) (List.rev xs) + in + let rep, mrepr = model_repr_of_term t env mrepr in + assert (is_a_good_model_value rep); + match f, xs, ty with + | Sy.Op Sy.Set, _, _ -> acc + + | Sy.Op Sy.Get, [(_,(a,_));((_,(i,_)) as e)], _ -> + begin + match X.term_extract a with + | Some ta, true -> + let { E.f = f_ta; xs=xs_ta; _ } = + match E.term_view ta with + | E.Not_a_term _ -> assert false + | E.Term tt -> tt + in + assert (xs_ta == []); + fprofs, + cprofs, + Models.Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, + mrepr + + | _ -> assert false + end + + | _ -> + if tys == [] then + fprofs, Models.Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, + mrepr + else + Models.Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, + mrepr + + ) make + (Models.Profile.empty, Models.Profile.empty, Models.Profile.empty, ME.empty) -let output_concrete_model ({ make; _ } as env) = +let output_concrete_model fmt env = if get_interpretation () then - let why3_counterexample = - let why3_output = - match Options.get_output_format () with - | Why3 -> true - | Smtlib2 | Native | Unknown _ -> false - in - why3_output || Options.get_why3_counterexample () - in let functions, constants, arrays, _ = - ME.fold - (fun t _mk ((fprofs, cprofs, carrays, mrepr) as acc) -> - let { E.f; xs; ty; _ } = - match E.term_view t with - | E.Not_a_term _ -> assert false - | E.Term tt -> tt - in - if X.is_solvable_theory_symbol f ty - || E.is_fresh t || E.is_fresh_skolem t - || E.equal t E.vrai || E.equal t E.faux - then - acc - else - let xs, tys, mrepr = - List.fold_left - (fun (xs, tys, mrepr) x -> - let rep_x, mrepr = model_repr_of_term x env mrepr in - assert (is_a_good_model_value rep_x); - (x, rep_x)::xs, - (E.type_info x)::tys, - mrepr - ) ([],[], mrepr) (List.rev xs) - in - let rep, mrepr = model_repr_of_term t env mrepr in - assert (is_a_good_model_value rep); - match f, xs, ty with - | Sy.Op Sy.Set, _, _ -> acc - - | Sy.Op Sy.Get, [(_,(a,_));((_,(i,_)) as e)], _ -> - begin - match X.term_extract a with - | Some ta, true -> - let { E.f = f_ta; xs=xs_ta; _ } = - match E.term_view ta with - | E.Not_a_term _ -> assert false - | E.Term tt -> tt - in - assert (xs_ta == []); - fprofs, - cprofs, - Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, - mrepr - - | _ -> assert false - end - - | _ -> - if tys == [] then - fprofs, Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, - mrepr - else - Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, - mrepr - - ) make (Profile.empty, Profile.empty, Profile.empty, ME.empty) - in - if why3_counterexample then begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[unknown@ "; - SMT2LikeModelOutput.output_constants_why3_counterexample - constants functions; - Printer.print_fmt (get_fmt_mdl ()) "@])"; - - (* Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[ME@ "; - * ME.iter (fun t r -> - * Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "%a -> %a@ " - * Expr.print t X.print r) make; - * Printer.print_fmt (get_fmt_mdl ()) "@])"; *) - end - else begin - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "@[(@ "; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Constants@ "; - SMT2LikeModelOutput.output_constants_model constants; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Functions@ "; - SMT2LikeModelOutput.output_functions_model functions; - Printer.print_fmt ~flushed:false (get_fmt_mdl ()) "Arrays@ "; - SMT2LikeModelOutput.output_arrays_model arrays; - Printer.print_fmt (get_fmt_mdl ()) "@])"; - end + compute_concrete_model env in + Models.output_concrete_model fmt functions constants arrays let save_cache () = LX.save_cache () diff --git a/src/lib/reasoners/uf.mli b/src/lib/reasoners/uf.mli index 03d742d46..18fd46000 100644 --- a/src/lib/reasoners/uf.mli +++ b/src/lib/reasoners/uf.mli @@ -26,6 +26,8 @@ (* *) (******************************************************************************) +(** {1 Uf module} *) + type t type r = Shostak.Combine.r @@ -68,8 +70,19 @@ val is_normalized : t -> r -> bool val assign_next : t -> (r Xliteral.view * bool * Th_util.lit_origin) list * t val output_concrete_model : t -> unit +(** {2 Counterexample function} *) + +(** Compute a counterexample using the Uf environment and then print it on the + given formatter with the corresponding format setted with + Options.get_output_format *) +val output_concrete_model : + Format.formatter -> + prop_model:Expr.Set.t -> + t -> + unit + +(** saves the module's cache *) val save_cache : unit -> unit -(* saves the module's cache *) -val reinit_cache : unit -> unit (** reinitializes the module's cache with the saved one *) +val reinit_cache : unit -> unit From 0f327c475e21025969eb18444ece2bb1b8a5ba39 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 16 Oct 2020 15:43:44 +0200 Subject: [PATCH 11/68] Prototype of printer for records in smt format --- src/lib/models/models.ml | 73 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 71 insertions(+), 2 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 1aac8ecf3..8f9a083b0 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -201,6 +201,45 @@ let debug = false module SmtlibCounterExample = struct + module Records = Map.Make(String) + let records = ref Records.empty + + let add_records_destr record destr rep = + match Records.find_opt record !records with + | None -> + records := Records.add record [(destr,rep)] !records + | Some destrs -> + records := Records.add record ((destr,rep) :: destrs) !records + + let mk_records_constr + { Ty.name = n; record_constr = cstr; lbs = lbs; _} = + let rec find_destrs destr destrs = + match destrs with + | [] -> None + | (d,rep) :: destrs -> + let s = Str.regexp_string destr in + try let _ = Str.search_forward s d 0 in + Some rep + with Not_found -> + find_destrs destr destrs + in + + let print_destr fmt (destrs,lbs) = + List.iter (fun (destr, _ty_destr) -> + let destr = Hstring.view destr in + match find_destrs destr destrs with + | None -> fprintf fmt " " destr + | Some rep -> fprintf fmt "%s " rep + ) (List.rev lbs) + in + match Records.find_opt (Hstring.view n) !records with + | None -> assert false + | Some [] -> assert false + | Some destrs -> + asprintf "%s %a" + (Hstring.view cstr) + print_destr (destrs,lbs) + let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr let x_print_why3 fmt (_ , ppr) = @@ -228,13 +267,23 @@ module SmtlibCounterExample = struct let pp_type fmt t = let open Ty in + (* let print_destr fmt (destr, ty) = + fprintf fmt "(%s:%a) " (Hstring.view destr) print ty + in *) Format.fprintf fmt "%s" (match t with | Tint -> "Int" | Treal -> "Real" | Tbool -> "Bool" | Text (_, t) -> Hstring.view t - | Trecord { args = lv; name = n; record_constr = cstr ; _} -> - asprintf "%a %s %s" print_list lv (Hstring.view n) (Hstring.view cstr) + | Trecord { args = lv; name = n; _ } -> + (* asprintf "(args:%a) %s (constr:%s) (destr:%a)" + print_list lv + (Hstring.view n) + (Hstring.view cstr) + (Printer.pp_list_no_space print_destr) lbs *) + asprintf "%a %s" + print_list lv + (Hstring.view n) | _ -> asprintf "%a" print t ) @@ -257,12 +306,14 @@ module SmtlibCounterExample = struct Profile.V.fold (fun (xs, rep) acc -> + let print_xs fmt (e,(r,xs)) = fprintf fmt "(%a / %a / %s), " E.print e X.print r xs in let print_rep fmt (r,rep) = fprintf fmt "(%a %s) " X.print r rep in + if debug then Printer.print_dbg ~header:false "xs:%a / rep:%a" (Printer.pp_list_no_space print_xs) xs @@ -270,6 +321,15 @@ module SmtlibCounterExample = struct let s = asprintf "%a" (print_symb ty) f in let rep = asprintf "%a" x_print rep in + begin match xs_ty with + | [Ty.Trecord r] -> + add_records_destr + (Hstring.view r.name) + (Sy.to_string f) + rep + | _ -> () + end; + match get_type s, get_type rep with | Some ts, Some tr when String.equal ts tr -> (* Printer.print_dbg "s: %s(%s) / rep: %s (%s)" @@ -308,6 +368,15 @@ module SmtlibCounterExample = struct Printer.print_dbg ~header:false "rep:%s / lsit lenght %d" rep (List.length xs_ty); + let qtmks = + match ty with + | Ty.Trecord r -> + let constr = mk_records_constr r in + let sconstr = sprintf "(%s)" constr in + Sorts.add rep sconstr qtmks + | _ -> qtmks + in + Printer.print_fmt ~flushed:false fmt "(define-fun %a () %a %s)@ " (print_symb ty) f pp_type ty (get_qtmk rep qtmks) From b6ac9a16387c938aa7e38559748e669519e9586e Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 16 Oct 2020 15:44:15 +0200 Subject: [PATCH 12/68] Directly use rep of bool value for counterexamples --- src/lib/reasoners/shostak.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lib/reasoners/shostak.ml b/src/lib/reasoners/shostak.ml index 8c9951c2e..0de3a84de 100644 --- a/src/lib/reasoners/shostak.ml +++ b/src/lib/reasoners/shostak.ml @@ -618,6 +618,7 @@ struct X6.choose_adequate_model t rep l | Ty.Trecord _ -> X2.choose_adequate_model t rep l | Ty.Tfarray _ -> X4.choose_adequate_model t rep l + | Ty.Tbool -> rep, asprintf "%a" print rep | _ -> let acc = List.fold_left From 4ed1c50e08ba17311c9348bfd2436cb52b39ca03 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 16 Oct 2020 15:50:42 +0200 Subject: [PATCH 13/68] fix destr list rev --- src/lib/models/models.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 8f9a083b0..7b389049b 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -230,7 +230,7 @@ module SmtlibCounterExample = struct match find_destrs destr destrs with | None -> fprintf fmt " " destr | Some rep -> fprintf fmt "%s " rep - ) (List.rev lbs) + ) lbs in match Records.find_opt (Hstring.view n) !records with | None -> assert false From e27aad584c99d20461b5a2f15ce4b604c968c1b5 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Mon, 19 Oct 2020 14:23:25 +0200 Subject: [PATCH 14/68] Clean choose_adequate_model for boolean constant --- src/lib/reasoners/shostak.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/lib/reasoners/shostak.ml b/src/lib/reasoners/shostak.ml index 0de3a84de..e50ff11dc 100644 --- a/src/lib/reasoners/shostak.ml +++ b/src/lib/reasoners/shostak.ml @@ -608,6 +608,12 @@ struct opt let choose_adequate_model t rep l = + let is_true_or_false r = + let re,_rb = term_extract r in + match re with + | None -> false + | Some e -> (Expr.equal Expr.vrai e) || (Expr.equal Expr.faux e) + in let r, pprint = match Expr.type_info t with | Ty.Tint @@ -618,7 +624,8 @@ struct X6.choose_adequate_model t rep l | Ty.Trecord _ -> X2.choose_adequate_model t rep l | Ty.Tfarray _ -> X4.choose_adequate_model t rep l - | Ty.Tbool -> rep, asprintf "%a" print rep + | Ty.Tbool when is_true_or_false rep -> + rep, asprintf "%a" print rep | _ -> let acc = List.fold_left From b5ea9641af50ecbaef24f9c70c2fca258ddbb314 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 17 Dec 2020 11:41:29 +0100 Subject: [PATCH 15/68] Add `fast` option that disable greedier instantiation phase --- src/bin/common/parse_command.ml | 10 ++++++++-- src/lib/reasoners/fun_sat.ml | 2 ++ src/lib/util/options.ml | 5 +++++ src/lib/util/options.mli | 7 +++++++ 4 files changed, 22 insertions(+), 2 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 8e65290a8..9d1e1c0b7 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -336,7 +336,7 @@ let mk_profiling_opt cumulative_time_profiling profiling set_cumulative_time_profiling cumulative_time_profiling; `Ok() -let mk_quantifiers_opt instantiation_heuristic instantiate_after_backjump +let mk_quantifiers_opt instantiation_heuristic fast instantiate_after_backjump max_multi_triggers_size nb_triggers no_ematching no_user_triggers normalize_instances triggers_var = @@ -345,6 +345,7 @@ let mk_quantifiers_opt instantiation_heuristic instantiate_after_backjump set_nb_triggers nb_triggers; set_normalize_instances normalize_instances; set_instantiation_heuristic instantiation_heuristic; + set_fast fast; set_instantiate_after_backjump instantiate_after_backjump; set_max_multi_triggers_size max_multi_triggers_size; set_triggers_var triggers_var; @@ -1027,6 +1028,11 @@ let parse_quantifiers_opt = Arg.(value & opt instantiation_heuristic_conv IAuto & info ["instantiation-heuristic"] ~docv ~docs ~doc) in + let fast = + let doc = "Heuristic that disable heavy instantiation with triggers-var \ + (greedier)" in + Arg.(value & flag & info ["fast"] ~docs ~doc) in + let instantiate_after_backjump = let doc = "Make a (normal) instantiation round after every backjump/backtrack." in @@ -1067,7 +1073,7 @@ let parse_quantifiers_opt = let doc = "Allows variables as triggers." in Arg.(value & flag & info ["triggers-var"] ~docs ~doc) in - Term.(ret (const mk_quantifiers_opt $ instantiation_heuristic $ + Term.(ret (const mk_quantifiers_opt $ instantiation_heuristic $ fast $ instantiate_after_backjump $ max_multi_triggers_size $ nb_triggers $ no_ematching $ no_user_triggers $ normalize_instances $ triggers_var diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index c1f6e9db5..d8cafd0a5 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1430,10 +1430,12 @@ are not Th-reduced"; semantic_th_inst env gre_inst ~rm_clauses:false ~loop:4 in let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env + else if not greedier || (get_fast ()) then greedy_instantiation_aux env true else return_answer env (get_before_end_interpretation ()) (fun e -> raise (I_dont_know e)) + let normal_instantiation env try_greedy = Debug.print_nb_related env; let env = do_case_split env Util.BeforeMatching in diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 1f797914f..e9b9ef5ed 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -351,7 +351,9 @@ let get_verbose () = !verbose (** Quantifiers options *) + let instantiation_heuristic = ref IAuto +let fast = ref false let instantiate_after_backjump = ref false let max_multi_triggers_size = ref 4 let nb_triggers = ref 2 @@ -360,7 +362,9 @@ let no_user_triggers = ref false let normalize_instances = ref false let triggers_var = ref false + let set_instantiation_heuristic i = instantiation_heuristic := i +let set_fast b = fast := b let set_instantiate_after_backjump b = instantiate_after_backjump := b let set_max_multi_triggers_size b = max_multi_triggers_size := b let set_nb_triggers b = nb_triggers := b @@ -371,6 +375,7 @@ let set_triggers_var b = triggers_var := b let get_instantiation_heuristic () = !instantiation_heuristic let get_greedy () = !instantiation_heuristic = IGreedy +let get_fast () = !fast let get_instantiate_after_backjump () = !instantiate_after_backjump let get_max_multi_triggers_size () = !max_multi_triggers_size let get_nb_triggers () = !nb_triggers diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 59f70fa75..339e7751e 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -178,6 +178,9 @@ val set_frontend : string -> unit {!val:get_instantiation_heuristic} *) val set_instantiation_heuristic : instantiation_heuristic -> unit +(** Set [fast] accessible with {!val:get_fast} *) +val set_fast : bool -> unit + (** Set [inline_lets] accessible with {!val:get_inline_lets} *) val set_inline_lets : bool -> unit @@ -786,6 +789,10 @@ val get_instantiation_heuristic : unit -> instantiation_heuristic val get_greedy : unit -> bool (** Default to [false] *) +(** [true] if greedier instantiation phase is disable. *) +val get_fast : unit -> bool +(** Default to [false] *) + (** [true] if a (normal) instantiation round is made after every backjump/backtrack.*) val get_instantiate_after_backjump : unit -> bool From 49b0b4b0fb589c4e4dac47ee53a51c596eeec38c Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Tue, 19 Jan 2021 18:01:18 +0100 Subject: [PATCH 16/68] remove greedier and get_fast in fun_sat --- src/lib/reasoners/fun_sat.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index d8cafd0a5..482ee0648 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1430,7 +1430,6 @@ are not Th-reduced"; semantic_th_inst env gre_inst ~rm_clauses:false ~loop:4 in let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env - else if not greedier || (get_fast ()) then greedy_instantiation_aux env true else return_answer env (get_before_end_interpretation ()) (fun e -> raise (I_dont_know e)) From 77ae13a0bb1c03ae0aba6de37d3bae881d09e836 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 13 Nov 2020 16:08:18 +0100 Subject: [PATCH 17/68] Prototype to output constraint as model if output is set to why3 --- src/lib/models/models.ml | 114 ++++++++++++++++++---------- src/lib/models/models.mli | 1 + src/lib/reasoners/ccx.ml | 7 +- src/lib/reasoners/ccx.mli | 2 +- src/lib/reasoners/fun_sat.ml | 16 ++-- src/lib/reasoners/satml_frontend.ml | 3 +- src/lib/reasoners/shostak.ml | 2 +- src/lib/reasoners/theory.ml | 8 +- src/lib/reasoners/theory.mli | 2 +- src/lib/reasoners/uf.ml | 12 +-- src/lib/reasoners/uf.mli | 8 +- src/lib/structures/expr.ml | 80 +++++++++++++++---- src/lib/structures/expr.mli | 3 +- src/lib/util/options.ml | 2 + src/lib/util/options.mli | 4 + src/lib/util/printer.ml | 4 + src/lib/util/printer.mli | 5 ++ 17 files changed, 188 insertions(+), 85 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 7b389049b..514a2e594 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -109,6 +109,8 @@ module Profile = struct let is_empty = P.is_empty end +let constraints = ref Sorts.empty + let assert_has_depth_one (e, _) = match X.term_extract e with | Some t, true -> assert (E.depth t = 1); @@ -265,27 +267,63 @@ module SmtlibCounterExample = struct | _ -> Sy.print fmt f - let pp_type fmt t = + let to_string_type t = let open Ty in - (* let print_destr fmt (destr, ty) = - fprintf fmt "(%s:%a) " (Hstring.view destr) print ty - in *) - Format.fprintf fmt "%s" (match t with - | Tint -> "Int" - | Treal -> "Real" - | Tbool -> "Bool" - | Text (_, t) -> Hstring.view t - | Trecord { args = lv; name = n; _ } -> - (* asprintf "(args:%a) %s (constr:%s) (destr:%a)" - print_list lv - (Hstring.view n) - (Hstring.view cstr) - (Printer.pp_list_no_space print_destr) lbs *) - asprintf "%a %s" - print_list lv - (Hstring.view n) - | _ -> asprintf "%a" print t - ) + match t with + | Tint -> "Int" + | Treal -> "Real" + | Tbool -> "Bool" + | Text (_, t) -> Hstring.view t + | Trecord { args = lv; name = n; _ } -> + (* asprintf "(args:%a) %s (constr:%s) (destr:%a)" + print_list lv + (Hstring.view n) + (Hstring.view cstr) + (Printer.pp_list_no_space print_destr) lbs *) + asprintf "%a %s" + print_list lv + (Hstring.view n) + | _ -> asprintf "%a" print t + + let pp_type fmt t = + Format.fprintf fmt "%s" (to_string_type t) + + let pp_term fmt t = + match E.symbol_info t with + | Sy.Name (n,_) -> begin + try + let constraint_name,_ty_name = + Sorts.find (Hstring.view n) !constraints in + fprintf fmt "%s" constraint_name + with _ -> + let constraint_name = "c_"^(Hstring.view n) in + constraints := Sorts.add (Hstring.view n) + (constraint_name,to_string_type (E.type_info t)) !constraints; + fprintf fmt "%s" constraint_name + end + | _ -> E.print fmt t + + let print_fun_def fmt name args ty t = + let i = ref 0 in + let print_args fmt ty = + incr i; + (** TODO create fresh variable *) + Format.fprintf fmt "(%s %a)" + (sprintf "x_%d" !i) + pp_type ty + in + let defined_value = + try + fst (Sorts.find (Sy.to_string name) !constraints) + with _ -> t + in + + Printer.print_fmt ~flushed:false fmt + "(define-fun %a (%a) %a %s)@ " + (print_symb ty) name + (Printer.pp_list_space print_args) args + pp_type ty + defined_value let get_qtmk f qtmks = try Sorts.find f qtmks @@ -294,7 +332,6 @@ module SmtlibCounterExample = struct let output_constants_counterexample fmt cprofs fprofs = (* Sorts.iter (fun f (nbargs, t) -> * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !h; *) - Printer.print_fmt ~flushed:false (get_fmt_mdl()) "@[(model@,"; let qtmks = Profile.fold (fun (f, xs_ty, ty) st acc -> if debug then @@ -305,8 +342,6 @@ module SmtlibCounterExample = struct Profile.V.fold (fun (xs, rep) acc -> - - let print_xs fmt (e,(r,xs)) = fprintf fmt "(%a / %a / %s), " E.print e X.print r xs in @@ -377,9 +412,7 @@ module SmtlibCounterExample = struct | _ -> qtmks in - Printer.print_fmt ~flushed:false fmt - "(define-fun %a () %a %s)@ " - (print_symb ty) f pp_type ty (get_qtmk rep qtmks) + print_fun_def fmt f [] ty (get_qtmk rep qtmks) | _ -> assert false ) cprofs @@ -387,34 +420,37 @@ end (* of module SmtlibCounterExample *) module Why3CounterExample = struct - let output_constraints fmt constraints = - let print_constraints fmt _constraint = - (* TODO *) - fprintf fmt "" - in - Printer.print_fmt fmt ";; Constraints@ %a" - (Printer.pp_list_no_space print_constraints) constraints + + let output_constraints fmt prop_model = + SE.iter (fun e -> + (fprintf str_formatter "(assert %a)@ " SmtlibCounterExample.pp_term e) + ) prop_model; + Sorts.iter (fun _ (name,ty) -> + Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty + ) !constraints; + Printer.print_fmt fmt "%s" (flush_str_formatter ()) + end (* of module Why3CounterExample *) -let output_concrete_model fmt functions constants arrays = +let output_concrete_model fmt props functions constants arrays = if get_interpretation () then if Options.get_output_format () == Why3 || Options.get_output_format () == Smtlib2 || (Options.get_why3_counterexample ()) then begin + Printer.print_fmt ~flushed:false fmt "@[unknown@ "; + Printer.print_fmt ~flushed:false fmt "@[(model@,"; if Options.get_output_format () == Why3 || (Options.get_why3_counterexample ()) then begin - (* TODO : add a printer to output constraint with assertions *) - Why3CounterExample.output_constraints fmt [] + Why3CounterExample.output_constraints fmt props end; - Printer.print_fmt ~flushed:false fmt "@[unknown@ "; SmtlibCounterExample.output_constants_counterexample fmt constants functions; - Printer.print_fmt fmt "@])"; + Printer.print_fmt fmt "@]@ )"; end else if Options.get_output_format () == Native then begin Printer.print_fmt ~flushed:false fmt "@[(@ "; @@ -427,4 +463,4 @@ let output_concrete_model fmt functions constants arrays = Printer.print_fmt fmt "@])"; end else - Printer.print_fmt fmt "Output format not recognised" \ No newline at end of file + Printer.print_fmt fmt "Output format not recognised" diff --git a/src/lib/models/models.mli b/src/lib/models/models.mli index 7f2ff43f0..e4a75c942 100644 --- a/src/lib/models/models.mli +++ b/src/lib/models/models.mli @@ -34,6 +34,7 @@ end corresponding format setted with Options.get_output_format *) val output_concrete_model : Format.formatter -> + Expr.Set.t -> Profile.V.t Profile.P.t -> Profile.V.t Profile.P.t -> Profile.V.t Profile.P.t -> diff --git a/src/lib/reasoners/ccx.ml b/src/lib/reasoners/ccx.ml index 6159c82a7..4d2626420 100644 --- a/src/lib/reasoners/ccx.ml +++ b/src/lib/reasoners/ccx.ml @@ -78,7 +78,8 @@ module type S = sig val are_distinct : t -> Expr.t -> Expr.t -> Th_util.answer val cl_extract : t -> Expr.Set.t list val term_repr : t -> Expr.t -> init_term:bool -> Expr.t - val print_model : Format.formatter -> t -> unit + val print_model : Format.formatter -> complete_model:bool -> t -> unit + val get_union_find : t -> Uf.t val assume_th_elt : t -> Expr.th_elt -> Explanation.t -> t @@ -726,9 +727,9 @@ module Main : S = struct let get_union_find env = env.uf - let print_model fmt env = + let print_model fmt ~complete_model env = let zero = ref true in - let eqs, neqs = Uf.model env.uf in + let eqs, neqs = Uf.model ~complete_model env.uf in let rs = List.fold_left (fun acc (r, l, to_rel) -> if l != [] then begin diff --git a/src/lib/reasoners/ccx.mli b/src/lib/reasoners/ccx.mli index e4aff6597..f3fe16529 100644 --- a/src/lib/reasoners/ccx.mli +++ b/src/lib/reasoners/ccx.mli @@ -71,7 +71,7 @@ module type S = sig val are_distinct : t -> Expr.t -> Expr.t -> Th_util.answer val cl_extract : t -> Expr.Set.t list val term_repr : t -> Expr.t -> init_term:bool -> Expr.t - val print_model : Format.formatter -> t -> unit + val print_model : Format.formatter -> complete_model:bool -> t -> unit val get_union_find : t -> Uf.t val assume_th_elt : t -> Expr.th_elt -> Explanation.t -> t diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 482ee0648..aab8914e1 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -451,11 +451,11 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct | E.Let _ | E.Iff _ | E.Xor _ -> false | E.Not_a_form -> assert false - let extract_prop_model t = + let extract_prop_model ~complete_model t = let s = ref SE.empty in ME.iter (fun f _ -> - if (get_complete_model () && is_literal f) || E.is_in_model f then + if (complete_model && is_literal f) || E.is_in_model f then s := SE.add f !s ) t.gamma; @@ -467,13 +467,13 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let print_model ~header fmt t = Format.print_flush (); if header then fprintf fmt "\nModel\n"; - let pm = extract_prop_model t in + let pm = extract_prop_model ~complete_model:(get_complete_model ()) t in if not (SE.is_empty pm) then begin fprintf fmt "Propositional:"; print_prop_model fmt pm; fprintf fmt "\n"; end; - Th.print_model fmt t.tbox + Th.print_model fmt ~complete_model:(get_complete_model ()) t.tbox let refresh_model_handler = @@ -1248,7 +1248,8 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct | Some env -> let cs_tbox = Th.get_case_split_env env.tbox in let uf = Ccx.Main.get_union_find cs_tbox in - Uf.output_concrete_model (get_fmt_mdl ()) uf + let prop_model = extract_prop_model ~complete_model:true env in + Uf.output_concrete_model (get_fmt_mdl ()) prop_model uf; end; return_function () @@ -1266,7 +1267,10 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let env = compute_concrete_model env compute in let uf = Ccx.Main.get_union_find (Th.get_case_split_env env.tbox) in Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); - Uf.output_concrete_model (get_fmt_mdl ()) uf; + + let prop_model = extract_prop_model ~complete_model:true env in + Uf.output_concrete_model (get_fmt_mdl ()) prop_model uf; + terminated_normally := true; return_function env diff --git a/src/lib/reasoners/satml_frontend.ml b/src/lib/reasoners/satml_frontend.ml index 76337721c..57d20e9f8 100644 --- a/src/lib/reasoners/satml_frontend.ml +++ b/src/lib/reasoners/satml_frontend.ml @@ -330,7 +330,8 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct Format.print_flush (); if header then fprintf fmt "\nModel\n@."; print_propositional_model env fmt; - Th.print_model fmt (SAT.current_tbox env.satml) + Th.print_model fmt ~complete_model:(get_complete_model ()) + (SAT.current_tbox env.satml) let make_explanation _ = Ex.empty (* diff --git a/src/lib/reasoners/shostak.ml b/src/lib/reasoners/shostak.ml index e50ff11dc..f96a2a632 100644 --- a/src/lib/reasoners/shostak.ml +++ b/src/lib/reasoners/shostak.ml @@ -608,7 +608,7 @@ struct opt let choose_adequate_model t rep l = - let is_true_or_false r = + let is_true_or_false r = let re,_rb = term_extract r in match re with | None -> false diff --git a/src/lib/reasoners/theory.ml b/src/lib/reasoners/theory.ml index 093a6568f..8912e9624 100644 --- a/src/lib/reasoners/theory.ml +++ b/src/lib/reasoners/theory.ml @@ -56,7 +56,7 @@ module type S = sig t * Expr.Set.t * int val query : E.t -> t -> Th_util.answer - val print_model : Format.formatter -> t -> unit + val print_model : Format.formatter -> complete_model:bool -> t -> unit val cl_extract : t -> Expr.Set.t list val extract_ground_terms : t -> Expr.Set.t val get_real_env : t -> Ccx.Main.t @@ -65,7 +65,6 @@ module type S = sig val add_term : t -> Expr.t -> add_in_cs:bool -> t val compute_concrete_model : t -> t - val assume_th_elt : t -> Expr.th_elt -> Explanation.t -> t val theories_instances : do_syntactic_matching:bool -> @@ -710,7 +709,8 @@ module Main_Default : S = struct let t, _, _ = assume true [a, Ex.empty, 0, -1] t in t - let print_model fmt t = CC_X.print_model fmt t.gamma_finite + let print_model fmt ~complete_model t = + CC_X.print_model fmt ~complete_model t.gamma_finite let cl_extract env = CC_X.cl_extract env.gamma @@ -776,7 +776,7 @@ module Main_Empty : S = struct let query _ _ = None - let print_model _ _ = () + let print_model _ ~complete_model:_ _ = () let cl_extract _ = [] let extract_ground_terms _ = Expr.Set.empty diff --git a/src/lib/reasoners/theory.mli b/src/lib/reasoners/theory.mli index a0de62ff6..b0341072a 100644 --- a/src/lib/reasoners/theory.mli +++ b/src/lib/reasoners/theory.mli @@ -40,7 +40,7 @@ module type S = sig t * Expr.Set.t * int val query : Expr.t -> t -> Th_util.answer - val print_model : Format.formatter -> t -> unit + val print_model : Format.formatter -> complete_model:bool -> t -> unit val cl_extract : t -> Expr.Set.t list val extract_ground_terms : t -> Expr.Set.t val get_real_env : t -> Ccx.Main.t diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index f12565cfb..2899353d3 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -882,13 +882,13 @@ let mapt_choose m = with Exit -> ()); match !r with Some b -> b | _ -> raise Not_found -let model env = +let model ~complete_model env = let eqs = MapX.fold (fun r cl acc -> let l, to_rel = List.fold_left (fun (l, to_rel) t -> let rt = ME.find t env.make in - if get_complete_model () || E.is_in_model t then + if complete_model || E.is_in_model t then if X.equal rt r then l, (t,rt)::to_rel else t::l, (t,rt)::to_rel else l, to_rel @@ -901,9 +901,9 @@ let model env = let x, rx = mapt_choose makes in let makes = ME.remove x makes in let acc = - if get_complete_model () || E.is_in_model x then + if complete_model || E.is_in_model x then ME.fold (fun y ry acc -> - if (get_complete_model () || E.is_in_model y) + if (complete_model || E.is_in_model y) && (already_distinct env [rx; ry] || already_distinct env [ry; rx]) then [y; x]::acc @@ -1127,11 +1127,11 @@ let compute_concrete_model ({ make; _ } as env) = ) make (Models.Profile.empty, Models.Profile.empty, Models.Profile.empty, ME.empty) -let output_concrete_model fmt env = +let output_concrete_model fmt prop_model env = if get_interpretation () then let functions, constants, arrays, _ = compute_concrete_model env in - Models.output_concrete_model fmt functions constants arrays + Models.output_concrete_model fmt prop_model functions constants arrays let save_cache () = LX.save_cache () diff --git a/src/lib/reasoners/uf.mli b/src/lib/reasoners/uf.mli index 18fd46000..995cf26d9 100644 --- a/src/lib/reasoners/uf.mli +++ b/src/lib/reasoners/uf.mli @@ -57,7 +57,7 @@ val class_of : t -> Expr.t -> Expr.t list val rclass_of : t -> r -> Expr.Set.t val cl_extract : t -> Expr.Set.t list -val model : t -> +val model : complete_model:bool -> t -> (r * Expr.t list * (Expr.t * r) list) list * (Expr.t list) list val print : t -> unit @@ -75,11 +75,7 @@ val output_concrete_model : t -> unit (** Compute a counterexample using the Uf environment and then print it on the given formatter with the corresponding format setted with Options.get_output_format *) -val output_concrete_model : - Format.formatter -> - prop_model:Expr.Set.t -> - t -> - unit +val output_concrete_model : Format.formatter -> Expr.Set.t -> t -> unit (** saves the module's cache *) val save_cache : unit -> unit diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index e349f89f5..3a87b121a 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -426,36 +426,65 @@ let rec print_silent fmt t = begin match lit, xs with | Sy.L_eq, a::l -> - fprintf fmt "(%a%a)" - print a (fun fmt -> List.iter (fprintf fmt " = %a" print)) l + if get_output_smtlib () then + fprintf fmt "(= %a%a)" + print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l + else + fprintf fmt "(%a%a)" + print a (fun fmt -> List.iter (fprintf fmt " = %a" print)) l | Sy.L_neg_eq, [a; b] -> - fprintf fmt "(%a <> %a)" print a print b + if get_output_smtlib () then + fprintf fmt "(not (= %a %a))" print a print b + else + fprintf fmt "(%a <> %a)" print a print b | Sy.L_neg_eq, a::l -> - fprintf fmt "distinct(%a%a)" - print a (fun fmt -> List.iter (fprintf fmt ", %a" print)) l + if get_output_smtlib () then + fprintf fmt "(distinct %a%a)" + print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l + else + fprintf fmt "distinct(%a%a)" + print a (fun fmt -> List.iter (fprintf fmt ", %a" print)) l | Sy.L_built Sy.LE, [a;b] -> - fprintf fmt "(%a <= %a)" print a print b + if get_output_smtlib () then + fprintf fmt "(<= %a %a)" print a print b + else + fprintf fmt "(%a <= %a)" print a print b | Sy.L_built Sy.LT, [a;b] -> - fprintf fmt "(%a < %a)" print a print b + if get_output_smtlib () then + fprintf fmt "(< %a %a)" print a print b + else + fprintf fmt "(%a < %a)" print a print b | Sy.L_neg_built Sy.LE, [a; b] -> - fprintf fmt "(%a > %a)" print a print b + if get_output_smtlib () then + fprintf fmt "(> %a %a)" print a print b + else + fprintf fmt "(%a > %a)" print a print b | Sy.L_neg_built Sy.LT, [a; b] -> - fprintf fmt "(%a >= %a)" print a print b + if get_output_smtlib () then + fprintf fmt "(>= %a %a)" print a print b + else + fprintf fmt "(%a >= %a)" print a print b | Sy.L_neg_pred, [a] -> fprintf fmt "(not %a)" print a | Sy.L_built (Sy.IsConstr hs), [e] -> - fprintf fmt "(%a ? %a)" print e Hstring.print hs + if get_output_smtlib () then + fprintf fmt "((_ is %a) %a)" Hstring.print hs print e + else + fprintf fmt "(%a ? %a)" print e Hstring.print hs | Sy.L_neg_built (Sy.IsConstr hs), [e] -> - fprintf fmt "not (%a ? %a)" print e Hstring.print hs + if get_output_smtlib () then + fprintf fmt "(not ((_ is %a) %a))" Hstring.print hs print e + else + fprintf fmt "not (%a ? %a)" print e Hstring.print hs | (Sy.L_built (Sy.LT | Sy.LE) | Sy.L_neg_built (Sy.LT | Sy.LE) | Sy.L_neg_pred | Sy.L_eq | Sy.L_neg_eq @@ -466,10 +495,19 @@ let rec print_silent fmt t = end | Sy.Op Sy.Get, [e1; e2] -> - fprintf fmt "%a[%a]" print e1 print e2 + if get_output_smtlib () then + fprintf fmt "(select %a %a)" print e1 print e2 + else + fprintf fmt "%a[%a]" print e1 print e2 | Sy.Op Sy.Set, [e1; e2; e3] -> - fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 + if get_output_smtlib () then + fprintf fmt "(store %a %a %a)" + print e1 + print e2 + print e3 + else + fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 | Sy.Op Sy.Concat, [e1; e2] -> fprintf fmt "%a@@%a" print e1 print e2 @@ -478,7 +516,10 @@ let rec print_silent fmt t = fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 | Sy.Op (Sy.Access field), [e] -> - fprintf fmt "%a.%s" print e (Hstring.view field) + if get_output_smtlib () then + fprintf fmt "(%s %a)" (Hstring.view field) print e + else + fprintf fmt "%a.%s" print e (Hstring.view field) | Sy.Op (Sy.Record), _ -> begin match ty with @@ -505,7 +546,10 @@ let rec print_silent fmt t = fprintf fmt "%a(%a)" Hstring.print hs print_list l | Sy.Op _, [e1; e2] -> - fprintf fmt "(%a %a %a)" print e1 Sy.print f print e2 + if get_output_smtlib () then + fprintf fmt "(%a %a %a)" Sy.print f print e1 print e2 + else + fprintf fmt "(%a %a %a)" print e1 Sy.print f print e2 | Sy.Op Sy.Destruct (hs, grded), [e] -> fprintf fmt "%a#%s%a" @@ -520,7 +564,10 @@ let rec print_silent fmt t = fprintf fmt "%a" Sy.print f | _, _ -> - fprintf fmt "%a(%a)" Sy.print f print_list xs + if get_output_smtlib () then + fprintf fmt "(%a %a)" Sy.print f print_list xs + else + fprintf fmt "%a(%a)" Sy.print f print_list xs and print_verbose fmt t = fprintf fmt "(%a : %a)" print_silent t Ty.print t.ty @@ -545,6 +592,7 @@ and print_triggers fmt trs = (** Some auxiliary functions *) let type_info t = t.ty +let symbol_info t = t.f (* unused let is_term e = match e.f with diff --git a/src/lib/structures/expr.mli b/src/lib/structures/expr.mli index 7ba1f5857..e4a357bcb 100644 --- a/src/lib/structures/expr.mli +++ b/src/lib/structures/expr.mli @@ -39,7 +39,7 @@ type decl_kind = | Dpredicate of t | Dfunction of t -type view = private { +type view = { f: Symbols.t; xs: t list; ty: Ty.t; @@ -169,6 +169,7 @@ val is_fresh_skolem : t -> bool val is_int : t -> bool val is_real : t -> bool val type_info : t -> Ty.t +val symbol_info : t -> Symbols.t (** Labeling and models *) diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index e9b9ef5ed..0043178ef 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -323,6 +323,8 @@ let get_model () = !model = MDefault || !model = MComplete let get_complete_model () = !model = MComplete let get_all_models () = !model = MAll let get_output_format () = !output_format +let get_output_smtlib () = + (!output_format = Smtlib2) || (!output_format = Why3) let get_infer_output_format () = !infer_output_format let get_unsat_core () = !unsat_core || !save_used_context || !debug_unsat_core let get_why3_counterexample () = !why3_counterexample diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 339e7751e..5b07dfc01 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -740,6 +740,10 @@ val get_why3_counterexample : unit -> bool val get_output_format : unit -> output_format (** Default to [Native] *) +(** True if the output format is set to smtlib2 or why3 *) +val get_output_smtlib : unit -> bool +(** Default to [false] *) + (** [true] if Alt-Ergo infers automatically the output format according to the the file extension or the input format if set. *) val get_infer_output_format : unit -> bool diff --git a/src/lib/util/printer.ml b/src/lib/util/printer.ml index 741401d20..2541cded5 100644 --- a/src/lib/util/printer.ml +++ b/src/lib/util/printer.ml @@ -265,6 +265,10 @@ let pp_sep_nospace fmt () = fprintf fmt "" let pp_list_no_space f fmt l = pp_print_list ~pp_sep:pp_sep_nospace f fmt l +let pp_sep_space fmt () = fprintf fmt " " + +let pp_list_space f fmt l = + pp_print_list ~pp_sep:pp_sep_space f fmt l (******** Status printers *********) let status_time t = diff --git a/src/lib/util/printer.mli b/src/lib/util/printer.mli index cb87f311d..0b3cf150f 100644 --- a/src/lib/util/printer.mli +++ b/src/lib/util/printer.mli @@ -75,6 +75,11 @@ val pp_list_no_space : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit +(** Print list with separator *) +val pp_list_space : + (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + (** {2 Status Printer} *) (** Print unsat status message from the frontend on the standard output. From 2309ca2d04f3db10b49bff1e4644c0e1da2f7cbf Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 19 Nov 2020 10:53:51 +0100 Subject: [PATCH 18/68] Remove `why3-counter-example` option, use `-o why3` instead --- src/bin/common/parse_command.ml | 9 +-------- src/lib/frontend/frontend.ml | 9 +++------ src/lib/models/models.ml | 6 ++---- src/lib/util/options.ml | 3 --- src/lib/util/options.mli | 4 ---- 5 files changed, 6 insertions(+), 25 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 9d1e1c0b7..b8007e93c 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -309,7 +309,6 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation `Ok() let mk_output_opt interpretation model unsat_core output_format - why3_counterexample = set_infer_output_format output_format; let output_format = match output_format with @@ -320,7 +319,6 @@ let mk_output_opt interpretation model unsat_core output_format set_model model; set_unsat_core unsat_core; set_output_format output_format; - set_why3_counterexample why3_counterexample; `Ok() let mk_profiling_opt cumulative_time_profiling profiling @@ -950,11 +948,6 @@ let parse_output_opt = let doc = "Experimental support for computing and printing unsat-cores." in Arg.(value & flag & info ["u"; "unsat-core"] ~doc) in - let why3_counterexample = - let doc = "Experimental support for computing and printing \ - counter-examples for Why3." in - Arg.(value & flag & info ["w"; "why3-ce"] ~doc) in - let output_format = let doc = Format.sprintf @@ -974,7 +967,7 @@ let parse_output_opt = Term.(ret (const mk_output_opt $ interpretation $ model $ unsat_core $ - output_format $ why3_counterexample + output_format )) let parse_profiling_opt = diff --git a/src/lib/frontend/frontend.ml b/src/lib/frontend/frontend.ml index faad89ac6..6f114993b 100644 --- a/src/lib/frontend/frontend.ml +++ b/src/lib/frontend/frontend.ml @@ -280,12 +280,9 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct | _ -> None in let why3_counterexample = - let why3_output = - match Options.get_output_format () with - | Why3 -> true - | Smtlib2 | Native | Unknown _ -> false - in - why3_output || Options.get_why3_counterexample () + match Options.get_output_format () with + | Why3 | Smtlib2 -> true + | Native | Unknown _ -> false in let time = Time.value() in diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 514a2e594..d99e5d0f3 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -437,13 +437,11 @@ let output_concrete_model fmt props functions constants arrays = if get_interpretation () then if Options.get_output_format () == Why3 || - Options.get_output_format () == Smtlib2 || - (Options.get_why3_counterexample ()) then begin + Options.get_output_format () == Smtlib2 then begin Printer.print_fmt ~flushed:false fmt "@[unknown@ "; Printer.print_fmt ~flushed:false fmt "@[(model@,"; - if Options.get_output_format () == Why3 || - (Options.get_why3_counterexample ()) then begin + if Options.get_output_format () == Why3 then begin Why3CounterExample.output_constraints fmt props end; diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 0043178ef..2fdf73c3f 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -301,14 +301,12 @@ let model = ref MNone let output_format = ref Native let infer_output_format = ref true let unsat_core = ref false -let why3_counterexample = ref false let set_interpretation b = interpretation := b let set_model b = model := b let set_output_format b = output_format := b let set_infer_output_format f = infer_output_format := f = None let set_unsat_core b = unsat_core := b -let set_why3_counterexample b = why3_counterexample := b let get_interpretation () = !interpretation = IFirst || @@ -327,7 +325,6 @@ let get_output_smtlib () = (!output_format = Smtlib2) || (!output_format = Why3) let get_infer_output_format () = !infer_output_format let get_unsat_core () = !unsat_core || !save_used_context || !debug_unsat_core -let get_why3_counterexample () = !why3_counterexample (** Profiling options *) diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 5b07dfc01..85006a4f4 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -196,8 +196,6 @@ val set_input_format : input_format -> unit *) val set_interpretation : interpretation -> unit -val set_why3_counterexample : bool -> unit - (** Set [max_split] accessible with {!val:get_max_split} *) val set_max_split : Numbers.Q.t -> unit @@ -732,8 +730,6 @@ val get_before_inst_interpretation : unit -> bool val get_before_end_interpretation : unit -> bool (** Default to [false] *) -val get_why3_counterexample : unit -> bool - (** Value specifying the default output format. possible values are {ul {- native} {- smtlib2} {- why3}} . *) From 318e6a5bbc21a802add5d11494caa5baf78cc7e0 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 19 Nov 2020 18:38:42 +0100 Subject: [PATCH 19/68] Code cleaning and addition of functions printing with cascade of ite --- src/lib/models/models.ml | 228 ++++++++++++---------------------- src/lib/structures/symbols.ml | 6 +- src/lib/structures/ty.ml | 50 +++++--- 3 files changed, 116 insertions(+), 168 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index d99e5d0f3..6adad0854 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -45,10 +45,6 @@ let sorts parsed = | _ -> () ) parsed -let get_type s = - try let (_, t) = Sorts.find s !h in Some t - with Not_found -> None - module Profile = struct module P = Map.Make @@ -199,8 +195,6 @@ module AECounterExample = struct end (* of module AECounterExample *) -let debug = false - module SmtlibCounterExample = struct module Records = Map.Make(String) @@ -219,11 +213,8 @@ module SmtlibCounterExample = struct match destrs with | [] -> None | (d,rep) :: destrs -> - let s = Str.regexp_string destr in - try let _ = Str.search_forward s d 0 in - Some rep - with Not_found -> - find_destrs destr destrs + if String.equal d destr then Some rep + else find_destrs destr destrs in let print_destr fmt (destrs,lbs) = @@ -244,49 +235,8 @@ module SmtlibCounterExample = struct let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr - let x_print_why3 fmt (_ , ppr) = - fprintf fmt "%s" - (match ppr with - | "True" -> "true" - | "False" -> "false" - | _ -> ppr) - - let print_args fmt l = - match l with - | [] -> assert false - | [_,e] -> - fprintf fmt "%a" x_print e; - | (_,e) :: l -> - fprintf fmt "%a" x_print e; - List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l - - let print_symb ty fmt f = - match f, ty with - | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> - fprintf fmt "%a__%s" Sy.print f (Hstring.view name) - - | _ -> Sy.print fmt f - let to_string_type t = - let open Ty in - match t with - | Tint -> "Int" - | Treal -> "Real" - | Tbool -> "Bool" - | Text (_, t) -> Hstring.view t - | Trecord { args = lv; name = n; _ } -> - (* asprintf "(args:%a) %s (constr:%s) (destr:%a)" - print_list lv - (Hstring.view n) - (Hstring.view cstr) - (Printer.pp_list_no_space print_destr) lbs *) - asprintf "%a %s" - print_list lv - (Hstring.view n) - | _ -> asprintf "%a" print t - - let pp_type fmt t = - Format.fprintf fmt "%s" (to_string_type t) + asprintf "%a" Ty.print t let pp_term fmt t = match E.symbol_info t with @@ -304,14 +254,8 @@ module SmtlibCounterExample = struct | _ -> E.print fmt t let print_fun_def fmt name args ty t = - let i = ref 0 in - let print_args fmt ty = - incr i; - (** TODO create fresh variable *) - Format.fprintf fmt "(%s %a)" - (sprintf "x_%d" !i) - pp_type ty - in + let print_args fmt (ty,name) = + Format.fprintf fmt "(%s %a)" name Ty.print ty in let defined_value = try fst (Sorts.find (Sy.to_string name) !constraints) @@ -320,115 +264,95 @@ module SmtlibCounterExample = struct Printer.print_fmt ~flushed:false fmt "(define-fun %a (%a) %a %s)@ " - (print_symb ty) name - (Printer.pp_list_space print_args) args - pp_type ty + Sy.print name + (Printer.pp_list_space (print_args)) args + Ty.print ty defined_value - let get_qtmk f qtmks = - try Sorts.find f qtmks - with Not_found -> f - - let output_constants_counterexample fmt cprofs fprofs = - (* Sorts.iter (fun f (nbargs, t) -> - * Format.eprintf "Sort: %s(%d): %s@." f nbargs t) !h; *) - let qtmks = Profile.fold - (fun (f, xs_ty, ty) st acc -> - if debug then - Printer.print_dbg "f:%a / xs_ty:%a / ty:%a" - Sy.print f - (Printer.pp_list_no_space Ty.print) xs_ty - Ty.print ty; - - Profile.V.fold - (fun (xs, rep) acc -> - let print_xs fmt (e,(r,xs)) = - fprintf fmt "(%a / %a / %s), " E.print e X.print r xs - in - let print_rep fmt (r,rep) = - fprintf fmt "(%a %s) " X.print r rep - in - - if debug then - Printer.print_dbg ~header:false "xs:%a / rep:%a" - (Printer.pp_list_no_space print_xs) xs - print_rep rep; - let s = asprintf "%a" (print_symb ty) f in - let rep = asprintf "%a" x_print rep in - - begin match xs_ty with - | [Ty.Trecord r] -> - add_records_destr - (Hstring.view r.name) - (Sy.to_string f) - rep - | _ -> () - end; - - match get_type s, get_type rep with - | Some ts, Some tr when String.equal ts tr -> - (* Printer.print_dbg "s: %s(%s) / rep: %s (%s)" - s ts rep tr; *) - if debug then Printer.print_dbg "s:%s(:%s) / rep:%s(:%s)" - s ts rep tr; - Sorts.add - rep (Format.asprintf "(%s %a)" s print_args xs) - acc - | Some ts, Some tr -> - if debug then Printer.print_dbg "s:%s(:%s) / rep:%s(:%s)" - s ts rep tr; - acc; - | Some ts, None -> - if debug then Printer.print_dbg "s:%s(:%s) / rep:%s(:_)" - s ts rep; - acc; - | None, Some tr -> - if debug then Printer.print_dbg "s:%s(:_) / rep:%s(:%s)" - s rep tr; - acc; - | None, None -> - if debug then Printer.print_dbg "s:%s(:_) / rep:%s(:_)" - s rep; - acc; - ) st acc; - ) fprofs Sorts.empty in - if debug then - Printer.print_dbg "CPROFS"; + let output_constants_counterexample fmt cprofs = Profile.iter (fun (f, xs_ty, ty) st -> + assert (xs_ty == []); match Profile.V.elements st with | [[], rep] -> - let rep = Format.asprintf "%a" x_print_why3 rep in - if debug then - Printer.print_dbg ~header:false "rep:%s / lsit lenght %d" - rep (List.length xs_ty); - - let qtmks = + let rep = Format.asprintf "%a" x_print rep in + let rep = match ty with | Ty.Trecord r -> let constr = mk_records_constr r in - let sconstr = sprintf "(%s)" constr in - Sorts.add rep sconstr qtmks - | _ -> qtmks + sprintf "(%s)" constr + | _ -> rep in - print_fun_def fmt f [] ty (get_qtmk rep qtmks) + print_fun_def fmt f [] ty rep | _ -> assert false ) cprofs + let check_is_destr ty f rep = + match ty with + | [Ty.Trecord r] -> + add_records_destr + (Hstring.view r.name) + (Sy.to_string f) + rep + | _ -> () + + let output_functions_counterexample fmt fprofs = + Profile.iter + (fun (f, xs_ty, ty) st -> + let xs_ty_named = List.mapi (fun i ty -> + ty,(sprintf "arg_%d" i) + ) xs_ty in + + let rep = + let representants = + Profile.V.fold (fun (xs_values,(rep,srep)) acc -> + assert ((List.length xs_ty_named) = (List.length xs_values)); + check_is_destr xs_ty f srep; + (xs_values,rep) :: acc + ) st [] in + + let rec reps_aux reps = + match reps with + | [] -> assert false + | [_xs_values,rep] -> + asprintf "%a" X.print rep + | (xs_values,rep) :: l -> + let rec mk_ite_cond xs tys = + match xs, tys with + | [],[] -> assert false + | [xs,_],[_ty,name] -> + asprintf "(= %s %a)" name Expr.print xs + | (xs,_) :: l1, (_ty,name) :: l2 -> + asprintf "(and (= %s %a) %s)" + name + Expr.print xs + (mk_ite_cond l1 l2) + | _, _ -> assert false + in + asprintf "(ite %s %a %s)" + (mk_ite_cond xs_values xs_ty_named) + X.print rep + (reps_aux l) + in + reps_aux representants + in + print_fun_def fmt f xs_ty_named ty rep; + ) fprofs + end (* of module SmtlibCounterExample *) module Why3CounterExample = struct let output_constraints fmt prop_model = - SE.iter (fun e -> - (fprintf str_formatter "(assert %a)@ " SmtlibCounterExample.pp_term e) - ) prop_model; + let assertions = SE.fold (fun e acc -> + (asprintf "%s(assert %a)@ " acc SmtlibCounterExample.pp_term e) + ) prop_model "" in Sorts.iter (fun _ (name,ty) -> Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty ) !constraints; - Printer.print_fmt fmt "%s" (flush_str_formatter ()) + Printer.print_fmt fmt "%s" assertions end (* of module Why3CounterExample *) @@ -445,8 +369,10 @@ let output_concrete_model fmt props functions constants arrays = Why3CounterExample.output_constraints fmt props end; - SmtlibCounterExample.output_constants_counterexample fmt - constants functions; + fprintf fmt "@ ; Functions@ "; + SmtlibCounterExample.output_functions_counterexample fmt functions; + fprintf fmt "@ ; Constants@ "; + SmtlibCounterExample.output_constants_counterexample fmt constants; Printer.print_fmt fmt "@]@ )"; end @@ -454,9 +380,9 @@ let output_concrete_model fmt props functions constants arrays = Printer.print_fmt ~flushed:false fmt "@[(@ "; Printer.print_fmt ~flushed:false fmt "Constants@ "; AECounterExample.output_constants_counterexample fmt constants; - Printer.print_fmt ~flushed:false fmt "Functions@ "; + Printer.print_fmt ~flushed:false fmt "@ Functions@ "; AECounterExample.output_functions_counterexample fmt functions; - Printer.print_fmt ~flushed:false fmt "Arrays@ "; + Printer.print_fmt ~flushed:false fmt "@ Arrays@ "; AECounterExample.output_arrays_counterexample fmt arrays; Printer.print_fmt fmt "@])"; end diff --git a/src/lib/structures/symbols.ml b/src/lib/structures/symbols.ml index f961de2b8..8eabe7e52 100644 --- a/src/lib/structures/symbols.ml +++ b/src/lib/structures/symbols.ml @@ -268,7 +268,11 @@ let to_string ?(show_vars=true) x = match x with | Op Mult -> "*" | Op Div -> "/" | Op Modulo -> "%" - | Op (Access s) -> "@Access_"^(Hstring.view s) + | Op (Access s) -> + if get_output_smtlib () then + (Hstring.view s) + else + "@Access_"^(Hstring.view s) | Op (Constr s) -> (Hstring.view s) | Op (Destruct (s,g)) -> Format.sprintf "%s%s" (if g then "" else "!") (Hstring.view s) diff --git a/src/lib/structures/ty.ml b/src/lib/structures/ty.ml index 23d1b2a2a..4c29a0b7c 100644 --- a/src/lib/structures/ty.ml +++ b/src/lib/structures/ty.ml @@ -82,9 +82,12 @@ let assoc_destrs hs cases = let print_generic body_of = let h = Hashtbl.create 17 in let rec print body_of fmt = function - | Tint -> fprintf fmt "int" - | Treal -> fprintf fmt "real" - | Tbool -> fprintf fmt "bool" + | Tint -> if get_output_smtlib () then fprintf fmt "Int" + else fprintf fmt "int" + | Treal -> if get_output_smtlib () then fprintf fmt "Real" + else fprintf fmt "real" + | Tbool -> if get_output_smtlib () then fprintf fmt "Bool" + else fprintf fmt "bool" | Tunit -> fprintf fmt "unit" | Tbitv n -> fprintf fmt "bitv[%d]" n | Tvar{v=v ; value = None} -> fprintf fmt "'a_%d" v @@ -98,22 +101,37 @@ let print_generic body_of = | Tvar{ value = Some t; _ } -> (*fprintf fmt "('a_%d->%a)" v print t *) print body_of fmt t - | Text(l, s) -> fprintf fmt "%a %s" print_list l (Hstring.view s) + | Text(l, s) when l == [] -> + if get_output_smtlib () then fprintf fmt "%s" (Hstring.view s) + else fprintf fmt "%s" (Hstring.view s) + | Text(l,s) -> + if get_output_smtlib () then + fprintf fmt "(%a %s)" print_list l (Hstring.view s) + else fprintf fmt "%a %s" print_list l (Hstring.view s) | Tfarray (t1, t2) -> - fprintf fmt "(%a,%a) farray" (print body_of) t1 (print body_of) t2 + if get_output_smtlib () then + fprintf fmt "(Array %a %a)" (print body_of) t1 (print body_of) t2 + else + fprintf fmt "(%a,%a) farray" (print body_of) t1 (print body_of) t2 | Tsum(s, _) -> fprintf fmt "%s" (Hstring.view s) | Trecord { args = lv; name = n; lbs = lbls; _ } -> - fprintf fmt "%a %s" print_list lv (Hstring.view n); - if body_of != None then begin - fprintf fmt " = {"; - let first = ref true in - List.iter - (fun (s, t) -> - fprintf fmt "%s%s : %a" (if !first then "" else "; ") - (Hstring.view s) (print body_of) t; - first := false - ) lbls; - fprintf fmt "}" + if get_output_smtlib () then begin + if lv == [] then fprintf fmt "%s" (Hstring.view n) + else fprintf fmt "%a %s" print_list lv (Hstring.view n) + end + else begin + fprintf fmt "%a %s" print_list lv (Hstring.view n); + if body_of != None then begin + fprintf fmt " = {"; + let first = ref true in + List.iter + (fun (s, t) -> + fprintf fmt "%s%s : %a" (if !first then "" else "; ") + (Hstring.view s) (print body_of) t; + first := false + ) lbls; + fprintf fmt "}" + end end | Tadt (n, lv) -> fprintf fmt "%a %s" print_list lv (Hstring.view n); From 55c5dd2ab3a7ec43cc775369622e36f98daa4ed5 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 20 Nov 2020 09:45:02 +0100 Subject: [PATCH 20/68] fix compatibility for ocaml version < 4.07 --- src/lib/models/models.ml | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 6adad0854..b6dabe071 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -201,11 +201,9 @@ module SmtlibCounterExample = struct let records = ref Records.empty let add_records_destr record destr rep = - match Records.find_opt record !records with - | None -> - records := Records.add record [(destr,rep)] !records - | Some destrs -> + try let destrs = Records.find record !records in records := Records.add record ((destr,rep) :: destrs) !records + with Not_found -> records := Records.add record [(destr,rep)] !records let mk_records_constr { Ty.name = n; record_constr = cstr; lbs = lbs; _} = @@ -225,13 +223,11 @@ module SmtlibCounterExample = struct | Some rep -> fprintf fmt "%s " rep ) lbs in - match Records.find_opt (Hstring.view n) !records with - | None -> assert false - | Some [] -> assert false - | Some destrs -> + try let destrs = Records.find (Hstring.view n) !records in asprintf "%s %a" (Hstring.view cstr) print_destr (destrs,lbs) + with Not_found -> assert false let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr From c71e7acbdd3599e9df434262c987373382899618 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 20 Nov 2020 11:51:04 +0100 Subject: [PATCH 21/68] Fix printing of some type in smtlib2 output format --- src/lib/models/models.ml | 5 +++++ src/lib/structures/ty.ml | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index b6dabe071..edaf14980 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -336,6 +336,9 @@ module SmtlibCounterExample = struct print_fun_def fmt f xs_ty_named ty rep; ) fprofs + let output_arrays_counterexample fmt _arrays = + fprintf fmt "@ ; Arrays not yet supported@ " + end (* of module SmtlibCounterExample *) @@ -370,6 +373,8 @@ let output_concrete_model fmt props functions constants arrays = fprintf fmt "@ ; Constants@ "; SmtlibCounterExample.output_constants_counterexample fmt constants; + SmtlibCounterExample.output_arrays_counterexample fmt arrays; + Printer.print_fmt fmt "@]@ )"; end else if Options.get_output_format () == Native then begin diff --git a/src/lib/structures/ty.ml b/src/lib/structures/ty.ml index 4c29a0b7c..b0d7fa9c3 100644 --- a/src/lib/structures/ty.ml +++ b/src/lib/structures/ty.ml @@ -106,14 +106,17 @@ let print_generic body_of = else fprintf fmt "%s" (Hstring.view s) | Text(l,s) -> if get_output_smtlib () then - fprintf fmt "(%a %s)" print_list l (Hstring.view s) + fprintf fmt "(%s %a)" (Hstring.view s) print_list l else fprintf fmt "%a %s" print_list l (Hstring.view s) | Tfarray (t1, t2) -> if get_output_smtlib () then fprintf fmt "(Array %a %a)" (print body_of) t1 (print body_of) t2 else fprintf fmt "(%a,%a) farray" (print body_of) t1 (print body_of) t2 - | Tsum(s, _) -> fprintf fmt "%s" (Hstring.view s) + | Tsum(s, _) -> + if get_output_smtlib () then + fprintf fmt "%s" (Hstring.view s) + else fprintf fmt "%s" (Hstring.view s) | Trecord { args = lv; name = n; lbs = lbls; _ } -> if get_output_smtlib () then begin if lv == [] then fprintf fmt "%s" (Hstring.view n) From f4a76075bd58029487967f4d8bceed2132846082 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 20 Nov 2020 11:51:54 +0100 Subject: [PATCH 22/68] Add an example which test some ce --- examples/smt2/complete.smt2 | 93 +++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 examples/smt2/complete.smt2 diff --git a/examples/smt2/complete.smt2 b/examples/smt2/complete.smt2 new file mode 100644 index 000000000..570a7c9f7 --- /dev/null +++ b/examples/smt2/complete.smt2 @@ -0,0 +1,93 @@ +(set-logic ALL) +(set-option :produce-models true) + +;; Constants +;; Bools +(declare-const b Bool) +(assert b) +(check-sat) + +;; Ints +(declare-const i Int) +(assert (> i 0)) +(check-sat) + +;; Reals +(declare-const r Real) +(assert (> r 0.0)) +(check-sat) + +;; UF +;; Bools +(declare-const fb_cst Bool) +(declare-const fb_cst2 Bool) +(declare-fun fb (Bool) Bool) +(declare-fun fb_b (Bool Bool) Bool) +(assert (and (fb fb_cst) (fb_b fb_cst fb_cst2))) +(check-sat) + +;; Ints +(declare-const fi_cst Int) +(declare-fun fi (Int) Bool) +(declare-fun fii (Int) Int) +(declare-fun fii_i (Int Int) Int) +(assert (and (fi fi_cst) (= (fii fi_cst) 0) (= (fii_i 1 2) fi_cst))) +(check-sat) + +;; Reals +(declare-const fr_cst Real) +(declare-fun fr (Real) Bool) +(declare-fun frr (Real) Real) +(declare-fun frr_r (Real Real) Real) +(assert (and (fr fr_cst) (= (frr fr_cst) 1.0) (= (frr_r 1.0 2.0) fr_cst))) +(check-sat) + +;; Sorts +(declare-sort S0 0) +(declare-const sa S0) +(declare-const sb S0) +(assert (= sa sb)) +(check-sat) + +(declare-sort S1 1) +(declare-const s1a (S1 S0)) +(declare-const s1b (S1 S0)) +(assert (= s1a s1b)) +(check-sat) + +;; Arrays +(declare-const a (Array Int Int)) +(assert (= a (store a 1 1))) +(assert (= (select a 1) 1)) + +(declare-const ai_cst Int) +(define-fun ai () (Array Int Int) (store a ai_cst 1)) +(assert (= (select ai ai_cst) 1)) +(check-sat) +(get-model) + +;; Sums +(declare-datatype s ((A) (B) (C))) +(declare-const s_cst s) +(assert (or (= s_cst A) (= s_cst B))) +(check-sat) +(get-model) + +;; Records +(declare-datatype r ((mk_r (r0 Int) (r1 Int)))) +(declare-const r_cst r) +(assert (> (r0 r_cst) 1)) +(check-sat) + +(define-fun r_fun () r (mk_r 1 2)) +(assert (= (r1 r_fun) 2)) +(check-sat) +(get-model) + +;; Adts +(declare-datatype IntList ((Cons (hd Int) (tl IntList)) (Nil))) +(declare-const l_cst IntList) +; not yet supported +;(assert (= (hd l_cst) 1)) +;(assert (= l_cst Nil)) +(check-sat) \ No newline at end of file From f006f41134d808aa2b31ece938a9a0e87b2ca047 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Tue, 24 Nov 2020 16:47:03 +0100 Subject: [PATCH 23/68] Add support for record constuctor use in model --- src/lib/models/models.ml | 112 ++++++++++++++++++++++++--------------- 1 file changed, 69 insertions(+), 43 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index edaf14980..bae6a8336 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -197,38 +197,6 @@ end module SmtlibCounterExample = struct - module Records = Map.Make(String) - let records = ref Records.empty - - let add_records_destr record destr rep = - try let destrs = Records.find record !records in - records := Records.add record ((destr,rep) :: destrs) !records - with Not_found -> records := Records.add record [(destr,rep)] !records - - let mk_records_constr - { Ty.name = n; record_constr = cstr; lbs = lbs; _} = - let rec find_destrs destr destrs = - match destrs with - | [] -> None - | (d,rep) :: destrs -> - if String.equal d destr then Some rep - else find_destrs destr destrs - in - - let print_destr fmt (destrs,lbs) = - List.iter (fun (destr, _ty_destr) -> - let destr = Hstring.view destr in - match find_destrs destr destrs with - | None -> fprintf fmt " " destr - | Some rep -> fprintf fmt "%s " rep - ) lbs - in - try let destrs = Records.find (Hstring.view n) !records in - asprintf "%s %a" - (Hstring.view cstr) - print_destr (destrs,lbs) - with Not_found -> assert false - let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr let to_string_type t = @@ -249,6 +217,73 @@ module SmtlibCounterExample = struct end | _ -> E.print fmt t + module Records = Map.Make(String) + module Destructors = Map.Make(String) + let records = ref Records.empty + + let add_records_destr record_name destr_name rep = + let destrs = + try Records.find record_name !records + with Not_found -> Destructors.empty + in + let destrs = + Destructors.add destr_name rep destrs in + records := Records.add record_name destrs !records + + let mk_records_constr record_name + { Ty.name = _n; record_constr = cstr; lbs = lbs; _} = + let find_destrs destr destrs = + try let rep = Destructors.find destr destrs in + Some rep + with Not_found -> None + in + + let print_destr fmt (destrs,lbs) = + List.iter (fun (destr, _ty_destr) -> + let destr = Hstring.view destr in + match find_destrs destr destrs with + | None -> + if Options.get_verbose () || + Options.get_debug_interpretation () then + fprintf fmt " " destr + else + fprintf fmt "_ " + | Some rep -> fprintf fmt "%s " rep + ) lbs + in + let destrs = + try Records.find (Sy.to_string record_name) !records + with Not_found -> Destructors.empty + in + asprintf "%s %a" + (Hstring.view cstr) + print_destr (destrs,lbs) + + let add_record_constr record_name { Ty.name = _n; record_constr = _cstr; lbs = lbs; _} xs_values = + List.iter2 (fun (destr,_) (rep,_) -> + add_records_destr + record_name + (Hstring.view destr) + (asprintf "%a" Expr.print rep) + ) lbs xs_values + + let check_records xs_ty_named xs_values f ty rep = + match xs_ty_named with + | [Ty.Trecord _r, _arg] -> begin + match xs_values with + | [record_name,_] -> + add_records_destr + (asprintf "%a" Expr.print record_name) + (Sy.to_string f) + rep + | [] | _ -> () + end + | _ -> + match ty with + | Ty.Trecord r -> + add_record_constr rep r xs_values + | _ -> () + let print_fun_def fmt name args ty t = let print_args fmt (ty,name) = Format.fprintf fmt "(%s %a)" name Ty.print ty in @@ -275,7 +310,7 @@ module SmtlibCounterExample = struct let rep = match ty with | Ty.Trecord r -> - let constr = mk_records_constr r in + let constr = mk_records_constr f r in sprintf "(%s)" constr | _ -> rep in @@ -284,15 +319,6 @@ module SmtlibCounterExample = struct | _ -> assert false ) cprofs - let check_is_destr ty f rep = - match ty with - | [Ty.Trecord r] -> - add_records_destr - (Hstring.view r.name) - (Sy.to_string f) - rep - | _ -> () - let output_functions_counterexample fmt fprofs = Profile.iter (fun (f, xs_ty, ty) st -> @@ -304,7 +330,7 @@ module SmtlibCounterExample = struct let representants = Profile.V.fold (fun (xs_values,(rep,srep)) acc -> assert ((List.length xs_ty_named) = (List.length xs_values)); - check_is_destr xs_ty f srep; + check_records xs_ty_named xs_values f ty srep; (xs_values,rep) :: acc ) st [] in From b0c4e9dd5c95688094c75f461bb0913d3b658710 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Wed, 25 Nov 2020 12:14:19 +0100 Subject: [PATCH 24/68] Add option dummy-value for interpretation that output _ instead of dummy fresh value when no value is computed --- src/bin/common/parse_command.ml | 10 ++++++++-- src/lib/models/models.ml | 23 +++++++++++++++++------ src/lib/util/options.ml | 3 +++ src/lib/util/options.mli | 8 ++++++++ 4 files changed, 36 insertions(+), 8 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index b8007e93c..1a1d11d51 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -308,7 +308,7 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() -let mk_output_opt interpretation model unsat_core output_format +let mk_output_opt interpretation dummy_value model unsat_core output_format = set_infer_output_format output_format; let output_format = match output_format with @@ -316,6 +316,7 @@ let mk_output_opt interpretation model unsat_core output_format | Some fmt -> fmt in set_interpretation interpretation; + set_interpretation_dummy_value (not dummy_value); set_model model; set_unsat_core unsat_core; set_output_format output_format; @@ -934,6 +935,11 @@ let parse_output_opt = Arg.(value & opt interpretation_conv INone & info ["interpretation"] ~docv ~docs ~doc) in + let dummy_value = + let doc = "Output \"_\" instead of dummy fresh value in interpretation" in + Arg.(value & flag & info + ["interpretation-dummy-value";"dummy-value"] ~doc) in + let model = let doc = Format.sprintf "Experimental support for models on labeled terms. \ @@ -966,7 +972,7 @@ let parse_output_opt = in Term.(ret (const mk_output_opt $ - interpretation $ model $ unsat_core $ + interpretation $ dummy_value $ model $ unsat_core $ output_format )) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index bae6a8336..035a43847 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -202,6 +202,21 @@ module SmtlibCounterExample = struct let to_string_type t = asprintf "%a" Ty.print t + let dummy_value_of_type ty = + match ty with + Ty.Tint -> "0" + | Ty.Treal -> "0.0" + | Ty.Tbool -> "false" + | _ -> asprintf "%a" Expr.print (Expr.fresh_name ty) + + let pp_dummy_value_of_type fmt ty = + + if Options.get_interpretation_dummy_value () then + let d = dummy_value_of_type ty in + fprintf fmt "%s " d + else + fprintf fmt "_ " + let pp_term fmt t = match E.symbol_info t with | Sy.Name (n,_) -> begin @@ -239,15 +254,11 @@ module SmtlibCounterExample = struct in let print_destr fmt (destrs,lbs) = - List.iter (fun (destr, _ty_destr) -> + List.iter (fun (destr, ty_destr) -> let destr = Hstring.view destr in match find_destrs destr destrs with | None -> - if Options.get_verbose () || - Options.get_debug_interpretation () then - fprintf fmt " " destr - else - fprintf fmt "_ " + pp_dummy_value_of_type fmt ty_destr | Some rep -> fprintf fmt "%s " rep ) lbs in diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 2fdf73c3f..dd8a3f3ce 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -297,12 +297,14 @@ let get_timelimit_per_goal () = !timelimit_per_goal (** Output options *) let interpretation = ref INone +let interpretation_dummy_value = ref true let model = ref MNone let output_format = ref Native let infer_output_format = ref true let unsat_core = ref false let set_interpretation b = interpretation := b +let set_interpretation_dummy_value b = interpretation_dummy_value := b let set_model b = model := b let set_output_format b = output_format := b let set_infer_output_format f = infer_output_format := f = None @@ -317,6 +319,7 @@ let get_first_interpretation () = !interpretation = IFirst let get_before_dec_interpretation () = !interpretation = IBefore_dec let get_before_inst_interpretation () = !interpretation = IBefore_inst let get_before_end_interpretation () = !interpretation = IBefore_end +let get_interpretation_dummy_value () = !interpretation_dummy_value let get_model () = !model = MDefault || !model = MComplete let get_complete_model () = !model = MComplete let get_all_models () = !model = MAll diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 85006a4f4..e1a378c35 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -196,6 +196,10 @@ val set_input_format : input_format -> unit *) val set_interpretation : interpretation -> unit +(** Set [interpretation_dummy_value] accessible with + {!val:get_interpretation_dummy_value} *) +val set_interpretation_dummy_value : bool -> unit + (** Set [max_split] accessible with {!val:get_max_split} *) val set_max_split : Numbers.Q.t -> unit @@ -730,6 +734,10 @@ val get_before_inst_interpretation : unit -> bool val get_before_end_interpretation : unit -> bool (** Default to [false] *) +(** [true] if the interpretation is set to output dummy values instean of _ *) +val get_interpretation_dummy_value : unit -> bool +(** Default to [false] *) + (** Value specifying the default output format. possible values are {ul {- native} {- smtlib2} {- why3}} . *) From f3a4dafcf5335121fa2dd68c6a2cf70bb2d6569c Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Wed, 25 Nov 2020 15:42:24 +0100 Subject: [PATCH 25/68] Fix pp_term and assert output prototype --- src/lib/models/models.ml | 44 +++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 035a43847..e08ca2cbb 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -202,36 +202,38 @@ module SmtlibCounterExample = struct let to_string_type t = asprintf "%a" Ty.print t + let pp_term fmt t = + if Options.get_output_format () == Why3 then + match E.symbol_info t with + | Sy.Name (n,_) -> begin + try + let constraint_name,_ty_name = + Sorts.find (Hstring.view n) !constraints in + fprintf fmt "%s" constraint_name + with _ -> + let constraint_name = "c_"^(Hstring.view n) in + constraints := Sorts.add (Hstring.view n) + (constraint_name,to_string_type (E.type_info t)) !constraints; + fprintf fmt "%s" constraint_name + end + | _ -> E.print fmt t + else + E.print fmt t + let dummy_value_of_type ty = match ty with Ty.Tint -> "0" | Ty.Treal -> "0.0" | Ty.Tbool -> "false" - | _ -> asprintf "%a" Expr.print (Expr.fresh_name ty) + | _ -> asprintf "%a" pp_term (Expr.fresh_name ty) let pp_dummy_value_of_type fmt ty = - if Options.get_interpretation_dummy_value () then let d = dummy_value_of_type ty in fprintf fmt "%s " d else fprintf fmt "_ " - let pp_term fmt t = - match E.symbol_info t with - | Sy.Name (n,_) -> begin - try - let constraint_name,_ty_name = - Sorts.find (Hstring.view n) !constraints in - fprintf fmt "%s" constraint_name - with _ -> - let constraint_name = "c_"^(Hstring.view n) in - constraints := Sorts.add (Hstring.view n) - (constraint_name,to_string_type (E.type_info t)) !constraints; - fprintf fmt "%s" constraint_name - end - | _ -> E.print fmt t - module Records = Map.Make(String) module Destructors = Map.Make(String) let records = ref Records.empty @@ -275,7 +277,7 @@ module SmtlibCounterExample = struct add_records_destr record_name (Hstring.view destr) - (asprintf "%a" Expr.print rep) + (asprintf "%a" pp_term rep) ) lbs xs_values let check_records xs_ty_named xs_values f ty rep = @@ -355,11 +357,11 @@ module SmtlibCounterExample = struct match xs, tys with | [],[] -> assert false | [xs,_],[_ty,name] -> - asprintf "(= %s %a)" name Expr.print xs + asprintf "(= %s %a)" name pp_term xs | (xs,_) :: l1, (_ty,name) :: l2 -> asprintf "(and (= %s %a) %s)" name - Expr.print xs + pp_term xs (mk_ite_cond l1 l2) | _, _ -> assert false in @@ -388,7 +390,7 @@ module Why3CounterExample = struct Sorts.iter (fun _ (name,ty) -> Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty ) !constraints; - Printer.print_fmt fmt "%s" assertions + Printer.print_fmt fmt ~flushed:false "%s" assertions end (* of module Why3CounterExample *) From b37a951aa334a786861aba8a2737d7fa60c73d9d Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Wed, 25 Nov 2020 17:08:51 +0100 Subject: [PATCH 26/68] Add factorisation in ite when values or the same --- src/lib/models/models.ml | 67 ++++++++++++++++++++++++++-------------- 1 file changed, 44 insertions(+), 23 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index e08ca2cbb..06d50e17a 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -332,6 +332,8 @@ module SmtlibCounterExample = struct | _ -> assert false ) cprofs + module Rep = Map.Make(String) + let output_functions_counterexample fmt fprofs = Profile.iter (fun (f, xs_ty, ty) st -> @@ -341,36 +343,55 @@ module SmtlibCounterExample = struct let rep = let representants = - Profile.V.fold (fun (xs_values,(rep,srep)) acc -> + Profile.V.fold (fun (xs_values,(_rep,srep)) acc -> assert ((List.length xs_ty_named) = (List.length xs_values)); check_records xs_ty_named xs_values f ty srep; - (xs_values,rep) :: acc - ) st [] in + let reps = try Rep.find srep acc with Not_found -> [] in + Rep.add srep (xs_values :: reps) acc + ) st Rep.empty in + + let representants = Rep.fold (fun srep xs_values_list acc -> + (srep,xs_values_list) :: acc) representants [] in + + let rec mk_ite_and xs tys = + match xs, tys with + | [],[] -> assert false + | [xs,_],[_ty,name] -> + asprintf "(= %s %a)" name pp_term xs + | (xs,_) :: l1, (_ty,name) :: l2 -> + asprintf "(and (= %s %a) %s)" + name + pp_term xs + (mk_ite_and l1 l2) + | _, _ -> assert false + in + + let mk_ite_or l = + let pp_or_list fmt xs_values = + fprintf fmt "%s" (mk_ite_and xs_values xs_ty_named) + in + match l with + | [] -> assert false + | [xs_values] -> mk_ite_and xs_values xs_ty_named + | xs_values :: l -> + asprintf "(or %s %a)" + (mk_ite_and xs_values xs_ty_named) + (Printer.pp_list_space pp_or_list) l + in let rec reps_aux reps = match reps with - | [] -> assert false - | [_xs_values,rep] -> - asprintf "%a" X.print rep - | (xs_values,rep) :: l -> - let rec mk_ite_cond xs tys = - match xs, tys with - | [],[] -> assert false - | [xs,_],[_ty,name] -> - asprintf "(= %s %a)" name pp_term xs - | (xs,_) :: l1, (_ty,name) :: l2 -> - asprintf "(and (= %s %a) %s)" - name - pp_term xs - (mk_ite_cond l1 l2) - | _, _ -> assert false - in - asprintf "(ite %s %a %s)" - (mk_ite_cond xs_values xs_ty_named) - X.print rep + | [] -> asprintf "%a" pp_dummy_value_of_type ty + | (srep,xs_values_list) :: l -> + asprintf "(ite %s %s %s)" + (mk_ite_or xs_values_list) + srep (reps_aux l) in - reps_aux representants + if List.length representants = 1 then + sprintf "%s" (fst (List.hd representants)) + else + reps_aux representants in print_fun_def fmt f xs_ty_named ty rep; ) fprofs From 6424ea194b59cf25e7e54516b9f10420c853b6d6 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 26 Nov 2020 11:10:31 +0100 Subject: [PATCH 27/68] reeplace dummy_value with use_underscore option --- src/bin/common/parse_command.ml | 12 ++++++------ src/lib/models/models.ml | 13 +++++++++++-- src/lib/util/options.ml | 6 +++--- src/lib/util/options.mli | 11 ++++++----- 4 files changed, 26 insertions(+), 16 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 1a1d11d51..43a4684fc 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -308,7 +308,7 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() -let mk_output_opt interpretation dummy_value model unsat_core output_format +let mk_output_opt interpretation use_underscore model unsat_core output_format = set_infer_output_format output_format; let output_format = match output_format with @@ -316,7 +316,7 @@ let mk_output_opt interpretation dummy_value model unsat_core output_format | Some fmt -> fmt in set_interpretation interpretation; - set_interpretation_dummy_value (not dummy_value); + set_interpretation_use_underscore use_underscore; set_model model; set_unsat_core unsat_core; set_output_format output_format; @@ -935,10 +935,10 @@ let parse_output_opt = Arg.(value & opt interpretation_conv INone & info ["interpretation"] ~docv ~docs ~doc) in - let dummy_value = - let doc = "Output \"_\" instead of dummy fresh value in interpretation" in + let use_underscore = + let doc = "Output \"_\" instead of fresh value in interpretation" in Arg.(value & flag & info - ["interpretation-dummy-value";"dummy-value"] ~doc) in + ["interpretation-use-underscore";"use-underscore"] ~doc) in let model = let doc = Format.sprintf @@ -972,7 +972,7 @@ let parse_output_opt = in Term.(ret (const mk_output_opt $ - interpretation $ dummy_value $ model $ unsat_core $ + interpretation $ use_underscore $ model $ unsat_core $ output_format )) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 06d50e17a..4701917c8 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -228,7 +228,7 @@ module SmtlibCounterExample = struct | _ -> asprintf "%a" pp_term (Expr.fresh_name ty) let pp_dummy_value_of_type fmt ty = - if Options.get_interpretation_dummy_value () then + if not (Options.get_interpretation_use_underscore ()) then let d = dummy_value_of_type ty in fprintf fmt "%s " d else @@ -272,7 +272,8 @@ module SmtlibCounterExample = struct (Hstring.view cstr) print_destr (destrs,lbs) - let add_record_constr record_name { Ty.name = _n; record_constr = _cstr; lbs = lbs; _} xs_values = + let add_record_constr record_name + { Ty.name = _n; record_constr = _cstr; lbs = lbs; _} xs_values = List.iter2 (fun (destr,_) (rep,_) -> add_records_destr record_name @@ -382,6 +383,14 @@ module SmtlibCounterExample = struct let rec reps_aux reps = match reps with | [] -> asprintf "%a" pp_dummy_value_of_type ty + | [srep,xs_values_list] -> + if Options.get_interpretation_use_underscore () then + asprintf "(ite %s %s %s)" + (mk_ite_or xs_values_list) + srep + (reps_aux []) + else + srep | (srep,xs_values_list) :: l -> asprintf "(ite %s %s %s)" (mk_ite_or xs_values_list) diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index dd8a3f3ce..aca0f4493 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -297,14 +297,14 @@ let get_timelimit_per_goal () = !timelimit_per_goal (** Output options *) let interpretation = ref INone -let interpretation_dummy_value = ref true +let interpretation_use_underscore = ref true let model = ref MNone let output_format = ref Native let infer_output_format = ref true let unsat_core = ref false let set_interpretation b = interpretation := b -let set_interpretation_dummy_value b = interpretation_dummy_value := b +let set_interpretation_use_underscore b = interpretation_use_underscore := b let set_model b = model := b let set_output_format b = output_format := b let set_infer_output_format f = infer_output_format := f = None @@ -319,7 +319,7 @@ let get_first_interpretation () = !interpretation = IFirst let get_before_dec_interpretation () = !interpretation = IBefore_dec let get_before_inst_interpretation () = !interpretation = IBefore_inst let get_before_end_interpretation () = !interpretation = IBefore_end -let get_interpretation_dummy_value () = !interpretation_dummy_value +let get_interpretation_use_underscore () = !interpretation_use_underscore let get_model () = !model = MDefault || !model = MComplete let get_complete_model () = !model = MComplete let get_all_models () = !model = MAll diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index e1a378c35..41e56739d 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -196,9 +196,9 @@ val set_input_format : input_format -> unit *) val set_interpretation : interpretation -> unit -(** Set [interpretation_dummy_value] accessible with - {!val:get_interpretation_dummy_value} *) -val set_interpretation_dummy_value : bool -> unit +(** Set [interpretation_use_underscore] accessible with + {!val:get_interpretation_use_underscore} *) +val set_interpretation_use_underscore : bool -> unit (** Set [max_split] accessible with {!val:get_max_split} *) val set_max_split : Numbers.Q.t -> unit @@ -734,8 +734,9 @@ val get_before_inst_interpretation : unit -> bool val get_before_end_interpretation : unit -> bool (** Default to [false] *) -(** [true] if the interpretation is set to output dummy values instean of _ *) -val get_interpretation_dummy_value : unit -> bool +(** [true] if the interpretation_use_underscore is set to output _ + instead of fresh values *) +val get_interpretation_use_underscore : unit -> bool (** Default to [false] *) (** Value specifying the default output format. possible values are From 2146df996e63f360c8bebaa83b139abea0d48334 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 17 Dec 2020 11:44:29 +0100 Subject: [PATCH 28/68] remove fast option, use `--instantiation-heuristic=normal` instead --- src/bin/common/parse_command.ml | 10 ++-------- src/lib/util/options.ml | 3 --- src/lib/util/options.mli | 7 ------- 3 files changed, 2 insertions(+), 18 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 43a4684fc..a2507ef62 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -335,7 +335,7 @@ let mk_profiling_opt cumulative_time_profiling profiling set_cumulative_time_profiling cumulative_time_profiling; `Ok() -let mk_quantifiers_opt instantiation_heuristic fast instantiate_after_backjump +let mk_quantifiers_opt instantiation_heuristic instantiate_after_backjump max_multi_triggers_size nb_triggers no_ematching no_user_triggers normalize_instances triggers_var = @@ -344,7 +344,6 @@ let mk_quantifiers_opt instantiation_heuristic fast instantiate_after_backjump set_nb_triggers nb_triggers; set_normalize_instances normalize_instances; set_instantiation_heuristic instantiation_heuristic; - set_fast fast; set_instantiate_after_backjump instantiate_after_backjump; set_max_multi_triggers_size max_multi_triggers_size; set_triggers_var triggers_var; @@ -1027,11 +1026,6 @@ let parse_quantifiers_opt = Arg.(value & opt instantiation_heuristic_conv IAuto & info ["instantiation-heuristic"] ~docv ~docs ~doc) in - let fast = - let doc = "Heuristic that disable heavy instantiation with triggers-var \ - (greedier)" in - Arg.(value & flag & info ["fast"] ~docs ~doc) in - let instantiate_after_backjump = let doc = "Make a (normal) instantiation round after every backjump/backtrack." in @@ -1072,7 +1066,7 @@ let parse_quantifiers_opt = let doc = "Allows variables as triggers." in Arg.(value & flag & info ["triggers-var"] ~docs ~doc) in - Term.(ret (const mk_quantifiers_opt $ instantiation_heuristic $ fast $ + Term.(ret (const mk_quantifiers_opt $ instantiation_heuristic $ instantiate_after_backjump $ max_multi_triggers_size $ nb_triggers $ no_ematching $ no_user_triggers $ normalize_instances $ triggers_var diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index aca0f4493..bd857be6a 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -355,7 +355,6 @@ let get_verbose () = !verbose let instantiation_heuristic = ref IAuto -let fast = ref false let instantiate_after_backjump = ref false let max_multi_triggers_size = ref 4 let nb_triggers = ref 2 @@ -366,7 +365,6 @@ let triggers_var = ref false let set_instantiation_heuristic i = instantiation_heuristic := i -let set_fast b = fast := b let set_instantiate_after_backjump b = instantiate_after_backjump := b let set_max_multi_triggers_size b = max_multi_triggers_size := b let set_nb_triggers b = nb_triggers := b @@ -377,7 +375,6 @@ let set_triggers_var b = triggers_var := b let get_instantiation_heuristic () = !instantiation_heuristic let get_greedy () = !instantiation_heuristic = IGreedy -let get_fast () = !fast let get_instantiate_after_backjump () = !instantiate_after_backjump let get_max_multi_triggers_size () = !max_multi_triggers_size let get_nb_triggers () = !nb_triggers diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 41e56739d..4cd0cf3fb 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -178,9 +178,6 @@ val set_frontend : string -> unit {!val:get_instantiation_heuristic} *) val set_instantiation_heuristic : instantiation_heuristic -> unit -(** Set [fast] accessible with {!val:get_fast} *) -val set_fast : bool -> unit - (** Set [inline_lets] accessible with {!val:get_inline_lets} *) val set_inline_lets : bool -> unit @@ -798,10 +795,6 @@ val get_instantiation_heuristic : unit -> instantiation_heuristic val get_greedy : unit -> bool (** Default to [false] *) -(** [true] if greedier instantiation phase is disable. *) -val get_fast : unit -> bool -(** Default to [false] *) - (** [true] if a (normal) instantiation round is made after every backjump/backtrack.*) val get_instantiate_after_backjump : unit -> bool From 2c7f12b54b99eb4f6c585d89430c8b75640000fb Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 17 Dec 2020 17:38:16 +0100 Subject: [PATCH 29/68] Copy print expr code in models for better management of named expr --- src/lib/models/models.ml | 195 +++++++++++++++++++++++++++++++++--- src/lib/structures/expr.ml | 1 + src/lib/structures/expr.mli | 2 +- 3 files changed, 181 insertions(+), 17 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 4701917c8..e6c4d4b6b 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -195,28 +195,189 @@ module AECounterExample = struct end (* of module AECounterExample *) -module SmtlibCounterExample = struct - - let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr +module Pp_smtlib_term = struct let to_string_type t = asprintf "%a" Ty.print t + let rec print fmt t = + let f,xs,ty = E.get_infos t in + match f, xs with + + | Sy.Lit lit, xs -> + begin + match lit, xs with + | Sy.L_eq, a::l -> + if get_output_smtlib () then + fprintf fmt "(= %a%a)" + print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l + else + fprintf fmt "(%a%a)" + print a (fun fmt -> List.iter (fprintf fmt " = %a" print)) l + + | Sy.L_neg_eq, [a; b] -> + if get_output_smtlib () then + fprintf fmt "(not (= %a %a))" print a print b + else + fprintf fmt "(%a <> %a)" print a print b + + | Sy.L_neg_eq, a::l -> + if get_output_smtlib () then + fprintf fmt "(distinct %a%a)" + print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l + else + fprintf fmt "distinct(%a%a)" + print a (fun fmt -> List.iter (fprintf fmt ", %a" print)) l + + | Sy.L_built Sy.LE, [a;b] -> + if get_output_smtlib () then + fprintf fmt "(<= %a %a)" print a print b + else + fprintf fmt "(%a <= %a)" print a print b + + | Sy.L_built Sy.LT, [a;b] -> + if get_output_smtlib () then + fprintf fmt "(< %a %a)" print a print b + else + fprintf fmt "(%a < %a)" print a print b + + | Sy.L_neg_built Sy.LE, [a; b] -> + if get_output_smtlib () then + fprintf fmt "(> %a %a)" print a print b + else + fprintf fmt "(%a > %a)" print a print b + + | Sy.L_neg_built Sy.LT, [a; b] -> + if get_output_smtlib () then + fprintf fmt "(>= %a %a)" print a print b + else + fprintf fmt "(%a >= %a)" print a print b + + | Sy.L_neg_pred, [a] -> + fprintf fmt "(not %a)" print a + + | Sy.L_built (Sy.IsConstr hs), [e] -> + if get_output_smtlib () then + fprintf fmt "((_ is %a) %a)" Hstring.print hs print e + else + fprintf fmt "(%a ? %a)" print e Hstring.print hs + + | Sy.L_neg_built (Sy.IsConstr hs), [e] -> + if get_output_smtlib () then + fprintf fmt "(not ((_ is %a) %a))" Hstring.print hs print e + else + fprintf fmt "not (%a ? %a)" print e Hstring.print hs + + | (Sy.L_built (Sy.LT | Sy.LE) | Sy.L_neg_built (Sy.LT | Sy.LE) + | Sy.L_neg_pred | Sy.L_eq | Sy.L_neg_eq + | Sy.L_built (Sy.IsConstr _) + | Sy.L_neg_built (Sy.IsConstr _)) , _ -> + assert false + + end + + | Sy.Op Sy.Get, [e1; e2] -> + if get_output_smtlib () then + fprintf fmt "(select %a %a)" print e1 print e2 + else + fprintf fmt "%a[%a]" print e1 print e2 + + | Sy.Op Sy.Set, [e1; e2; e3] -> + if get_output_smtlib () then + fprintf fmt "(store %a %a %a)" + print e1 + print e2 + print e3 + else + fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 + + | Sy.Op Sy.Concat, [e1; e2] -> + fprintf fmt "%a@@%a" print e1 print e2 + + | Sy.Op Sy.Extract, [e1; e2; e3] -> + fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 + + | Sy.Op (Sy.Access field), [e] -> + if get_output_smtlib () then + fprintf fmt "(%s %a)" (Hstring.view field) print e + else + fprintf fmt "%a.%s" print e (Hstring.view field) + + | Sy.Op (Sy.Record), _ -> + begin match ty with + | Ty.Trecord { Ty.lbs = lbs; _ } -> + assert (List.length xs = List.length lbs); + fprintf fmt "{"; + ignore (List.fold_left2 (fun first (field,_) e -> + fprintf fmt "%s%s = %a" (if first then "" else "; ") + (Hstring.view field) print e; + false + ) true lbs xs); + fprintf fmt "}"; + | _ -> assert false + end + + (* TODO: introduce PrefixOp in the future to simplify this ? *) + | Sy.Op op, [e1; e2] when op == Sy.Pow || op == Sy.Integer_round || + op == Sy.Max_real || op == Sy.Max_int || + op == Sy.Min_real || op == Sy.Min_int -> + fprintf fmt "%a(%a,%a)" Sy.print f print e1 print e2 + + (* TODO: introduce PrefixOp in the future to simplify this ? *) + | Sy.Op (Sy.Constr hs), ((_::_) as l) -> + fprintf fmt "%a(%a)" Hstring.print hs print_list l + + | Sy.Op _, [e1; e2] -> + if get_output_smtlib () then + fprintf fmt "(%a %a %a)" Sy.print f print e1 print e2 + else + fprintf fmt "(%a %a %a)" print e1 Sy.print f print e2 + + | Sy.Op Sy.Destruct (hs, grded), [e] -> + fprintf fmt "%a#%s%a" + print e (if grded then "" else "!") Hstring.print hs + + + | Sy.In(lb, rb), [t] -> + fprintf fmt "(%a in %a, %a)" print t Sy.print_bound lb Sy.print_bound rb + + | Sy.Name (n,_), _ -> begin + try + let constraint_name,_ty_name = + Sorts.find (Hstring.view n) !constraints in + fprintf fmt "%s" constraint_name + with _ -> + let constraint_name = "c_"^(Hstring.view n) in + constraints := Sorts.add (Hstring.view n) + (constraint_name,to_string_type (E.type_info t)) !constraints; + fprintf fmt "%s" constraint_name + end + + | _, [] -> + fprintf fmt "%a" Sy.print f + + | _, _ -> + if get_output_smtlib () then + fprintf fmt "(%a %a)" Sy.print f print_list xs + else + fprintf fmt "%a(%a)" Sy.print f print_list xs + + and print_list_sep sep fmt = function + | [] -> () + | [t] -> print fmt t + | t::l -> Format.fprintf fmt "%a%s%a" print t sep (print_list_sep sep) l + + and print_list fmt = print_list_sep "," fmt + +end + +module SmtlibCounterExample = struct + + let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr + let pp_term fmt t = if Options.get_output_format () == Why3 then - match E.symbol_info t with - | Sy.Name (n,_) -> begin - try - let constraint_name,_ty_name = - Sorts.find (Hstring.view n) !constraints in - fprintf fmt "%s" constraint_name - with _ -> - let constraint_name = "c_"^(Hstring.view n) in - constraints := Sorts.add (Hstring.view n) - (constraint_name,to_string_type (E.type_info t)) !constraints; - fprintf fmt "%s" constraint_name - end - | _ -> E.print fmt t + Pp_smtlib_term.print fmt t else E.print fmt t @@ -417,9 +578,11 @@ module Why3CounterExample = struct let assertions = SE.fold (fun e acc -> (asprintf "%s(assert %a)@ " acc SmtlibCounterExample.pp_term e) ) prop_model "" in + Printer.print_fmt ~flushed:false fmt "@ ; constants@ "; Sorts.iter (fun _ (name,ty) -> Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty ) !constraints; + Printer.print_fmt ~flushed:false fmt "@ ; assertions@ "; Printer.print_fmt fmt ~flushed:false "%s" assertions end diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index 3a87b121a..8839d48a3 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -593,6 +593,7 @@ and print_triggers fmt trs = let type_info t = t.ty let symbol_info t = t.f +let get_infos t = t.f, t.xs, t.ty (* unused let is_term e = match e.f with diff --git a/src/lib/structures/expr.mli b/src/lib/structures/expr.mli index e4a357bcb..147ec72eb 100644 --- a/src/lib/structures/expr.mli +++ b/src/lib/structures/expr.mli @@ -170,7 +170,7 @@ val is_int : t -> bool val is_real : t -> bool val type_info : t -> Ty.t val symbol_info : t -> Symbols.t - +val get_infos : t -> Symbols.t * t list * Ty.t (** Labeling and models *) From 2faa2ffb1cc05c9234c75071679ff37945adc4e1 Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Sat, 19 Dec 2020 09:57:31 +0100 Subject: [PATCH 30/68] [models] add case-split on internal bool terms Useful when/if the SAT don't see/assign internal bool expression and/or SAT assignement is not propagated to theories (eg. because of CDCL(Tableaux) filtering) --- src/lib/models/models.ml | 12 +++++++----- src/lib/reasoners/shostak.ml | 32 +++++++++++++++++++++++++------- 2 files changed, 32 insertions(+), 12 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index e6c4d4b6b..7c33a9b25 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -107,10 +107,12 @@ end let constraints = ref Sorts.empty -let assert_has_depth_one (e, _) = +let assert_has_depth_one_at_most (e, _) = match X.term_extract e with - | Some t, true -> assert (E.depth t = 1); - | _ -> () + | Some t, true -> + assert (E.depth t <= 1); (* true and false have depth = -1 *) + | _ -> + () module AECounterExample = struct @@ -160,7 +162,7 @@ module AECounterExample = struct Printer.print_fmt ~flushed:false fmt "((s: %a, args: %a) rep: %a)@ " (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one x) xs; + List.iter (fun (_,x) -> assert_has_depth_one_at_most x) xs; )st; Printer.print_fmt ~flushed:false fmt "@]@ "; ) fprofs; @@ -183,7 +185,7 @@ module AECounterExample = struct Printer.print_fmt ~flushed:false fmt "((%a %a) %a)@ " (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one x) xs; + List.iter (fun (_,x) -> assert_has_depth_one_at_most x) xs; )st; Printer.print_fmt ~flushed:false fmt "@]@ "; | _ -> assert false diff --git a/src/lib/reasoners/shostak.ml b/src/lib/reasoners/shostak.ml index f96a2a632..0793bbe16 100644 --- a/src/lib/reasoners/shostak.ml +++ b/src/lib/reasoners/shostak.ml @@ -581,6 +581,8 @@ struct c )sbs + let is_bool_const r = equal r (top()) || equal r (bot()) + let assign_value r distincts eq = let opt = match r.v, type_info r with | _, Ty.Tint @@ -591,6 +593,25 @@ struct | _, Ty.Tsum _ -> X5.assign_value r distincts eq | _, Ty.Tadt _ when not (Options.get_disable_adts()) -> X6.assign_value r distincts eq + + | Term _t, Ty.Tbool -> + if is_bool_const r then None + else + begin + let eq = List.filter (fun (_t, r) -> is_bool_const r) eq in + match eq with + | (e,_r)::_ -> Some (e, false) (* false <-> not a case-split *) + | [] -> + let dist = List.filter (fun r -> is_bool_const r) distincts in + match dist with + | {v = Term e; _}::_ -> + Some (Expr.neg e, true) (* safety: consider it as case-splut *) + | _::_ -> + assert false + | [] -> + Some (Expr.faux, true) (* true <-> make a case split *) + end + | Term t, ty -> (* case disable_adts() handled here *) if Expr.const_term t || List.exists (fun (t,_) -> Expr.const_term t) eq then None @@ -608,12 +629,6 @@ struct opt let choose_adequate_model t rep l = - let is_true_or_false r = - let re,_rb = term_extract r in - match re with - | None -> false - | Some e -> (Expr.equal Expr.vrai e) || (Expr.equal Expr.faux e) - in let r, pprint = match Expr.type_info t with | Ty.Tint @@ -624,7 +639,10 @@ struct X6.choose_adequate_model t rep l | Ty.Trecord _ -> X2.choose_adequate_model t rep l | Ty.Tfarray _ -> X4.choose_adequate_model t rep l - | Ty.Tbool when is_true_or_false rep -> + | Ty.Tbool -> + (* case split is now supposed to be done for internal bools if + needed as well *) + assert (is_bool_const rep); rep, asprintf "%a" print rep | _ -> let acc = From 8d0192c6f59b0cfd58d4c259e35b50c77c38949a Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Mon, 28 Dec 2020 14:37:20 +0100 Subject: [PATCH 31/68] Type Expr.view should remain "private" --- src/lib/structures/expr.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/structures/expr.mli b/src/lib/structures/expr.mli index 147ec72eb..011a3b73a 100644 --- a/src/lib/structures/expr.mli +++ b/src/lib/structures/expr.mli @@ -39,7 +39,7 @@ type decl_kind = | Dpredicate of t | Dfunction of t -type view = { +type view = private { f: Symbols.t; xs: t list; ty: Ty.t; From 43f53fc6ecdb776862fb8fd38404de6c1e46ff6a Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Mon, 28 Dec 2020 15:36:19 +0100 Subject: [PATCH 32/68] fix intendation --- src/lib/structures/ty.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/lib/structures/ty.ml b/src/lib/structures/ty.ml index b0d7fa9c3..90d7ce452 100644 --- a/src/lib/structures/ty.ml +++ b/src/lib/structures/ty.ml @@ -82,11 +82,14 @@ let assoc_destrs hs cases = let print_generic body_of = let h = Hashtbl.create 17 in let rec print body_of fmt = function - | Tint -> if get_output_smtlib () then fprintf fmt "Int" + | Tint -> + if get_output_smtlib () then fprintf fmt "Int" else fprintf fmt "int" - | Treal -> if get_output_smtlib () then fprintf fmt "Real" + | Treal -> + if get_output_smtlib () then fprintf fmt "Real" else fprintf fmt "real" - | Tbool -> if get_output_smtlib () then fprintf fmt "Bool" + | Tbool -> + if get_output_smtlib () then fprintf fmt "Bool" else fprintf fmt "bool" | Tunit -> fprintf fmt "unit" | Tbitv n -> fprintf fmt "bitv[%d]" n From 6721f144b6f349b1fbd90fb1d70b144ea158c15f Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Mon, 28 Dec 2020 15:42:22 +0100 Subject: [PATCH 33/68] Expr.get_infos returns the view: to avoid uesless tuple allocation --- src/lib/models/models.ml | 2 +- src/lib/structures/expr.ml | 2 +- src/lib/structures/expr.mli | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/lib/models/models.ml b/src/lib/models/models.ml index 7c33a9b25..cbc184abb 100644 --- a/src/lib/models/models.ml +++ b/src/lib/models/models.ml @@ -203,7 +203,7 @@ module Pp_smtlib_term = struct asprintf "%a" Ty.print t let rec print fmt t = - let f,xs,ty = E.get_infos t in + let {E.f;xs;ty; _} = E.get_infos t in match f, xs with | Sy.Lit lit, xs -> diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index 8839d48a3..65828da52 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -593,7 +593,7 @@ and print_triggers fmt trs = let type_info t = t.ty let symbol_info t = t.f -let get_infos t = t.f, t.xs, t.ty +let get_infos t = t (* unused let is_term e = match e.f with diff --git a/src/lib/structures/expr.mli b/src/lib/structures/expr.mli index 011a3b73a..1c708dcf1 100644 --- a/src/lib/structures/expr.mli +++ b/src/lib/structures/expr.mli @@ -168,9 +168,9 @@ val is_fresh : t -> bool val is_fresh_skolem : t -> bool val is_int : t -> bool val is_real : t -> bool -val type_info : t -> Ty.t -val symbol_info : t -> Symbols.t -val get_infos : t -> Symbols.t * t list * Ty.t +val [@inline always] type_info : t -> Ty.t +val [@inline always] symbol_info : t -> Symbols.t +val [@inline always] get_infos : t -> view (** Labeling and models *) From e2f953d73b289f4f6267b410d7e809130e0cf3a7 Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Wed, 2 Dec 2020 14:33:00 +0100 Subject: [PATCH 34/68] refactor the way model is output from fun_sat it now goes through Theory instead of calling directly Uf --- src/lib/reasoners/ccx.ml | 7 +++++++ src/lib/reasoners/ccx.mli | 6 ++++++ src/lib/reasoners/fun_sat.ml | 7 ++----- src/lib/reasoners/theory.ml | 12 ++++++++++-- src/lib/reasoners/theory.mli | 6 ++++++ src/lib/reasoners/uf.ml | 2 +- src/lib/reasoners/uf.mli | 6 +++++- 7 files changed, 37 insertions(+), 9 deletions(-) diff --git a/src/lib/reasoners/ccx.ml b/src/lib/reasoners/ccx.ml index 4d2626420..efac0bc78 100644 --- a/src/lib/reasoners/ccx.ml +++ b/src/lib/reasoners/ccx.ml @@ -88,6 +88,11 @@ module type S = sig Matching_types.info Expr.Map.t * Expr.t list Expr.Map.t Symbols.Map.t -> t -> (Expr.t -> Expr.t -> bool) -> t * instances + val output_concrete_model : + Format.formatter -> + prop_model:Expr.Set.t -> + t -> + unit end module Main : S = struct @@ -778,5 +783,7 @@ module Main : S = struct in Uf.term_repr env.uf t + let output_concrete_model fmt ~prop_model env = + Uf.output_concrete_model fmt ~prop_model env.uf end diff --git a/src/lib/reasoners/ccx.mli b/src/lib/reasoners/ccx.mli index f3fe16529..7d8d8d32f 100644 --- a/src/lib/reasoners/ccx.mli +++ b/src/lib/reasoners/ccx.mli @@ -79,6 +79,12 @@ module type S = sig do_syntactic_matching:bool -> Matching_types.info Expr.Map.t * Expr.t list Expr.Map.t Symbols.Map.t -> t -> (Expr.t -> Expr.t -> bool) -> t * Sig_rel.instances + + val output_concrete_model : + Format.formatter -> + prop_model:Expr.Set.t -> + t -> + unit end module Main : S diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index aab8914e1..cb936a083 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1246,10 +1246,8 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct You may need to change your model generation strategy@,\ or to increase your timeout.@]" | Some env -> - let cs_tbox = Th.get_case_split_env env.tbox in - let uf = Ccx.Main.get_union_find cs_tbox in let prop_model = extract_prop_model ~complete_model:true env in - Uf.output_concrete_model (get_fmt_mdl ()) prop_model uf; + Th.output_concrete_model (get_fmt_mdl ()) ~prop_model env.tbox; end; return_function () @@ -1265,11 +1263,10 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let return_answer env compute return_function = update_all_models_option env; let env = compute_concrete_model env compute in - let uf = Ccx.Main.get_union_find (Th.get_case_split_env env.tbox) in Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); let prop_model = extract_prop_model ~complete_model:true env in - Uf.output_concrete_model (get_fmt_mdl ()) prop_model uf; + Th.output_concrete_model (get_fmt_mdl ()) ~prop_model env.tbox; terminated_normally := true; return_function env diff --git a/src/lib/reasoners/theory.ml b/src/lib/reasoners/theory.ml index 8912e9624..3ce2a318a 100644 --- a/src/lib/reasoners/theory.ml +++ b/src/lib/reasoners/theory.ml @@ -74,6 +74,12 @@ module type S = sig val get_assumed : t -> E.Set.t + val output_concrete_model : + Format.formatter -> + prop_model:Expr.Set.t -> + t -> + unit + val reinit_cpt : unit -> unit end @@ -752,6 +758,9 @@ module Main_Default : S = struct let get_assumed env = env.assumed_set + let output_concrete_model fmt ~prop_model env = + CC_X.output_concrete_model fmt ~prop_model env.gamma_finite + let reinit_cpt () = Debug.reinit_cpt () @@ -790,7 +799,6 @@ module Main_Empty : S = struct let assume_th_elt e _ _ = e let theories_instances ~do_syntactic_matching:_ _ e _ _ _ = e, [] let get_assumed env = env.assumed_set - + let output_concrete_model _fmt ~prop_model:_ _env = () let reinit_cpt () = () - end diff --git a/src/lib/reasoners/theory.mli b/src/lib/reasoners/theory.mli index b0341072a..da55e0a83 100644 --- a/src/lib/reasoners/theory.mli +++ b/src/lib/reasoners/theory.mli @@ -59,6 +59,12 @@ module type S = sig val get_assumed : t -> Expr.Set.t + val output_concrete_model : + Format.formatter -> + prop_model:Expr.Set.t -> + t -> + unit + val reinit_cpt : unit -> unit (** reinitializes the counter to zero *) diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index 2899353d3..c149ca04e 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1127,7 +1127,7 @@ let compute_concrete_model ({ make; _ } as env) = ) make (Models.Profile.empty, Models.Profile.empty, Models.Profile.empty, ME.empty) -let output_concrete_model fmt prop_model env = +let output_concrete_model fmt ~prop_model env = if get_interpretation () then let functions, constants, arrays, _ = compute_concrete_model env in diff --git a/src/lib/reasoners/uf.mli b/src/lib/reasoners/uf.mli index 995cf26d9..fc5c0bd91 100644 --- a/src/lib/reasoners/uf.mli +++ b/src/lib/reasoners/uf.mli @@ -75,7 +75,11 @@ val output_concrete_model : t -> unit (** Compute a counterexample using the Uf environment and then print it on the given formatter with the corresponding format setted with Options.get_output_format *) -val output_concrete_model : Format.formatter -> Expr.Set.t -> t -> unit +val output_concrete_model : + Format.formatter -> + prop_model:Expr.Set.t -> + t -> + unit (** saves the module's cache *) val save_cache : unit -> unit From 590be70e57632d939a0bf4a95b091258b985c032 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Wed, 23 Dec 2020 10:56:40 +0100 Subject: [PATCH 35/68] Rename interpretation option values to None First Last and Every --- src/bin/common/parse_command.ml | 10 ++++------ src/lib/reasoners/fun_sat.ml | 7 +++---- src/lib/util/options.ml | 13 ++++--------- src/lib/util/options.mli | 11 +++-------- 4 files changed, 14 insertions(+), 27 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index a2507ef62..06a4f1515 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -60,9 +60,8 @@ let instantiation_heuristic_conv = let interpretation_parser = function | "none" -> Ok INone | "first" -> Ok IFirst - | "before_inst" -> Ok IBefore_inst - | "before_dec" -> Ok IBefore_dec - | "before_end" -> Ok IBefore_end + | "every" -> Ok IEvery + | "last" -> Ok ILast | s -> Error (`Msg ("Option --interpretation does not accept the argument \"" ^ s)) @@ -70,9 +69,8 @@ let interpretation_parser = function let interpretation_to_string = function | INone -> "none" | IFirst -> "first" - | IBefore_inst -> "before_inst" - | IBefore_dec -> "before_dec" - | IBefore_end -> "before_end" + | IEvery -> "every" + | ILast -> "last" let interpretation_printer fmt interpretation = Format.fprintf fmt "%s" (interpretation_to_string interpretation) diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index cb936a083..299365064 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1405,7 +1405,7 @@ are not Th-reduced"; let greedy_instantiation env = match get_instantiation_heuristic () with | INormal -> - return_answer env (get_before_end_interpretation ()) + return_answer env (get_last_interpretation ()) (fun e -> raise (I_dont_know e)) | IAuto | IGreedy -> let gre_inst = @@ -1432,14 +1432,14 @@ are not Th-reduced"; let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env else - return_answer env (get_before_end_interpretation ()) + return_answer env (get_last_interpretation ()) (fun e -> raise (I_dont_know e)) let normal_instantiation env try_greedy = Debug.print_nb_related env; let env = do_case_split env Util.BeforeMatching in - let env = compute_concrete_model env (get_before_inst_interpretation ()) in + let env = compute_concrete_model env (get_every_interpretation ()) in let env = new_inst_level env in let mconf = {Util.nb_triggers = get_nb_triggers (); @@ -1533,7 +1533,6 @@ are not Th-reduced"; and back_tracking env = try - let env = compute_concrete_model env (get_before_dec_interpretation ()) in if env.delta == [] || Options.get_no_decisions() then back_tracking (normal_instantiation env true) else diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index bd857be6a..f90edbe1c 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -63,7 +63,7 @@ let set_fmt_usc f = fmt_usc := f type model = MNone | MDefault | MAll | MComplete type instantiation_heuristic = INormal | IAuto | IGreedy -type interpretation = INone | IFirst | IBefore_inst | IBefore_dec | IBefore_end +type interpretation = INone | IFirst | IEvery | ILast type input_format = Native | Smtlib2 | Why3 (* | SZS *) | Unknown of string type output_format = input_format @@ -310,15 +310,10 @@ let set_output_format b = output_format := b let set_infer_output_format f = infer_output_format := f = None let set_unsat_core b = unsat_core := b -let get_interpretation () = - !interpretation = IFirst || - !interpretation = IBefore_dec || - !interpretation = IBefore_inst || - !interpretation = IBefore_end +let get_interpretation () = !interpretation <> INone let get_first_interpretation () = !interpretation = IFirst -let get_before_dec_interpretation () = !interpretation = IBefore_dec -let get_before_inst_interpretation () = !interpretation = IBefore_inst -let get_before_end_interpretation () = !interpretation = IBefore_end +let get_every_interpretation () = !interpretation = IEvery +let get_last_interpretation () = !interpretation = ILast let get_interpretation_use_underscore () = !interpretation_use_underscore let get_model () = !model = MDefault || !model = MComplete let get_complete_model () = !model = MComplete diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 4cd0cf3fb..f4e0631f3 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -42,7 +42,7 @@ type model = MNone | MDefault | MAll | MComplete type instantiation_heuristic = INormal | IAuto | IGreedy (** Type used to describe the type of interpretation wanted *) -type interpretation = INone | IFirst | IBefore_inst | IBefore_dec | IBefore_end +type interpretation = INone | IFirst | IEvery | ILast (** Type used to describe the type of input wanted by {!val:set_input_format} *) @@ -716,19 +716,14 @@ val get_interpretation : unit -> bool val get_first_interpretation : unit -> bool (** Default to [false] *) -(** [true] if the interpretation is set to compute interpretation - before every decision *) -val get_before_dec_interpretation : unit -> bool -(** Default to [false] *) - (** [true] if the interpretation is set to compute interpretation before every instantiation *) -val get_before_inst_interpretation : unit -> bool +val get_every_interpretation : unit -> bool (** Default to [false] *) (** [true] if the interpretation is set to compute interpretation before the solver return unknown *) -val get_before_end_interpretation : unit -> bool +val get_last_interpretation : unit -> bool (** Default to [false] *) (** [true] if the interpretation_use_underscore is set to output _ From fc903a9f374dbca2f655dae8aecd9c82f7118163 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Thu, 7 Jan 2021 11:35:07 +0100 Subject: [PATCH 36/68] Fix interpretation_timelimit initialisation --- src/bin/common/parse_command.ml | 2 +- src/lib/util/options.ml | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 06a4f1515..74b68e353 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -297,7 +297,7 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation else let fm_cross_limit = Numbers.Q.from_string fm_cross_limit in let timelimit = set_limit timelimit 0. in - let timelimit_interpretation = set_limit timelimit_interpretation 1. in + let timelimit_interpretation = set_limit timelimit_interpretation 0. in set_age_bound age_bound; set_fm_cross_limit fm_cross_limit; set_timelimit_interpretation timelimit_interpretation; diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index f90edbe1c..c0b749893 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -277,7 +277,8 @@ let age_bound = ref 50 let fm_cross_limit = ref (Numbers.Q.from_int 10_000) let steps_bound = ref (-1) let timelimit = ref 0. -let timelimit_interpretation = ref (if Sys.win32 then 0. else 1.) +(* let timelimit_interpretation = ref (if Sys.win32 then 0. else 1.) *) +let timelimit_interpretation = ref 0. let timelimit_per_goal = ref false let set_age_bound i = age_bound := i From c812399929e5e70f4b372cc0b84e503d0fe70431 Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Thu, 7 Jan 2021 11:15:11 +0100 Subject: [PATCH 37/68] auto set option "fm_cross_limit = -1" (ie. infinity) if models-gen is set. --- src/bin/common/parse_command.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 74b68e353..5bdda1884 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -1358,6 +1358,11 @@ let main = in Cmd.v info term + +let auto_set_implied_options () = + if Options.get_interpretation () then + Options.set_fm_cross_limit Numbers.Q.m_one + let parse_cmdline_arguments () = let r = Cmd.eval_value main in match r with From 1637918b26abf855a358afdca9fe9855312d3947 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 10:25:22 +0100 Subject: [PATCH 38/68] Fix use_underscore_interpretation option --- src/bin/common/parse_command.ml | 3 ++- src/lib/util/options.ml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 5bdda1884..a12951325 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -934,8 +934,9 @@ let parse_output_opt = let use_underscore = let doc = "Output \"_\" instead of fresh value in interpretation" in + let docv = "VAL" in Arg.(value & flag & info - ["interpretation-use-underscore";"use-underscore"] ~doc) in + ["interpretation-use-underscore";"use-underscore"] ~docv ~docs ~doc) in let model = let doc = Format.sprintf diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index c0b749893..5f1dc6b9e 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -298,7 +298,7 @@ let get_timelimit_per_goal () = !timelimit_per_goal (** Output options *) let interpretation = ref INone -let interpretation_use_underscore = ref true +let interpretation_use_underscore = ref false let model = ref MNone let output_format = ref Native let infer_output_format = ref true From 0ad94d6d3deb7227721f2eda9eb20294b18e69ff Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 11:24:22 +0100 Subject: [PATCH 39/68] Remove deadcode from models and mv models.ml in frontend --- src/bin/js/options_interface.ml | 11 +++++++++- src/bin/js/worker_example.ml | 2 +- src/bin/js/worker_interface.ml | 29 +++++++++++++++++++++++-- src/bin/js/worker_interface.mli | 4 +++- src/lib/dune | 4 ++-- src/lib/frontend/input.ml | 2 +- src/lib/frontend/input.mli | 2 +- src/lib/{models => frontend}/models.ml | 21 ------------------ src/lib/{models => frontend}/models.mli | 2 -- src/lib/models/populate.ml | 17 --------------- 10 files changed, 45 insertions(+), 49 deletions(-) rename src/lib/{models => frontend}/models.ml (97%) rename src/lib/{models => frontend}/models.mli (97%) delete mode 100644 src/lib/models/populate.ml diff --git a/src/bin/js/options_interface.ml b/src/bin/js/options_interface.ml index 24181df41..37c460312 100644 --- a/src/bin/js/options_interface.ml +++ b/src/bin/js/options_interface.ml @@ -50,6 +50,14 @@ let get_instantiation_heuristic = function | IAuto -> Some Options.IAuto | IGreedy -> Some Options.IGreedy +let get_interpretation = function + | None -> None + | Some m -> match m with + | INone -> Some Options.INone + | IFirst -> Some Options.IFirst + | IEvery -> Some Options.IEvery + | ILast -> Some Options.ILast + let get_no_decisions_on = function | None -> None | Some l -> @@ -129,7 +137,8 @@ let set_options r = set_options_opt Options.set_fm_cross_limit (get_numbers r.fm_cross_limit); set_options_opt Options.set_steps_bound r.steps_bound; - set_options_opt Options.set_interpretation r.interpretation; + set_options_opt Options.set_interpretation + (get_interpretation r.interpretation); set_options_opt Options.set_output_format (get_output_format r.output_format); diff --git a/src/bin/js/worker_example.ml b/src/bin/js/worker_example.ml index 8ddb90093..8bdecffe2 100644 --- a/src/bin/js/worker_example.ml +++ b/src/bin/js/worker_example.ml @@ -53,7 +53,7 @@ let solve () = debug = Some true; verbose = Some true; answers_with_loc = Some false; - interpretation = Some 1; + interpretation = Some IEvery; sat_solver = Some Worker_interface.Tableaux; unsat_core = Some true; } in diff --git a/src/bin/js/worker_interface.ml b/src/bin/js/worker_interface.ml index b7a77c703..8735dec80 100644 --- a/src/bin/js/worker_interface.ml +++ b/src/bin/js/worker_interface.ml @@ -113,6 +113,7 @@ let frontend_encoding = ] type instantiation_heuristic = INormal | IAuto | IGreedy +type interpretation = INone | IFirst | IEvery | ILast let instantiation_heuristic_encoding = union [ @@ -133,6 +134,30 @@ let instantiation_heuristic_encoding = (fun () -> IGreedy); ] +let interpretation_encoding = + union [ + case(Tag 1) + ~title:"INone" + (constant "INone") + (function INone -> Some () | _ -> None) + (fun () -> INone); + case(Tag 2) + ~title:"IFirst" + (constant "IFirst") + (function IFirst -> Some () | _ -> None) + (fun () -> IFirst); + case(Tag 3) + ~title:"IEvery" + (constant "IEvery") + (function IEvery -> Some () | _ -> None) + (fun () -> IEvery); + case(Tag 4) + ~title:"ILast" + (constant "ILast") + (function ILast -> Some () | _ -> None) + (fun () -> ILast); + ] + type options = { debug : bool option; debug_ac : bool option; @@ -187,7 +212,7 @@ type options = { fm_cross_limit : int option; steps_bound : int option; - interpretation : int option; + interpretation : interpretation option; output_format : output_format option; unsat_core : bool option; @@ -433,7 +458,7 @@ let opt3_encoding = (opt "age_bound" int31) (opt "fm_cross_limit" int31) (opt "steps_bound" int31) - (opt "interpretation" int31) + (opt "interpretation" interpretation_encoding) (opt "output_format" format_encoding) (opt "unsat_core" bool) ) diff --git a/src/bin/js/worker_interface.mli b/src/bin/js/worker_interface.mli index 382216b2d..62acd9477 100644 --- a/src/bin/js/worker_interface.mli +++ b/src/bin/js/worker_interface.mli @@ -38,6 +38,8 @@ type frontend = type instantiation_heuristic = INormal | IAuto | IGreedy +type interpretation = INone | IFirst | IEvery | ILast + (** Record type that contains all options that can be set for the Alt-Ergo's worker. *) type options = { @@ -94,7 +96,7 @@ type options = { fm_cross_limit : int option; steps_bound : int option; - interpretation : int option; + interpretation : interpretation option; output_format : output_format option; unsat_core : bool option; diff --git a/src/lib/dune b/src/lib/dune index f0ce31441..8b0f1d2c3 100644 --- a/src/lib/dune +++ b/src/lib/dune @@ -29,7 +29,7 @@ ; modules that make up the lib (modules ; frontend - Cnf Input Frontend Parsed_interface Typechecker + Cnf Input Frontend Parsed_interface Typechecker Models ; reasoners Ac Arith Arrays Arrays_rel Bitv Ccx Shostak Relation Enum Enum_rel Fun_sat Inequalities Bitv_rel Th_util Adt Adt_rel @@ -37,7 +37,7 @@ Polynome Records Records_rel Satml_frontend_hybrid Satml_frontend Satml Sat_solver Sat_solver_sig Sig Sig_rel Theory Uf Use ; structures - Commands Errors Explanation Fpa_rounding Models + Commands Errors Explanation Fpa_rounding Parsed Profiling Satml_types Symbols Expr Var Ty Typed Xliteral ; util diff --git a/src/lib/frontend/input.ml b/src/lib/frontend/input.ml index 37f3cfc22..c5be46b79 100644 --- a/src/lib/frontend/input.ml +++ b/src/lib/frontend/input.ml @@ -15,7 +15,7 @@ module type S = sig (* Parsing *) - type parsed = Parsed.decl + type parsed val parse_file : content:string -> format:string option -> parsed Seq.t diff --git a/src/lib/frontend/input.mli b/src/lib/frontend/input.mli index eaf6c07fc..20155f20a 100644 --- a/src/lib/frontend/input.mli +++ b/src/lib/frontend/input.mli @@ -31,7 +31,7 @@ module type S = sig (** {5 Parsing} *) - type parsed = Parsed.decl + type parsed (** The type of a parsed statement. *) val parse_file : content:string -> format:string option -> parsed Seq.t diff --git a/src/lib/models/models.ml b/src/lib/frontend/models.ml similarity index 97% rename from src/lib/models/models.ml rename to src/lib/frontend/models.ml index cbc184abb..f8f2124c7 100644 --- a/src/lib/models/models.ml +++ b/src/lib/frontend/models.ml @@ -24,27 +24,6 @@ module SE = Expr.Set module Sorts = Map.Make(String) -let h = ref Sorts.empty - -let sorts parsed = - let open Parsed in - Format.eprintf "@["; - Seq.iter (fun d -> match d with - | Parsed.Axiom (_, _, _, le) -> begin - match le.pp_desc with - | PPapp("sort", f) - | PPforall_named (_, _, _, {pp_desc = PPapp("sort", f); _}) -> - begin - match f with - | [{pp_desc = PPapp(t, _); _}; {pp_desc = PPapp(f, args); _}] -> - h := Sorts.add f (List.length args, t) !h - | _ -> () - end - | _ -> () - end - | _ -> () - ) parsed - module Profile = struct module P = Map.Make diff --git a/src/lib/models/models.mli b/src/lib/frontend/models.mli similarity index 97% rename from src/lib/models/models.mli rename to src/lib/frontend/models.mli index e4a75c942..5b8a6f99a 100644 --- a/src/lib/models/models.mli +++ b/src/lib/frontend/models.mli @@ -13,8 +13,6 @@ module Sorts : Map.S with type key = string -val sorts : Parsed.decl Seq.t -> unit - module Profile : sig module P : Map.S with type key = diff --git a/src/lib/models/populate.ml b/src/lib/models/populate.ml deleted file mode 100644 index 9c1ff1b1c..000000000 --- a/src/lib/models/populate.ml +++ /dev/null @@ -1,17 +0,0 @@ -module Sorts = Map.Make(String) - -let sorts parsed = - let open Parsed in - Seq.iter (fun d -> match d with - | Axiom (_, _, _, { - pp_desc = - PPapp("sort", [ - {pp_desc = PPapp(t, []); _}; - {pp_desc=PPapp(f, []); _} - ]); _ - }) -> - Format.eprintf "@{sort: %s : %s@}@ " f t - | _ -> () - (* Format.eprintf "blah@." *) - ) parsed; - Format.eprintf "@]@."; From 4dcd4621a45d50dbfb4a3815c8cd65cf16bafbc7 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 16:52:36 +0100 Subject: [PATCH 40/68] Add some documentation in options.ml for type model, instanciation_heuristic and interpretation --- src/lib/util/options.mli | 38 +++++++++++++++++++++++++++++--------- 1 file changed, 29 insertions(+), 9 deletions(-) diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index f4e0631f3..68f3d8574 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -34,15 +34,35 @@ of the program *) -(** Type used to describe the type of models wanted *) -type model = MNone | MDefault | MAll | MComplete - - -(** Type used to describe the type of heuristic for instantiation wanted *) -type instantiation_heuristic = INormal | IAuto | IGreedy - -(** Type used to describe the type of interpretation wanted *) -type interpretation = INone | IFirst | IEvery | ILast +(** Type used to describe the type of models wanted by + {!val:set_model} *) +type model = + | MNone (** Default, No models computed *) + | MDefault (** Output model for variable annotated with "model:" *) + | MComplete (** Output complete boolean and theory model *) + | MAll (** Output propositional model *) + +(** Type used to describe the type of heuristic for instantiation wanted by + {!val:set_instantiation_heuristic} *) +type instantiation_heuristic = + | INormal (** Least costly heuristic for instantiation, instantiate on + a reduced set of term *) + | IAuto (** Default Heuristic that try to do the normal heuristic and + then try a greedier instantiation if no new instance have + been made *) + | IGreedy (** Force instantiation to be the greedier as possible, + use all available ground terms *) + +(** Type used to describe the type of interpretation wanted by + {!val:set_interpretation} *) +type interpretation = + | INone (** Default, No interpretation computed *) + | IFirst (** Compute an interpretation after the first instantiation + and output it at the end of the executionn *) + | IEvery (** Compute an interpretation before every instantiation + and return the last one computed *) + | ILast (** Compute only the last interpretation just before + returning SAT/Unknown *) (** Type used to describe the type of input wanted by {!val:set_input_format} *) From bd1383683ec81402efaa998fbd21e9961cbd9c63 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 17:11:40 +0100 Subject: [PATCH 41/68] Fix no-term-like-pp option comment --- src/bin/common/parse_command.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index a12951325..9bbd9aa33 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -1183,7 +1183,7 @@ let parse_term_opt = Arg.(value & flag & info ["rwt"; "rewriting"] ~docs ~doc) in let no_term_like_pp = - let doc = "Output semantic values as terms." in + let doc = "Do not output semantic values as terms." in Arg.(value & flag & info ["no-term-like-pp"] ~docs ~doc) in Term.(ret (const mk_term_opt $ From 20074d1cd7e03e74f5ff169ac9a8c86150150414 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 17:20:49 +0100 Subject: [PATCH 42/68] Fix model options --- src/lib/util/options.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 5f1dc6b9e..c1960f40b 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -61,7 +61,7 @@ let set_fmt_usc f = fmt_usc := f (* Declaration of all the options as refs with default values *) -type model = MNone | MDefault | MAll | MComplete +type model = MNone | MDefault | MComplete | MAll type instantiation_heuristic = INormal | IAuto | IGreedy type interpretation = INone | IFirst | IEvery | ILast From f0657beffd42ebbec795998492985cbd3b639332 Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Fri, 8 Jan 2021 18:15:34 +0100 Subject: [PATCH 43/68] remove unused models-generation code (all, complete and default models) --- src/bin/common/parse_command.ml | 33 +------------- src/bin/common/signals_profiling.ml | 9 ++-- src/bin/gui/main_gui.ml | 23 ++++++---- src/lib/frontend/frontend.ml | 4 +- src/lib/reasoners/adt_rel.ml | 1 - src/lib/reasoners/arrays_rel.ml | 1 - src/lib/reasoners/bitv_rel.ml | 1 - src/lib/reasoners/ccx.ml | 25 ----------- src/lib/reasoners/ccx.mli | 1 - src/lib/reasoners/enum_rel.ml | 2 - src/lib/reasoners/fun_sat.ml | 65 --------------------------- src/lib/reasoners/intervalCalculus.ml | 27 ----------- src/lib/reasoners/ite_rel.ml | 1 - src/lib/reasoners/records_rel.ml | 1 - src/lib/reasoners/relation.ml | 10 ----- src/lib/reasoners/sat_solver_sig.ml | 2 - src/lib/reasoners/sat_solver_sig.mli | 2 - src/lib/reasoners/satml_frontend.ml | 20 +-------- src/lib/reasoners/sig_rel.mli | 4 -- src/lib/reasoners/theory.ml | 5 --- src/lib/reasoners/theory.mli | 1 - src/lib/util/options.ml | 6 --- src/lib/util/options.mli | 35 --------------- 23 files changed, 23 insertions(+), 256 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 9bbd9aa33..2e3d03497 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -18,24 +18,6 @@ exception Error of bool * string (* Exception used to exit with corresponding retcode *) exception Exit_parse_command of int -let model_parser = function - | "none" -> Ok MNone - | "default" -> Ok MDefault - | "complete" -> Ok MComplete - | "all" -> Ok MAll - | s -> - Error (`Msg ("Option --model does not accept the argument \"" ^ s)) - -let model_to_string = function - | MNone -> "none" - | MDefault -> "default" - | MComplete -> "complete" - | MAll -> "all" - -let model_printer fmt model = Format.fprintf fmt "%s" (model_to_string model) - -let model_conv = Arg.conv ~docv:"MDL" (model_parser, model_printer) - let instantiation_heuristic_parser = function | "normal" -> Ok INormal | "auto" -> Ok IAuto @@ -306,7 +288,7 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() -let mk_output_opt interpretation use_underscore model unsat_core output_format +let mk_output_opt interpretation use_underscore unsat_core output_format = set_infer_output_format output_format; let output_format = match output_format with @@ -315,7 +297,6 @@ let mk_output_opt interpretation use_underscore model unsat_core output_format in set_interpretation interpretation; set_interpretation_use_underscore use_underscore; - set_model model; set_unsat_core unsat_core; set_output_format output_format; `Ok() @@ -938,16 +919,6 @@ let parse_output_opt = Arg.(value & flag & info ["interpretation-use-underscore";"use-underscore"] ~docv ~docs ~doc) in - let model = - let doc = Format.sprintf - "Experimental support for models on labeled terms. \ - $(docv) must be %s. %s shows a complete model and %s shows \ - all models." - (Arg.doc_alts ["none"; "default"; "complete"; "all"]) - (Arg.doc_quote "complete") (Arg.doc_quote "all") in - let docv = "VAL" in - Arg.(value & opt model_conv MNone & info ["m"; "model"] ~docv ~doc) in - let unsat_core = let doc = "Experimental support for computing and printing unsat-cores." in Arg.(value & flag & info ["u"; "unsat-core"] ~doc) in @@ -970,7 +941,7 @@ let parse_output_opt = in Term.(ret (const mk_output_opt $ - interpretation $ use_underscore $ model $ unsat_core $ + interpretation $ use_underscore $ unsat_core $ output_format )) diff --git a/src/bin/common/signals_profiling.ml b/src/bin/common/signals_profiling.ml index 52aec14da..6438555ce 100644 --- a/src/bin/common/signals_profiling.ml +++ b/src/bin/common/signals_profiling.ml @@ -74,11 +74,10 @@ let init_sigterm_21 () = ) let init_sigalarm () = - if not (get_model ()) then - try - Sys.set_signal Sys.sigvtalrm - (Sys.Signal_handle (fun _ -> Options.exec_timeout ())) - with Invalid_argument _ -> () + try + Sys.set_signal Sys.sigvtalrm + (Sys.Signal_handle (fun _ -> Options.exec_timeout ())) + with Invalid_argument _ -> () let init_profiling () = if Options.get_profiling () then begin diff --git a/src/bin/gui/main_gui.ml b/src/bin/gui/main_gui.ml index 8b467e4c0..d581abf8d 100644 --- a/src/bin/gui/main_gui.ml +++ b/src/bin/gui/main_gui.ml @@ -194,6 +194,7 @@ let show_about () = let pop_error ?(error=false) ~message () = let pop_w = GWindow.dialog ~title:(if error then "Error" else "Warning") + ~allow_grow:true ~position:`CENTER ~width:400 () in @@ -517,7 +518,7 @@ let update_status image label buttonclean env s steps = image#set_stock `EXECUTE; label#set_text " Inconsistent assumption" - | FE.Unknown (d, t) -> + | FE.Unknown (d, _t) -> if not satmode then Printer.print_std "%a@ I don't know." Loc.report d.st_loc else @@ -525,9 +526,8 @@ let update_status image label buttonclean env s steps = image#set_stock `NO; label#set_text (sprintf " I don't know (%2.2f s)" (Options.Time.value())); - if get_model () then pop_model t () - | FE.Sat (d, t) -> + | FE.Sat (d, _t) -> if not satmode then Printer.print_std "%a" Loc.report d.st_loc; if satmode then @@ -537,7 +537,6 @@ let update_status image label buttonclean env s steps = image#set_stock `NO; label#set_text (sprintf " I don't know (sat) (%2.2f s)" (Options.Time.value())); - if get_model () then pop_model t () | FE.Timeout _ -> assert false (* should not happen in GUI ? *) @@ -814,6 +813,8 @@ let create_error_view error_model buffer sv ~packing () = ~callback:(goto_error view error_model buffer sv)); view + + let goto_lemma (view:GTree.view) inst_model buffer (sv:GSourceView3.source_view) env path _column = let model = view#model in @@ -831,6 +832,9 @@ let goto_lemma (view:GTree.view) inst_model buffer env.last_tag <- t; with Not_found -> () + +let colormap () = Gdk.Color.get_system_colormap () + let set_color_inst inst_model renderer (istore:GTree.model) row = let id = istore#get ~row ~column:inst_model.icol_tag in let _, nb_inst, _, limit = Hashtbl.find inst_model.h id in @@ -970,6 +974,7 @@ let search_all entry (_sv:GSourceView3.source_view) search_one buf str result iter found_all_tag done + let start_gui all_used_context = Options.set_timers true; Options.set_thread_yield Thread.yield; @@ -979,9 +984,12 @@ let start_gui all_used_context = Printer.print_std "Timeout"; raise Util.Timeout); + let w = GWindow.window ~title:"AltGr-Ergo" + ~allow_grow:true + ~allow_shrink:true ~position:`CENTER ~width:window_width ~height:window_height () @@ -1245,6 +1253,8 @@ let start_gui all_used_context = ~callback:(search_next ~backward:true tv1 buf1 found_tag found_all_tag)); + + let sw3 = GBin.scrolled_window ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC @@ -1368,11 +1378,6 @@ let start_gui all_used_context = ] in let options_entries = - let set_complete_model b = - if b then set_model MComplete else set_model MNone in - let set_all_models b = - if b then set_model MAll else set_model MNone in - let set_model b = if b then set_model MDefault else set_model MNone in let set_greedy b = if b then set_instantiation_heuristic IGreedy diff --git a/src/lib/frontend/frontend.ml b/src/lib/frontend/frontend.ml index 6f114993b..a0950a42c 100644 --- a/src/lib/frontend/frontend.ml +++ b/src/lib/frontend/frontend.ml @@ -227,7 +227,7 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct (* This case should mainly occur when a query has a non-unsat result, so we want to print the status in this case. *) print_status (Sat (d,t)) (Steps.get_steps ()); - if get_model () then SAT.print_model ~header:true (get_fmt_mdl ()) t; + (*if get_model () then SAT.print_model ~header:true (get_fmt_mdl ()) t;*) env , consistent, dep | SAT.Unsat dep' -> (* This case should mainly occur when a new assumption results in an unsat @@ -242,7 +242,7 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct Instead, it'd be better to accumulate in `consistent` a 3-case adt and not a simple bool. *) print_status (Unknown (d, t)) (Steps.get_steps ()); - if get_model () then SAT.print_model ~header:true (get_fmt_mdl ()) t; + (*if get_model () then SAT.print_model ~header:true (get_fmt_mdl ()) t;*) env , consistent, dep | Util.Timeout as e -> (* In this case, we obviously want to print the status, diff --git a/src/lib/reasoners/adt_rel.ml b/src/lib/reasoners/adt_rel.ml index 127942908..1333c3994 100644 --- a/src/lib/reasoners/adt_rel.ml +++ b/src/lib/reasoners/adt_rel.ml @@ -147,7 +147,6 @@ end (* ################################################################ *) -let print_model _ _ _ = () let new_terms env = env.new_terms let instantiate ~do_syntactic_matching:_ _ env _ _ = env, [] diff --git a/src/lib/reasoners/arrays_rel.ml b/src/lib/reasoners/arrays_rel.ml index 7d4efc8ec..f7a23607b 100644 --- a/src/lib/reasoners/arrays_rel.ml +++ b/src/lib/reasoners/arrays_rel.ml @@ -450,7 +450,6 @@ let assume env uf la = let query _ _ _ = None let add env _ _ _ = env, [] -let print_model _ _ _ = () let new_terms env = env.new_terms let instantiate ~do_syntactic_matching:_ _ env _ _ = env, [] diff --git a/src/lib/reasoners/bitv_rel.ml b/src/lib/reasoners/bitv_rel.ml index e70ee5f66..871c54ad5 100644 --- a/src/lib/reasoners/bitv_rel.ml +++ b/src/lib/reasoners/bitv_rel.ml @@ -34,7 +34,6 @@ let assume _ _ _ = let query _ _ _ = None let case_split _ _ ~for_model:_ = [] let add env _ _ _ = env, [] -let print_model _ _ _ = () let new_terms _ = Expr.Set.empty let instantiate ~do_syntactic_matching:_ _ env _ _ = env, [] diff --git a/src/lib/reasoners/ccx.ml b/src/lib/reasoners/ccx.ml index efac0bc78..e965ef50e 100644 --- a/src/lib/reasoners/ccx.ml +++ b/src/lib/reasoners/ccx.ml @@ -78,7 +78,6 @@ module type S = sig val are_distinct : t -> Expr.t -> Expr.t -> Th_util.answer val cl_extract : t -> Expr.Set.t list val term_repr : t -> Expr.t -> init_term:bool -> Expr.t - val print_model : Format.formatter -> complete_model:bool -> t -> unit val get_union_find : t -> Uf.t @@ -732,30 +731,6 @@ module Main : S = struct let get_union_find env = env.uf - let print_model fmt ~complete_model env = - let zero = ref true in - let eqs, neqs = Uf.model ~complete_model env.uf in - let rs = - List.fold_left (fun acc (r, l, to_rel) -> - if l != [] then begin - if !zero then begin - fprintf fmt "Theory:"; - zero := false; - end; - fprintf fmt "\n %a = %a" (E.print_list_sep " = ") l X.print r; - end; - to_rel@acc - ) [] eqs in - List.iter (fun lt -> - if !zero then begin - fprintf fmt "Theory:"; - zero := false; - end; - fprintf fmt "\n %a" (E.print_list_sep " <> ") lt; - ) neqs; - if not !zero then fprintf fmt "\n@."; - Rel.print_model fmt env.relation rs - let assume_th_elt env th_elt dep = {env with relation = Rel.assume_th_elt env.relation th_elt dep} diff --git a/src/lib/reasoners/ccx.mli b/src/lib/reasoners/ccx.mli index 7d8d8d32f..7dc919910 100644 --- a/src/lib/reasoners/ccx.mli +++ b/src/lib/reasoners/ccx.mli @@ -71,7 +71,6 @@ module type S = sig val are_distinct : t -> Expr.t -> Expr.t -> Th_util.answer val cl_extract : t -> Expr.Set.t list val term_repr : t -> Expr.t -> init_term:bool -> Expr.t - val print_model : Format.formatter -> complete_model:bool -> t -> unit val get_union_find : t -> Uf.t val assume_th_elt : t -> Expr.th_elt -> Explanation.t -> t diff --git a/src/lib/reasoners/enum_rel.ml b/src/lib/reasoners/enum_rel.ml index 9741051fa..6db7d03a8 100644 --- a/src/lib/reasoners/enum_rel.ml +++ b/src/lib/reasoners/enum_rel.ml @@ -302,8 +302,6 @@ let query env uf la = else query env uf la -let print_model _ _ _ = () - let new_terms _ = Expr.Set.empty let instantiate ~do_syntactic_matching:_ _ env _ _ = env, [] diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 299365064..cecca414e 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -179,12 +179,10 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct unit_facts_cache : (E.gformula * Ex.t) ME.t ref; } - let all_models_sat_env = ref None let latest_saved_env = ref None let terminated_normally = ref false let reset_refs () = - all_models_sat_env := None; latest_saved_env := None; terminated_normally := false; Steps.reset_steps () @@ -461,38 +459,6 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct t.gamma; !s - let print_prop_model fmt s = - SE.iter (fprintf fmt "\n %a" E.print) s - - let print_model ~header fmt t = - Format.print_flush (); - if header then fprintf fmt "\nModel\n"; - let pm = extract_prop_model ~complete_model:(get_complete_model ()) t in - if not (SE.is_empty pm) then begin - fprintf fmt "Propositional:"; - print_prop_model fmt pm; - fprintf fmt "\n"; - end; - Th.print_model fmt ~complete_model:(get_complete_model ()) t.tbox - - - let refresh_model_handler = - if get_model () then - fun t -> - try - let alrm = - if Options.get_is_gui() then - Sys.sigalrm (* troubles with GUI+VTARLM *) - else - Sys.sigvtalrm - in - Sys.set_signal alrm - (Sys.Signal_handle (fun _ -> - Printer.print_fmt (Options.get_fmt_mdl ()) - "%a" (print_model ~header:true) t; - Options.exec_timeout ())) - with Invalid_argument _ -> () - else fun _ -> () (* sat-solver *) @@ -980,7 +946,6 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct (fun ((env, _bcp, tcp, ap_delta, lits) as acc) ({ E.ff = f; _ } as ff, dep) -> - refresh_model_handler env; Options.exec_thread_yield (); let dep = add_dep f dep in let dep_gamma = add_dep_of_formula f dep in @@ -1182,32 +1147,6 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct ignore (update_instances_cache (Some [])); env, true - let update_all_models_option env = - if get_all_models () then - begin - (* should be used when all_models () is activated only *) - if !all_models_sat_env == None then all_models_sat_env := Some env; - let m = - ME.fold - (fun f _ s -> if is_literal f then SE.add f s else s) - env.gamma SE.empty - in - Printer.print_fmt (Options.get_fmt_mdl ()) - "@[--- SAT model found ---@ \ - %a@ \ - --- / SAT model ---@]" - print_prop_model m; - raise (IUnsat (Ex.make_deps m, [])) - end - - let get_all_models_answer () = - if get_all_models () then - match !all_models_sat_env with - | Some env -> raise (I_dont_know env) - | None -> - Printer.print_fmt (Options.get_fmt_mdl ()) - "[all-models] No SAT models found" - let compute_concrete_model env compute = let compute = @@ -1261,7 +1200,6 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let return_answer env compute return_function = - update_all_models_option env; let env = compute_concrete_model env compute in Options.Time.unset_timeout ~is_gui:(Options.get_is_gui()); @@ -1784,7 +1722,6 @@ are not Th-reduced"; acc.guards.guards in acc.model_gen_mode := false; - all_models_sat_env := None; latest_saved_env := None; terminated_normally := false; {acc with inst; @@ -1858,14 +1795,12 @@ are not Th-reduced"; let d = back_tracking env in assert (Ex.has_no_bj d); - get_all_models_answer (); terminated_normally := true; d with | IUnsat (dep, classes) -> Debug.bottom classes; Debug.unsat (); - get_all_models_answer (); terminated_normally := true; assert (Ex.has_no_bj dep); dep diff --git a/src/lib/reasoners/intervalCalculus.ml b/src/lib/reasoners/intervalCalculus.ml index 05d75be4e..51f44a14d 100644 --- a/src/lib/reasoners/intervalCalculus.ml +++ b/src/lib/reasoners/intervalCalculus.ml @@ -1865,33 +1865,6 @@ let add = env.improved MP.empty *) -let print_model fmt env rs = match rs with - | [] -> () - | _ -> - fprintf fmt "Relation:"; - List.iter (fun (t, r) -> - let p = poly_of r in - let ty = P.type_info p in - if ty == Ty.Tint || ty == Ty.Treal then - let p', c, d = P.normal_form_pos p in - let pu' = - try MP.n_find p' env.polynomes - with Not_found -> I.undefined ty - in - let pm' = - try intervals_from_monomes ~monomes_inited:false env p' - with Not_found -> I.undefined ty - in - let u' = I.intersect pu' pm' in - if I.is_point u' == None && I.is_undefined u' then - let u = - I.scale d - (I.add u' - (I.point c ty Explanation.empty)) in - fprintf fmt "\n %a ∈ %a" E.print t I.pretty_print u - ) rs; - fprintf fmt "\n@." - let new_terms _ = SE.empty let case_split_union_of_intervals = diff --git a/src/lib/reasoners/ite_rel.ml b/src/lib/reasoners/ite_rel.ml index 59f666577..1072fa2ee 100644 --- a/src/lib/reasoners/ite_rel.ml +++ b/src/lib/reasoners/ite_rel.ml @@ -174,7 +174,6 @@ let assume env uf la = let case_split _ _ ~for_model:_ = [] let query _ _ _ = None -let print_model _ _ _ = () let new_terms _ = E.Set.empty let instantiate ~do_syntactic_matching:_ _ env _ _ = env, [] diff --git a/src/lib/reasoners/records_rel.ml b/src/lib/reasoners/records_rel.ml index 81b320e9b..b7d0e32a9 100644 --- a/src/lib/reasoners/records_rel.ml +++ b/src/lib/reasoners/records_rel.ml @@ -34,7 +34,6 @@ let assume _ _ _ = let query _ _ _ = None let case_split _ _ ~for_model:_ = [] let add env _ _ _ = env, [] -let print_model _ _ _ = () let new_terms _ = Expr.Set.empty let instantiate ~do_syntactic_matching:_ _ env _ _ = env, [] diff --git a/src/lib/reasoners/relation.ml b/src/lib/reasoners/relation.ml index b371228c4..c453f2e13 100644 --- a/src/lib/reasoners/relation.ml +++ b/src/lib/reasoners/relation.ml @@ -174,15 +174,6 @@ let instantiate ~do_syntactic_matching t_match env uf selector = {r1=r1; r2=r2; r3=r3; r4=r4; r5=r5; r6=r6; r7=r7}, l7 |@| l6 |@| l5 |@| l4 |@| l3 |@| l2 |@| l1 -let print_model fmt env rs = - Rel1.print_model fmt env.r1 rs; - Rel2.print_model fmt env.r2 rs; - Rel3.print_model fmt env.r3 rs; - Rel4.print_model fmt env.r4 rs; - Rel5.print_model fmt env.r5 rs; - Rel6.print_model fmt env.r6 rs; - Rel7.print_model fmt env.r7 rs - let new_terms env = let t1 = Rel1.new_terms env.r1 in let t2 = Rel2.new_terms env.r2 in @@ -197,4 +188,3 @@ let new_terms env = (Expr.Set.union t4 (Expr.Set.union t5 (Expr.Set.union t6 t7)) ))) - diff --git a/src/lib/reasoners/sat_solver_sig.ml b/src/lib/reasoners/sat_solver_sig.ml index d25cb6acb..06ca40c5e 100644 --- a/src/lib/reasoners/sat_solver_sig.ml +++ b/src/lib/reasoners/sat_solver_sig.ml @@ -66,8 +66,6 @@ module type S = sig [size]. Raises Sat if [f] is satisfiable in [env] *) val unsat : t -> Expr.gformula -> Explanation.t - val print_model : header:bool -> Format.formatter -> t -> unit - val reset_refs : unit -> unit (** [reinit_ctx ()] reinitializes the solving context. *) diff --git a/src/lib/reasoners/sat_solver_sig.mli b/src/lib/reasoners/sat_solver_sig.mli index 0cb096704..6a30b6d80 100644 --- a/src/lib/reasoners/sat_solver_sig.mli +++ b/src/lib/reasoners/sat_solver_sig.mli @@ -67,8 +67,6 @@ module type S = sig (** [print_model header fmt env] print propositional model and theory model on the corresponding fmt. *) - val print_model : header:bool -> Format.formatter -> t -> unit - val reset_refs : unit -> unit (** [reinit_ctx ()] reinitializes the solving context. *) diff --git a/src/lib/reasoners/satml_frontend.ml b/src/lib/reasoners/satml_frontend.ml index 57d20e9f8..ceb213460 100644 --- a/src/lib/reasoners/satml_frontend.ml +++ b/src/lib/reasoners/satml_frontend.ml @@ -317,22 +317,6 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct (*BISECT-IGNORE-END*) - let print_propositional_model env fmt = - let model = SAT.boolean_model env.satml in - fprintf fmt "Propositional:"; - List.iter - (fun at -> - (fprintf fmt "\n %a" E.print) (Atom.literal at) - ) model; - fprintf fmt "\n@." - - let print_model ~header fmt env = - Format.print_flush (); - if header then fprintf fmt "\nModel\n@."; - print_propositional_model env fmt; - Th.print_model fmt ~complete_model:(get_complete_model ()) - (SAT.current_tbox env.satml) - let make_explanation _ = Ex.empty (* if get_debug_sat () then @@ -1039,9 +1023,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let open Options in if get_interpretation () then fails "interpretation"; if get_save_used_context () then fails "save_used_context"; - if get_unsat_core () then fails "unsat_core"; - if get_all_models () then fails "all_models"; - if get_model () then fails "model" + if get_unsat_core () then fails "unsat_core" let create_guard env = let expr_guard = E.fresh_name Ty.Tbool in diff --git a/src/lib/reasoners/sig_rel.mli b/src/lib/reasoners/sig_rel.mli index ecdfc110d..9bb9851b6 100644 --- a/src/lib/reasoners/sig_rel.mli +++ b/src/lib/reasoners/sig_rel.mli @@ -72,12 +72,8 @@ module type RELATION = sig t -> Uf.t -> (Expr.t -> Expr.t -> bool) -> t * instances - val print_model : - Format.formatter -> t -> (Expr.t * Shostak.Combine.r) list -> unit - val new_terms : t -> Expr.Set.t val assume_th_elt : t -> Expr.th_elt -> Explanation.t -> t end - diff --git a/src/lib/reasoners/theory.ml b/src/lib/reasoners/theory.ml index 3ce2a318a..83438fd5b 100644 --- a/src/lib/reasoners/theory.ml +++ b/src/lib/reasoners/theory.ml @@ -56,7 +56,6 @@ module type S = sig t * Expr.Set.t * int val query : E.t -> t -> Th_util.answer - val print_model : Format.formatter -> complete_model:bool -> t -> unit val cl_extract : t -> Expr.Set.t list val extract_ground_terms : t -> Expr.Set.t val get_real_env : t -> Ccx.Main.t @@ -715,9 +714,6 @@ module Main_Default : S = struct let t, _, _ = assume true [a, Ex.empty, 0, -1] t in t - let print_model fmt ~complete_model t = - CC_X.print_model fmt ~complete_model t.gamma_finite - let cl_extract env = CC_X.cl_extract env.gamma let assume ?(ordered=true) facts t = @@ -785,7 +781,6 @@ module Main_Empty : S = struct let query _ _ = None - let print_model _ ~complete_model:_ _ = () let cl_extract _ = [] let extract_ground_terms _ = Expr.Set.empty diff --git a/src/lib/reasoners/theory.mli b/src/lib/reasoners/theory.mli index da55e0a83..99e336ec7 100644 --- a/src/lib/reasoners/theory.mli +++ b/src/lib/reasoners/theory.mli @@ -40,7 +40,6 @@ module type S = sig t * Expr.Set.t * int val query : Expr.t -> t -> Th_util.answer - val print_model : Format.formatter -> complete_model:bool -> t -> unit val cl_extract : t -> Expr.Set.t list val extract_ground_terms : t -> Expr.Set.t val get_real_env : t -> Ccx.Main.t diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index c1960f40b..708fbab9a 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -61,7 +61,6 @@ let set_fmt_usc f = fmt_usc := f (* Declaration of all the options as refs with default values *) -type model = MNone | MDefault | MComplete | MAll type instantiation_heuristic = INormal | IAuto | IGreedy type interpretation = INone | IFirst | IEvery | ILast @@ -299,14 +298,12 @@ let get_timelimit_per_goal () = !timelimit_per_goal let interpretation = ref INone let interpretation_use_underscore = ref false -let model = ref MNone let output_format = ref Native let infer_output_format = ref true let unsat_core = ref false let set_interpretation b = interpretation := b let set_interpretation_use_underscore b = interpretation_use_underscore := b -let set_model b = model := b let set_output_format b = output_format := b let set_infer_output_format f = infer_output_format := f = None let set_unsat_core b = unsat_core := b @@ -316,9 +313,6 @@ let get_first_interpretation () = !interpretation = IFirst let get_every_interpretation () = !interpretation = IEvery let get_last_interpretation () = !interpretation = ILast let get_interpretation_use_underscore () = !interpretation_use_underscore -let get_model () = !model = MDefault || !model = MComplete -let get_complete_model () = !model = MComplete -let get_all_models () = !model = MAll let get_output_format () = !output_format let get_output_smtlib () = (!output_format = Smtlib2) || (!output_format = Why3) diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index 68f3d8574..a7cda0cc0 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -34,14 +34,6 @@ of the program *) -(** Type used to describe the type of models wanted by - {!val:set_model} *) -type model = - | MNone (** Default, No models computed *) - | MDefault (** Output model for variable annotated with "model:" *) - | MComplete (** Output complete boolean and theory model *) - | MAll (** Output propositional model *) - (** Type used to describe the type of heuristic for instantiation wanted by {!val:set_instantiation_heuristic} *) type instantiation_heuristic = @@ -220,13 +212,6 @@ val set_interpretation_use_underscore : bool -> unit (** Set [max_split] accessible with {!val:get_max_split} *) val set_max_split : Numbers.Q.t -> unit -(** Set [model] accessible with {!val:get_model} - - Possible values are : - {ul {- Default} {- Complete} {- All}} -*) -val set_model : model -> unit - (** Set [nb_triggers] accessible with {!val:get_nb_triggers} *) val set_nb_triggers : int -> unit @@ -696,26 +681,6 @@ val get_timelimit_per_goal : unit -> bool (** {4 Output options} *) -(** Experimental support for models on labeled terms. - - Possible values are - {ul {- None} {- Default} {- Complete : shows a complete model} - {- All : shows all models}} - - Which are used in the two getters below. This option answers - [true] if the model is set to Default or Complete -*) -val get_model : unit -> bool -(** Default to [false] *) - -(** [true] if the model is set to complete model *) -val get_complete_model : unit -> bool -(** Default to [false] *) - -(** [true] if the model is set to all models *) -val get_all_models : unit -> bool -(** Default to [false] *) - (** Experimental support for counter-example generation. Possible values are : From 8884c620331d340c137c4438442c460a796848bf Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 18:56:50 +0100 Subject: [PATCH 44/68] remove functions related to old model --- src/lib/reasoners/fun_sat.ml | 2 +- src/lib/reasoners/uf.ml | 9 ++------- src/lib/reasoners/uf.mli | 3 +-- src/lib/structures/expr.ml | 22 ---------------------- src/lib/structures/expr.mli | 1 - 5 files changed, 4 insertions(+), 33 deletions(-) diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index cecca414e..e5d8e6527 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -453,7 +453,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let s = ref SE.empty in ME.iter (fun f _ -> - if (complete_model && is_literal f) || E.is_in_model f then + if complete_model && is_literal f then s := SE.add f !s ) t.gamma; diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index c149ca04e..e495953fb 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -882,16 +882,14 @@ let mapt_choose m = with Exit -> ()); match !r with Some b -> b | _ -> raise Not_found -let model ~complete_model env = +let model env = let eqs = MapX.fold (fun r cl acc -> let l, to_rel = List.fold_left (fun (l, to_rel) t -> let rt = ME.find t env.make in - if complete_model || E.is_in_model t then if X.equal rt r then l, (t,rt)::to_rel else t::l, (t,rt)::to_rel - else l, to_rel ) ([], []) (SE.elements cl) in (r, l, to_rel)::acc ) env.classes [] @@ -901,15 +899,12 @@ let model ~complete_model env = let x, rx = mapt_choose makes in let makes = ME.remove x makes in let acc = - if complete_model || E.is_in_model x then ME.fold (fun y ry acc -> - if (complete_model || E.is_in_model y) - && (already_distinct env [rx; ry] + if (already_distinct env [rx; ry] || already_distinct env [ry; rx]) then [y; x]::acc else acc ) makes acc - else acc in extract_neqs acc makes with Not_found -> acc in diff --git a/src/lib/reasoners/uf.mli b/src/lib/reasoners/uf.mli index fc5c0bd91..05336759a 100644 --- a/src/lib/reasoners/uf.mli +++ b/src/lib/reasoners/uf.mli @@ -57,8 +57,7 @@ val class_of : t -> Expr.t -> Expr.t list val rclass_of : t -> r -> Expr.Set.t val cl_extract : t -> Expr.Set.t list -val model : complete_model:bool -> t -> - (r * Expr.t list * (Expr.t * r) list) list * (Expr.t list) list +val model : t -> (r * Expr.t list * (Expr.t * r) list) list * (Expr.t list) list val print : t -> unit val term_repr : t -> Expr.t -> Expr.t diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index 65828da52..f5cdca0ec 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -702,28 +702,6 @@ let label t = let { f = f; _ } = t in Sy.label f -let is_model_label = - let model = "model:" in - fun h -> - try String.equal (String.sub (Hstring.view h) 0 6) model - with Invalid_argument _ -> false - -let rec is_in_model_rec depth { f = f; xs = xs ; _ } = - let lb = Sy.label f in - (is_model_label lb - && - (try depth <= Scanf.sscanf (Hstring.view lb) "model:%d" (fun x -> x) - with Scanf.Scan_failure _ | End_of_file-> true)) - || - List.exists (is_in_model_rec (depth +1)) xs - -let rec is_in_model e = - is_model_label (label e) || - match e with - | { f = Sy.Form _; _ } -> false - | { f = Sy.Lit _ ; xs; _ } -> List.exists is_in_model xs - | _ -> is_in_model_rec 0 e - let print_tagged_classes = let is_labeled t = not (Hstring.equal (label t) Hstring.empty) in fun fmt l -> diff --git a/src/lib/structures/expr.mli b/src/lib/structures/expr.mli index 1c708dcf1..c9a990aae 100644 --- a/src/lib/structures/expr.mli +++ b/src/lib/structures/expr.mli @@ -176,7 +176,6 @@ val [@inline always] get_infos : t -> view val add_label : Hstring.t -> t -> unit val label : t -> Hstring.t -val is_in_model : t -> bool val name_of_lemma : t -> string val name_of_lemma_opt : t option -> string val print_tagged_classes : Format.formatter -> Set.t list -> unit From 3b15a1fc493d1e7b1085126001db3f8e3df5650c Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Fri, 8 Jan 2021 19:46:18 +0100 Subject: [PATCH 45/68] clean unused code --- src/lib/reasoners/uf.ml | 39 --------------------------------------- src/lib/reasoners/uf.mli | 1 - 2 files changed, 40 deletions(-) diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index e495953fb..99378f55a 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -873,45 +873,6 @@ let already_distinct env lr = true with Not_found -> false -let mapt_choose m = - let r = ref None in - (try - ME.iter (fun x rx -> - r := Some (x, rx); raise Exit - ) m - with Exit -> ()); - match !r with Some b -> b | _ -> raise Not_found - -let model env = - let eqs = - MapX.fold (fun r cl acc -> - let l, to_rel = - List.fold_left (fun (l, to_rel) t -> - let rt = ME.find t env.make in - if X.equal rt r then l, (t,rt)::to_rel - else t::l, (t,rt)::to_rel - ) ([], []) (SE.elements cl) in - (r, l, to_rel)::acc - ) env.classes [] - in - let rec extract_neqs acc makes = - try - let x, rx = mapt_choose makes in - let makes = ME.remove x makes in - let acc = - ME.fold (fun y ry acc -> - if (already_distinct env [rx; ry] - || already_distinct env [ry; rx]) - then [y; x]::acc - else acc - ) makes acc - in extract_neqs acc makes - with Not_found -> acc - in - let neqs = extract_neqs [] env.make in - eqs, neqs - - let find env t = Options.tool_req 3 "TR-UFX-Find"; Env.lookup_by_t t env diff --git a/src/lib/reasoners/uf.mli b/src/lib/reasoners/uf.mli index 05336759a..e31772603 100644 --- a/src/lib/reasoners/uf.mli +++ b/src/lib/reasoners/uf.mli @@ -57,7 +57,6 @@ val class_of : t -> Expr.t -> Expr.t list val rclass_of : t -> r -> Expr.Set.t val cl_extract : t -> Expr.Set.t list -val model : t -> (r * Expr.t list * (Expr.t * r) list) list * (Expr.t list) list val print : t -> unit val term_repr : t -> Expr.t -> Expr.t From 97635ed58dbbd6ece729a530f1f0b862f909f9ad Mon Sep 17 00:00:00 2001 From: OriginLabs-Iguernlala Date: Sat, 9 Jan 2021 09:11:18 +0100 Subject: [PATCH 46/68] fix linter --- src/bin/common/parse_command.ml | 3 ++- src/lib/util/options.mli | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 2e3d03497..1b18a4fcc 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -917,7 +917,8 @@ let parse_output_opt = let doc = "Output \"_\" instead of fresh value in interpretation" in let docv = "VAL" in Arg.(value & flag & info - ["interpretation-use-underscore";"use-underscore"] ~docv ~docs ~doc) in + ["interpretation-use-underscore";"use-underscore"] + ~docv ~docs ~doc) in let unsat_core = let doc = "Experimental support for computing and printing unsat-cores." in diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index a7cda0cc0..f89ba4a97 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -35,7 +35,7 @@ *) (** Type used to describe the type of heuristic for instantiation wanted by - {!val:set_instantiation_heuristic} *) + {!val:set_instantiation_heuristic} *) type instantiation_heuristic = | INormal (** Least costly heuristic for instantiation, instantiate on a reduced set of term *) @@ -46,7 +46,7 @@ type instantiation_heuristic = use all available ground terms *) (** Type used to describe the type of interpretation wanted by - {!val:set_interpretation} *) + {!val:set_interpretation} *) type interpretation = | INone (** Default, No interpretation computed *) | IFirst (** Compute an interpretation after the first instantiation From a961b3309ef129bb9f25ae5fdd747b2760580ef2 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 17:36:08 +0100 Subject: [PATCH 47/68] Fix frontend output in case of timeout --- src/lib/frontend/frontend.ml | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/lib/frontend/frontend.ml b/src/lib/frontend/frontend.ml index a0950a42c..8302ca05f 100644 --- a/src/lib/frontend/frontend.ml +++ b/src/lib/frontend/frontend.ml @@ -279,11 +279,6 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct | Query(g,_,_) -> Some g | _ -> None in - let why3_counterexample = - match Options.get_output_format () with - | Why3 | Smtlib2 -> true - | Native | Unknown _ -> false - in let time = Time.value() in match status with @@ -317,13 +312,17 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout (Some d) -> - if not why3_counterexample then + if Options.get_interpretation () then + Printer.print_wrn "Timeout" + else let loc = d.st_loc in Printer.print_status_timeout ~validity_mode (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout None -> - if not why3_counterexample then + if Options.get_interpretation () then + Printer.print_wrn "Timeout" + else Printer.print_status_timeout ~validity_mode None (Some time) (Some steps) None; From 388d8c8eaeb682fca0afb2447bac029ccef07237 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 18:09:30 +0100 Subject: [PATCH 48/68] Clean models, remove old native output, and remove ref for records --- src/lib/frontend/models.ml | 190 ++++++++---------------------------- src/lib/frontend/models.mli | 2 - 2 files changed, 42 insertions(+), 150 deletions(-) diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index f8f2124c7..cd72be0d4 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -21,8 +21,7 @@ module Sy = Symbols module E = Expr module ME = Expr.Map module SE = Expr.Set - -module Sorts = Map.Make(String) +module MS = Map.Make(String) module Profile = struct @@ -84,97 +83,7 @@ module Profile = struct let is_empty = P.is_empty end -let constraints = ref Sorts.empty - -let assert_has_depth_one_at_most (e, _) = - match X.term_extract e with - | Some t, true -> - assert (E.depth t <= 1); (* true and false have depth = -1 *) - | _ -> - () - -module AECounterExample = struct - - let x_print fmt (_ , ppr) = fprintf fmt "%s" ppr - - let print_args fmt l = - match l with - | [] -> assert false - | [_,e] -> - fprintf fmt "%a" x_print e; - | (_,e) :: l -> - fprintf fmt "%a" x_print e; - List.iter (fun (_, e) -> fprintf fmt " %a" x_print e) l - - let print_symb ty fmt f = - match f, ty with - | Sy.Op Sy.Record, Ty.Trecord { Ty.name ; _ } -> - fprintf fmt "%a__%s" Sy.print f (Hstring.view name) - - | _ -> Sy.print fmt f - - let output_constants_counterexample fmt cprofs = - (*printf "; constants:@.";*) - Profile.iter - (fun (f, _xs_ty, ty) st -> - match Profile.V.elements st with - | [[], rep] -> - (*printf " (%a %a) ; %a@." - (print_symb ty) f x_print rep Ty.print ty*) - Printer.print_fmt ~flushed:false fmt - "(s(%d): %a, rep: %a)@ " - (List.length _xs_ty) (print_symb ty) f x_print rep - | _ -> assert false - ) cprofs - - let output_functions_counterexample fmt fprofs = - if not (Profile.is_empty fprofs) then begin - Printer.print_fmt ~flushed:false fmt "@[@ "; - (*printf "@.; functions:@.";*) - Profile.iter - (fun (f, _xs_ty, ty) st -> - (*printf " ; fun %a : %a -> %a@." - (print_symb ty) f Ty.print_list xs_ty Ty.print ty;*) - Printer.print_fmt ~flushed:false fmt "@[@ "; - Profile.V.iter - (fun (xs, rep) -> - Printer.print_fmt ~flushed:false fmt - "((s: %a, args: %a) rep: %a)@ " - (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one_at_most x) xs; - )st; - Printer.print_fmt ~flushed:false fmt "@]@ "; - ) fprofs; - Printer.print_fmt fmt "@]"; - end - - let output_arrays_counterexample fmt arrays = - if not (Profile.is_empty arrays) then begin - Printer.print_fmt ~flushed:false fmt "@[@ "; - (*printf "; arrays:@.";*) - Profile.iter - (fun (f, xs_ty, ty) st -> - match xs_ty with - [_] -> - (*printf " ; array %a : %a -> %a@." - (print_symb ty) f Ty.print tyi Ty.print ty;*) - Printer.print_fmt ~flushed:false fmt "@[@ "; - Profile.V.iter - (fun (xs, rep) -> - Printer.print_fmt ~flushed:false fmt - "((%a %a) %a)@ " - (print_symb ty) f print_args xs x_print rep; - List.iter (fun (_,x) -> assert_has_depth_one_at_most x) xs; - )st; - Printer.print_fmt ~flushed:false fmt "@]@ "; - | _ -> assert false - - ) arrays; - Printer.print_fmt fmt "@]"; - end - -end -(* of module AECounterExample *) +let constraints = ref MS.empty module Pp_smtlib_term = struct @@ -325,11 +234,11 @@ module Pp_smtlib_term = struct | Sy.Name (n,_), _ -> begin try let constraint_name,_ty_name = - Sorts.find (Hstring.view n) !constraints in + MS.find (Hstring.view n) !constraints in fprintf fmt "%s" constraint_name with _ -> let constraint_name = "c_"^(Hstring.view n) in - constraints := Sorts.add (Hstring.view n) + constraints := MS.add (Hstring.view n) (constraint_name,to_string_type (E.type_info t)) !constraints; fprintf fmt "%s" constraint_name end @@ -376,23 +285,19 @@ module SmtlibCounterExample = struct else fprintf fmt "_ " - module Records = Map.Make(String) - module Destructors = Map.Make(String) - let records = ref Records.empty - - let add_records_destr record_name destr_name rep = + let add_records_destr records record_name destr_name rep = let destrs = - try Records.find record_name !records - with Not_found -> Destructors.empty + try MS.find record_name records + with Not_found -> MS.empty in let destrs = - Destructors.add destr_name rep destrs in - records := Records.add record_name destrs !records + MS.add destr_name rep destrs in + MS.add record_name destrs records - let mk_records_constr record_name + let mk_records_constr records record_name { Ty.name = _n; record_constr = cstr; lbs = lbs; _} = let find_destrs destr destrs = - try let rep = Destructors.find destr destrs in + try let rep = MS.find destr destrs in Some rep with Not_found -> None in @@ -407,45 +312,47 @@ module SmtlibCounterExample = struct ) lbs in let destrs = - try Records.find (Sy.to_string record_name) !records - with Not_found -> Destructors.empty + try MS.find (Sy.to_string record_name) records + with Not_found -> MS.empty in asprintf "%s %a" (Hstring.view cstr) print_destr (destrs,lbs) - let add_record_constr record_name + let add_record_constr records record_name { Ty.name = _n; record_constr = _cstr; lbs = lbs; _} xs_values = - List.iter2 (fun (destr,_) (rep,_) -> + List.fold_left2(fun records (destr,_) (rep,_) -> add_records_destr + records record_name (Hstring.view destr) (asprintf "%a" pp_term rep) - ) lbs xs_values + ) records lbs xs_values - let check_records xs_ty_named xs_values f ty rep = + let check_records records xs_ty_named xs_values f ty rep = match xs_ty_named with | [Ty.Trecord _r, _arg] -> begin match xs_values with | [record_name,_] -> add_records_destr + records (asprintf "%a" Expr.print record_name) (Sy.to_string f) rep - | [] | _ -> () + | [] | _ -> records end | _ -> match ty with | Ty.Trecord r -> - add_record_constr rep r xs_values - | _ -> () + add_record_constr records rep r xs_values + | _ -> records let print_fun_def fmt name args ty t = let print_args fmt (ty,name) = Format.fprintf fmt "(%s %a)" name Ty.print ty in let defined_value = try - fst (Sorts.find (Sy.to_string name) !constraints) + fst (MS.find (Sy.to_string name) !constraints) with _ -> t in @@ -456,7 +363,7 @@ module SmtlibCounterExample = struct Ty.print ty defined_value - let output_constants_counterexample fmt cprofs = + let output_constants_counterexample fmt records cprofs = Profile.iter (fun (f, xs_ty, ty) st -> assert (xs_ty == []); @@ -466,7 +373,7 @@ module SmtlibCounterExample = struct let rep = match ty with | Ty.Trecord r -> - let constr = mk_records_constr f r in + let constr = mk_records_constr records f r in sprintf "(%s)" constr | _ -> rep in @@ -475,9 +382,8 @@ module SmtlibCounterExample = struct | _ -> assert false ) cprofs - module Rep = Map.Make(String) - - let output_functions_counterexample fmt fprofs = + let output_functions_counterexample fmt records fprofs = + let records = ref records in Profile.iter (fun (f, xs_ty, ty) st -> let xs_ty_named = List.mapi (fun i ty -> @@ -488,12 +394,12 @@ module SmtlibCounterExample = struct let representants = Profile.V.fold (fun (xs_values,(_rep,srep)) acc -> assert ((List.length xs_ty_named) = (List.length xs_values)); - check_records xs_ty_named xs_values f ty srep; - let reps = try Rep.find srep acc with Not_found -> [] in - Rep.add srep (xs_values :: reps) acc - ) st Rep.empty in + records := check_records !records xs_ty_named xs_values f ty srep; + let reps = try MS.find srep acc with Not_found -> [] in + MS.add srep (xs_values :: reps) acc + ) st MS.empty in - let representants = Rep.fold (fun srep xs_values_list acc -> + let representants = MS.fold (fun srep xs_values_list acc -> (srep,xs_values_list) :: acc) representants [] in let rec mk_ite_and xs tys = @@ -545,7 +451,8 @@ module SmtlibCounterExample = struct reps_aux representants in print_fun_def fmt f xs_ty_named ty rep; - ) fprofs + ) fprofs; + !records let output_arrays_counterexample fmt _arrays = fprintf fmt "@ ; Arrays not yet supported@ " @@ -560,7 +467,7 @@ module Why3CounterExample = struct (asprintf "%s(assert %a)@ " acc SmtlibCounterExample.pp_term e) ) prop_model "" in Printer.print_fmt ~flushed:false fmt "@ ; constants@ "; - Sorts.iter (fun _ (name,ty) -> + MS.iter (fun _ (name,ty) -> Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty ) !constraints; Printer.print_fmt ~flushed:false fmt "@ ; assertions@ "; @@ -570,11 +477,7 @@ end (* of module Why3CounterExample *) let output_concrete_model fmt props functions constants arrays = - if get_interpretation () then - if - Options.get_output_format () == Why3 || - Options.get_output_format () == Smtlib2 then begin - + if get_interpretation () then begin Printer.print_fmt ~flushed:false fmt "@[unknown@ "; Printer.print_fmt ~flushed:false fmt "@[(model@,"; if Options.get_output_format () == Why3 then begin @@ -582,23 +485,14 @@ let output_concrete_model fmt props functions constants arrays = end; fprintf fmt "@ ; Functions@ "; - SmtlibCounterExample.output_functions_counterexample fmt functions; + let records = SmtlibCounterExample.output_functions_counterexample + fmt MS.empty functions in + fprintf fmt "@ ; Constants@ "; - SmtlibCounterExample.output_constants_counterexample fmt constants; + SmtlibCounterExample.output_constants_counterexample + fmt records constants; SmtlibCounterExample.output_arrays_counterexample fmt arrays; Printer.print_fmt fmt "@]@ )"; - end - else if Options.get_output_format () == Native then begin - Printer.print_fmt ~flushed:false fmt "@[(@ "; - Printer.print_fmt ~flushed:false fmt "Constants@ "; - AECounterExample.output_constants_counterexample fmt constants; - Printer.print_fmt ~flushed:false fmt "@ Functions@ "; - AECounterExample.output_functions_counterexample fmt functions; - Printer.print_fmt ~flushed:false fmt "@ Arrays@ "; - AECounterExample.output_arrays_counterexample fmt arrays; - Printer.print_fmt fmt "@])"; - end - else - Printer.print_fmt fmt "Output format not recognised" + end; diff --git a/src/lib/frontend/models.mli b/src/lib/frontend/models.mli index 5b8a6f99a..0a887392b 100644 --- a/src/lib/frontend/models.mli +++ b/src/lib/frontend/models.mli @@ -11,8 +11,6 @@ (** {1 Models module} *) -module Sorts : Map.S with type key = string - module Profile : sig module P : Map.S with type key = From ebba0929b3dbcadc9e16e7421ab307fe6f8dc7bd Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 8 Jan 2021 18:42:08 +0100 Subject: [PATCH 49/68] Move profile module from Models module to structures --- src/lib/dune | 2 +- src/lib/frontend/frontend.ml | 2 +- src/lib/frontend/models.ml | 91 ++++++---------------------------- src/lib/frontend/models.mli | 15 ------ src/lib/reasoners/uf.ml | 8 +-- src/lib/structures/profile.ml | 75 ++++++++++++++++++++++++++++ src/lib/structures/profile.mli | 28 +++++++++++ 7 files changed, 125 insertions(+), 96 deletions(-) create mode 100644 src/lib/structures/profile.ml create mode 100644 src/lib/structures/profile.mli diff --git a/src/lib/dune b/src/lib/dune index 8b0f1d2c3..7473851db 100644 --- a/src/lib/dune +++ b/src/lib/dune @@ -39,7 +39,7 @@ ; structures Commands Errors Explanation Fpa_rounding Parsed Profiling Satml_types Symbols - Expr Var Ty Typed Xliteral + Expr Var Ty Typed Xliteral Profile ; util Config Emap Gc_debug Hconsing Hstring Iheap Lists Loc MyDynlink MyUnix Numbers NumsNumbers NumbersInterface diff --git a/src/lib/frontend/frontend.ml b/src/lib/frontend/frontend.ml index 8302ca05f..87451808f 100644 --- a/src/lib/frontend/frontend.ml +++ b/src/lib/frontend/frontend.ml @@ -320,7 +320,7 @@ module Make(SAT : Sat_solver_sig.S) : S with type sat_env = SAT.t = struct (Some loc) (Some time) (Some steps) (get_goal_name d); | Timeout None -> - if Options.get_interpretation () then + if Options.get_interpretation () then Printer.print_wrn "Timeout" else Printer.print_status_timeout ~validity_mode diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index cd72be0d4..6b0459f8b 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -23,66 +23,6 @@ module ME = Expr.Map module SE = Expr.Set module MS = Map.Make(String) -module Profile = struct - - module P = Map.Make - (struct - type t = Sy.t * Ty.t list * Ty.t - - let (|||) c1 c2 = if c1 <> 0 then c1 else c2 - - let compare (a1, b1, c1) (a2, b2, c2) = - let l1_l2 = List.length b1 - List.length b2 in - let c = l1_l2 ||| (Ty.compare c1 c2) ||| (Sy.compare a1 a2) in - if c <> 0 then c - else - let c = ref 0 in - try - List.iter2 - (fun ty1 ty2 -> - let d = Ty.compare ty1 ty2 in - if d <> 0 then begin c := d; raise Exit end - ) b1 b2; - 0 - with - | Exit -> assert (!c <> 0); !c - | Invalid_argument _ -> assert false - end) - - module V = Set.Make - (struct - type t = (E.t * (X.r * string)) list * (X.r * string) - let compare (l1, (v1,_)) (l2, (v2,_)) = - let c = X.hash_cmp v1 v2 in - if c <> 0 then c - else - let c = ref 0 in - try - List.iter2 - (fun (_,(x,_)) (_,(y,_)) -> - let d = X.hash_cmp x y in - if d <> 0 then begin c := d; raise Exit end - ) l1 l2; - !c - with - | Exit -> !c - | Invalid_argument _ -> List.length l1 - List.length l2 - end) - - let add p v mp = - let prof_p = try P.find p mp with Not_found -> V.empty in - if V.mem v prof_p then mp - else P.add p (V.add v prof_p) mp - - let iter = P.iter - - let fold = P.fold - - let empty = P.empty - - let is_empty = P.is_empty -end - let constraints = ref MS.empty module Pp_smtlib_term = struct @@ -394,7 +334,8 @@ module SmtlibCounterExample = struct let representants = Profile.V.fold (fun (xs_values,(_rep,srep)) acc -> assert ((List.length xs_ty_named) = (List.length xs_values)); - records := check_records !records xs_ty_named xs_values f ty srep; + records := + check_records !records xs_ty_named xs_values f ty srep; let reps = try MS.find srep acc with Not_found -> [] in MS.add srep (xs_values :: reps) acc ) st MS.empty in @@ -478,21 +419,21 @@ end let output_concrete_model fmt props functions constants arrays = if get_interpretation () then begin - Printer.print_fmt ~flushed:false fmt "@[unknown@ "; - Printer.print_fmt ~flushed:false fmt "@[(model@,"; - if Options.get_output_format () == Why3 then begin - Why3CounterExample.output_constraints fmt props - end; + Printer.print_fmt ~flushed:false fmt "@[unknown@ "; + Printer.print_fmt ~flushed:false fmt "@[(model@,"; + if Options.get_output_format () == Why3 then begin + Why3CounterExample.output_constraints fmt props + end; - fprintf fmt "@ ; Functions@ "; - let records = SmtlibCounterExample.output_functions_counterexample - fmt MS.empty functions in + fprintf fmt "@ ; Functions@ "; + let records = SmtlibCounterExample.output_functions_counterexample + fmt MS.empty functions in - fprintf fmt "@ ; Constants@ "; - SmtlibCounterExample.output_constants_counterexample - fmt records constants; + fprintf fmt "@ ; Constants@ "; + SmtlibCounterExample.output_constants_counterexample + fmt records constants; - SmtlibCounterExample.output_arrays_counterexample fmt arrays; + SmtlibCounterExample.output_arrays_counterexample fmt arrays; - Printer.print_fmt fmt "@]@ )"; - end; + Printer.print_fmt fmt "@]@ )"; + end; diff --git a/src/lib/frontend/models.mli b/src/lib/frontend/models.mli index 0a887392b..9d94358a2 100644 --- a/src/lib/frontend/models.mli +++ b/src/lib/frontend/models.mli @@ -11,21 +11,6 @@ (** {1 Models module} *) -module Profile : sig - - module P : Map.S with type key = - Symbols.t * Ty.t list * Ty.t - module V : Set.S with type elt = - (Expr.t * (Shostak.Combine.r * string)) list * - (Shostak.Combine.r * string) - - val add : P.key -> V.elt -> V.t P.t -> V.t P.t - val iter : (P.key -> 'a -> unit) -> 'a P.t -> unit - val fold : (P.key -> 'a -> 'b -> 'b) -> 'a P.t -> 'b -> 'b - val empty : 'a P.t - val is_empty : 'a P.t -> bool -end - (** Print the given counterexample on the given formatter with the corresponding format setted with Options.get_output_format *) val output_concrete_model : diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index 99378f55a..a4a902a6e 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1066,7 +1066,7 @@ let compute_concrete_model ({ make; _ } as env) = assert (xs_ta == []); fprofs, cprofs, - Models.Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, + Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, mrepr | _ -> assert false @@ -1074,14 +1074,14 @@ let compute_concrete_model ({ make; _ } as env) = | _ -> if tys == [] then - fprofs, Models.Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, + fprofs, Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, mrepr else - Models.Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, + Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, mrepr ) make - (Models.Profile.empty, Models.Profile.empty, Models.Profile.empty, ME.empty) + (Profile.empty, Profile.empty, Profile.empty, ME.empty) let output_concrete_model fmt ~prop_model env = if get_interpretation () then diff --git a/src/lib/structures/profile.ml b/src/lib/structures/profile.ml new file mode 100644 index 000000000..23a669c61 --- /dev/null +++ b/src/lib/structures/profile.ml @@ -0,0 +1,75 @@ +(******************************************************************************) +(* *) +(* Alt-Ergo: The SMT Solver For Software Verification *) +(* Copyright (C) 2018-2020 --- OCamlPro SAS *) +(* *) +(* This file is distributed under the terms of the license indicated *) +(* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) +(* present, please contact us to clarify licensing. *) +(* *) +(******************************************************************************) + +open Options + +module X = Shostak.Combine + +module Sy = Symbols +module E = Expr + + +module P = Map.Make + (struct + type t = Sy.t * Ty.t list * Ty.t + + let (|||) c1 c2 = if c1 <> 0 then c1 else c2 + + let compare (a1, b1, c1) (a2, b2, c2) = + let l1_l2 = List.length b1 - List.length b2 in + let c = l1_l2 ||| (Ty.compare c1 c2) ||| (Sy.compare a1 a2) in + if c <> 0 then c + else + let c = ref 0 in + try + List.iter2 + (fun ty1 ty2 -> + let d = Ty.compare ty1 ty2 in + if d <> 0 then begin c := d; raise Exit end + ) b1 b2; + 0 + with + | Exit -> assert (!c <> 0); !c + | Invalid_argument _ -> assert false + end) + +module V = Set.Make + (struct + type t = (E.t * (X.r * string)) list * (X.r * string) + let compare (l1, (v1,_)) (l2, (v2,_)) = + let c = X.hash_cmp v1 v2 in + if c <> 0 then c + else + let c = ref 0 in + try + List.iter2 + (fun (_,(x,_)) (_,(y,_)) -> + let d = X.hash_cmp x y in + if d <> 0 then begin c := d; raise Exit end + ) l1 l2; + !c + with + | Exit -> !c + | Invalid_argument _ -> List.length l1 - List.length l2 + end) + +let add p v mp = + let prof_p = try P.find p mp with Not_found -> V.empty in + if V.mem v prof_p then mp + else P.add p (V.add v prof_p) mp + +let iter = P.iter + +let fold = P.fold + +let empty = P.empty + +let is_empty = P.is_empty diff --git a/src/lib/structures/profile.mli b/src/lib/structures/profile.mli new file mode 100644 index 000000000..b19aa3014 --- /dev/null +++ b/src/lib/structures/profile.mli @@ -0,0 +1,28 @@ +(******************************************************************************) +(* *) +(* Alt-Ergo: The SMT Solver For Software Verification *) +(* Copyright (C) 2020-2020 --- OCamlPro SAS *) +(* *) +(* This file is distributed under the terms of the license indicated *) +(* in the file 'License.OCamlPro'. If 'License.OCamlPro' is not *) +(* present, please contact us to clarify licensing. *) +(* *) +(******************************************************************************) + +module P : Map.S with type key = + Symbols.t * Ty.t list * Ty.t + +module V : Set.S with type elt = + (Expr.t * (Shostak.Combine.r * string)) list * + (Shostak.Combine.r * string) + + +val add : P.key -> V.elt -> V.t P.t -> V.t P.t + +val iter : (P.key -> 'a -> unit) -> 'a P.t -> unit + +val fold : (P.key -> 'a -> 'b -> 'b) -> 'a P.t -> 'b -> 'b + +val empty : 'a P.t + +val is_empty : 'a P.t -> bool From 51a1394661c523c2702c97ea0da08e090a87a969 Mon Sep 17 00:00:00 2001 From: Albin Coquereau Date: Fri, 15 Jan 2021 15:36:03 +0100 Subject: [PATCH 50/68] Fix printing of constraints in why3 output when constraints are functions and not just constants --- src/lib/frontend/models.ml | 42 +++++++++++++++++++++++++----------- src/lib/reasoners/fun_sat.ml | 2 +- 2 files changed, 30 insertions(+), 14 deletions(-) diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index 6b0459f8b..05da3d4b5 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -171,16 +171,24 @@ module Pp_smtlib_term = struct | Sy.In(lb, rb), [t] -> fprintf fmt "(%a in %a, %a)" print t Sy.print_bound lb Sy.print_bound rb - | Sy.Name (n,_), _ -> begin - try - let constraint_name,_ty_name = - MS.find (Hstring.view n) !constraints in - fprintf fmt "%s" constraint_name - with _ -> - let constraint_name = "c_"^(Hstring.view n) in - constraints := MS.add (Hstring.view n) - (constraint_name,to_string_type (E.type_info t)) !constraints; - fprintf fmt "%s" constraint_name + | Sy.Name (n,_), l -> begin + let constraint_name = + try let constraint_name,_,_ = + (MS.find (Hstring.view n) !constraints) in + constraint_name + with _ -> + let constraint_name = "c_"^(Hstring.view n) in + constraints := MS.add (Hstring.view n) + (constraint_name, + to_string_type (E.type_info t), + List.map (fun e -> to_string_type (E.type_info e)) l + ) !constraints; + constraint_name + in + match l with + | [] -> fprintf fmt "%s" constraint_name + | l -> + fprintf fmt "(%s %a)" constraint_name (Printer.pp_list_space print) l; end | _, [] -> @@ -292,7 +300,7 @@ module SmtlibCounterExample = struct Format.fprintf fmt "(%s %a)" name Ty.print ty in let defined_value = try - fst (MS.find (Sy.to_string name) !constraints) + let res,_,_ = (MS.find (Sy.to_string name) !constraints) in res with _ -> t in @@ -408,8 +416,16 @@ module Why3CounterExample = struct (asprintf "%s(assert %a)@ " acc SmtlibCounterExample.pp_term e) ) prop_model "" in Printer.print_fmt ~flushed:false fmt "@ ; constants@ "; - MS.iter (fun _ (name,ty) -> - Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty + MS.iter (fun _ (name,ty,args_ty) -> + match args_ty with + | [] -> + Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " + name ty + | l -> + Printer.print_fmt ~flushed:false fmt "(declate-fun %s (%s) %s)@ " + name + (String.concat " " l) + ty ) !constraints; Printer.print_fmt ~flushed:false fmt "@ ; assertions@ "; Printer.print_fmt fmt ~flushed:false "%s" assertions diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index e5d8e6527..336a7b32f 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1370,7 +1370,7 @@ are not Th-reduced"; let env = do_case_split env Util.AfterMatching in if ok1 || ok2 || ok3 || ok4 then env else - return_answer env (get_last_interpretation ()) + return_answer env (get_last_interpretation ()) (fun e -> raise (I_dont_know e)) From 8fd568f773523ae7771f6b5e41a9f6b01db5805a Mon Sep 17 00:00:00 2001 From: Albin Coquereau <6535385+ACoquereau@users.noreply.github.com> Date: Tue, 9 Feb 2021 15:05:09 +0100 Subject: [PATCH 51/68] Fix declare-fun command in models --- src/lib/frontend/models.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index 05da3d4b5..c0a80e363 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -422,7 +422,7 @@ module Why3CounterExample = struct Printer.print_fmt ~flushed:false fmt "(declare-const %s %s)@ " name ty | l -> - Printer.print_fmt ~flushed:false fmt "(declate-fun %s (%s) %s)@ " + Printer.print_fmt ~flushed:false fmt "(declare-fun %s (%s) %s)@ " name (String.concat " " l) ty From 21438a65fd2ced4be9b99910481a8d447d176754 Mon Sep 17 00:00:00 2001 From: Albin Coquereau <6535385+ACoquereau@users.noreply.github.com> Date: Mon, 29 Mar 2021 09:51:14 +0200 Subject: [PATCH 52/68] Uses printer instead of format in models comments --- src/lib/frontend/models.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index c0a80e363..eb13dae58 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -404,7 +404,7 @@ module SmtlibCounterExample = struct !records let output_arrays_counterexample fmt _arrays = - fprintf fmt "@ ; Arrays not yet supported@ " + Printer.print_fmt fmt "@ ; Arrays not yet supported@ " end (* of module SmtlibCounterExample *) @@ -441,11 +441,11 @@ let output_concrete_model fmt props functions constants arrays = Why3CounterExample.output_constraints fmt props end; - fprintf fmt "@ ; Functions@ "; + Printer.print_fmt fmt "@ ; Functions@ "; let records = SmtlibCounterExample.output_functions_counterexample fmt MS.empty functions in - fprintf fmt "@ ; Constants@ "; + Printer.print_fmt fmt "@ ; Constants@ "; SmtlibCounterExample.output_constants_counterexample fmt records constants; From 5dba7a0a9acf139185f657561834eaec723e4076 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Wed, 19 May 2021 10:58:40 +0200 Subject: [PATCH 53/68] Better command line arguments --- src/bin/common/parse_command.ml | 36 +++++++++++++++++++++++++++++++-- src/lib/frontend/models.ml | 2 +- src/lib/util/options.ml | 9 +++++++-- src/lib/util/options.mli | 18 ++++++++++++++++- 4 files changed, 59 insertions(+), 6 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 1b18a4fcc..198f38d6d 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -89,6 +89,22 @@ let format_printer fmt format = let format_conv = Arg.conv ~docv:"FMT" (format_parser, format_printer) +let model_type_parser = function + | "value" -> Ok Value + | "constraints" -> Ok Constraints + | s -> + Error (`Msg (Format.sprintf + "The model kind %s is invalid. Only \"value\" and \ + \"constraints\" are allowed" s)) + +let model_type_printer fmt format = + Format.fprintf fmt "%s" + (match format with + | Value -> "value" + | Constraints -> "constaints") + +let model_type_conv = Arg.conv ~docv:"MTYP" (model_type_parser, model_type_printer) + type formatter = Stdout | Stderr | Other of string let value_of_fmt = function @@ -288,17 +304,22 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() -let mk_output_opt interpretation use_underscore unsat_core output_format +let mk_output_opt interpretation use_underscore unsat_core output_format model_type = set_infer_output_format output_format; let output_format = match output_format with | None -> Native | Some fmt -> fmt in + let model_type = match model_type with + | None -> Value + | Some v -> v + in set_interpretation interpretation; set_interpretation_use_underscore use_underscore; set_unsat_core unsat_core; set_output_format output_format; + set_model_type model_type; `Ok() let mk_profiling_opt cumulative_time_profiling profiling @@ -941,9 +962,20 @@ let parse_output_opt = Arg.(value & opt (some format_conv) None & info ["o"; "output"] ~docv ~doc) in + let model_type = + let doc = + Format.sprintf + "Control the output model type of the solver, $(docv) must be %s." + (Arg.doc_alts [ "value"; "constraint" ]) + in + let docv = "MTYP" in + Arg.(value & opt (some model_type_conv) None & info ["mt"; "model-type"] ~docv ~doc) + in + + Term.(ret (const mk_output_opt $ interpretation $ use_underscore $ unsat_core $ - output_format + output_format $ model_type )) let parse_profiling_opt = diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index eb13dae58..81531223a 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -437,7 +437,7 @@ let output_concrete_model fmt props functions constants arrays = if get_interpretation () then begin Printer.print_fmt ~flushed:false fmt "@[unknown@ "; Printer.print_fmt ~flushed:false fmt "@[(model@,"; - if Options.get_output_format () == Why3 then begin + if Options.get_model_type_constraints () then begin Why3CounterExample.output_constraints fmt props end; diff --git a/src/lib/util/options.ml b/src/lib/util/options.ml index 708fbab9a..a596c00c4 100644 --- a/src/lib/util/options.ml +++ b/src/lib/util/options.ml @@ -67,6 +67,8 @@ type interpretation = INone | IFirst | IEvery | ILast type input_format = Native | Smtlib2 | Why3 (* | SZS *) | Unknown of string type output_format = input_format +type model_type = Value | Constraints + let match_extension e = match e with | ".ae" -> Native @@ -299,12 +301,14 @@ let get_timelimit_per_goal () = !timelimit_per_goal let interpretation = ref INone let interpretation_use_underscore = ref false let output_format = ref Native +let model_type = ref Value let infer_output_format = ref true let unsat_core = ref false let set_interpretation b = interpretation := b let set_interpretation_use_underscore b = interpretation_use_underscore := b let set_output_format b = output_format := b +let set_model_type t = model_type := t let set_infer_output_format f = infer_output_format := f = None let set_unsat_core b = unsat_core := b @@ -314,8 +318,9 @@ let get_every_interpretation () = !interpretation = IEvery let get_last_interpretation () = !interpretation = ILast let get_interpretation_use_underscore () = !interpretation_use_underscore let get_output_format () = !output_format -let get_output_smtlib () = - (!output_format = Smtlib2) || (!output_format = Why3) +let get_output_smtlib () = !output_format = Smtlib2 +let get_model_type () = !model_type +let get_model_type_constraints () = !model_type = Constraints let get_infer_output_format () = !infer_output_format let get_unsat_core () = !unsat_core || !save_used_context || !debug_unsat_core diff --git a/src/lib/util/options.mli b/src/lib/util/options.mli index f89ba4a97..bc3444f5a 100644 --- a/src/lib/util/options.mli +++ b/src/lib/util/options.mli @@ -68,6 +68,8 @@ type input_format = (* | SZS * Not yet implemented SZS format *) | Unknown of string (** Unknown file format *) +type model_type = Value | Constraints + (** Type used to describe the type of output wanted by {!val:set_output_format} *) type output_format = input_format @@ -236,6 +238,9 @@ val set_normalize_instances : bool -> unit (** Set [output_format] accessible with {!val:get_output_format} *) val set_output_format : output_format -> unit +(** Set [model_type] accessible with {!val:get_model_type} *) +val set_model_type : model_type -> unit + (** Set [parse_only] accessible with {!val:get_parse_only} *) val set_parse_only : bool -> unit @@ -722,10 +727,21 @@ val get_interpretation_use_underscore : unit -> bool val get_output_format : unit -> output_format (** Default to [Native] *) -(** True if the output format is set to smtlib2 or why3 *) +(** [true] if the output format is set to smtlib2 or why3 *) val get_output_smtlib : unit -> bool (** Default to [false] *) +(** Value specifying the default model type. possible values are + {ul {- value} {- constraints}} + . *) +val get_model_type : unit -> model_type +(** Default to [Value] *) + +(** [true] if the model kind is set to constraints + . *) +val get_model_type_constraints : unit -> bool +(** Default to [false] *) + (** [true] if Alt-Ergo infers automatically the output format according to the the file extension or the input format if set. *) val get_infer_output_format : unit -> bool From 0e54017e0bd78e170ac5f120bf8c432a28223a2e Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Wed, 19 May 2021 11:03:59 +0200 Subject: [PATCH 54/68] Style fix --- src/bin/common/parse_command.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 198f38d6d..ef8b96717 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -103,7 +103,8 @@ let model_type_printer fmt format = | Value -> "value" | Constraints -> "constaints") -let model_type_conv = Arg.conv ~docv:"MTYP" (model_type_parser, model_type_printer) +let model_type_conv = + Arg.conv ~docv:"MTYP" (model_type_parser, model_type_printer) type formatter = Stdout | Stderr | Other of string @@ -304,7 +305,8 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() -let mk_output_opt interpretation use_underscore unsat_core output_format model_type +let mk_output_opt + interpretation use_underscore unsat_core output_format model_type = set_infer_output_format output_format; let output_format = match output_format with @@ -969,7 +971,11 @@ let parse_output_opt = (Arg.doc_alts [ "value"; "constraint" ]) in let docv = "MTYP" in - Arg.(value & opt (some model_type_conv) None & info ["mt"; "model-type"] ~docv ~doc) + Arg.( + value & + opt (some model_type_conv) None & + info ["mt"; "model-type"] ~docv ~doc + ) in From 771152db14d6fe0bd09a22d8296a16502c58f1d8 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Fri, 14 Oct 2022 13:14:29 +0200 Subject: [PATCH 55/68] Adding simple model option --- src/bin/common/parse_command.ml | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index ef8b96717..154cb101e 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -462,7 +462,7 @@ let halt_opt version_info where = with Failure f -> `Error (false, f) | Error (b, m) -> `Error (b, m) -let mk_opts file () () () () () () halt_opt (gc) () () () () () () () () +let mk_opts file () () () () () () halt_opt (gc) () () () () () () () () () = if halt_opt then `Ok false @@ -493,6 +493,14 @@ let mk_fmt_opt std_fmt err_fmt mdl_fmt set_fmt_mdl (value_of_fmt mdl_fmt); `Ok() +let mk_models_opt b = + if b then begin + set_interpretation IEvery; + set_instantiation_heuristic INormal; + set_sat_solver Tableaux + end; + `Ok () + (* Custom sections *) let s_debug = "DEBUG OPTIONS" @@ -509,6 +517,8 @@ let s_sat = "SAT OPTIONS" let s_term = "TERM OPTIONS" let s_theory = "THEORY OPTIONS" let s_fmt = "FORMATTER OPTIONS" +let s_models = "MODEL OPTIONS" + (* Parsers *) @@ -1294,6 +1304,18 @@ let parse_fmt_opt = std_formatter $ err_formatter $ mdl_formatter )) +let parse_models_opt = + let docs = s_models in + + let mdls = + let doc = + "Activates the models in alt-ergo. This is achieved by acitvating \ + some parameters: interpretation = every; instanciation heuristic = normal; \ + sat-solver = tableaux" + in + Arg.(value & flag & info ~doc ~docs ["models"]) + in Term.(ret (const mk_models_opt $ mdls)) + let main = let file = @@ -1329,6 +1351,7 @@ let main = `S s_case_split; `S s_halt; `S s_fmt; + `S s_models; `S s_debug; `P "These options are used to output debug info for the concerned \ part of the solver.\ @@ -1361,7 +1384,7 @@ let main = parse_execution_opt $ parse_halt_opt $ parse_internal_opt $ parse_limit_opt $ parse_output_opt $ parse_profiling_opt $ parse_quantifiers_opt $ parse_sat_opt $ parse_term_opt $ - parse_theory_opt $ parse_fmt_opt + parse_theory_opt $ parse_fmt_opt $ parse_models_opt )) in let info = From a5e47c6eac4472f4c8c3ab8030d64ee3a0afcf43 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Fri, 14 Oct 2022 13:54:08 +0200 Subject: [PATCH 56/68] Rebase artifacts --- src/bin/common/parse_command.ml | 5 ----- src/bin/gui/main_gui.ml | 18 +++++++----------- 2 files changed, 7 insertions(+), 16 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 154cb101e..e2b191151 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -1392,11 +1392,6 @@ let main = in Cmd.v info term - -let auto_set_implied_options () = - if Options.get_interpretation () then - Options.set_fm_cross_limit Numbers.Q.m_one - let parse_cmdline_arguments () = let r = Cmd.eval_value main in match r with diff --git a/src/bin/gui/main_gui.ml b/src/bin/gui/main_gui.ml index d581abf8d..812cb044e 100644 --- a/src/bin/gui/main_gui.ml +++ b/src/bin/gui/main_gui.ml @@ -194,7 +194,6 @@ let show_about () = let pop_error ?(error=false) ~message () = let pop_w = GWindow.dialog ~title:(if error then "Error" else "Warning") - ~allow_grow:true ~position:`CENTER ~width:400 () in @@ -236,8 +235,8 @@ let pop_model sat_env () = ~wrap_mode:`CHAR () in let _ = tv1#misc#modify_font font in let _ = tv1#set_editable false in - let model_text = asprintf "%a@." (SAT.print_model ~header:false) sat_env in - buf1#set_text model_text; + (* let model_text = asprintf "%a@." (SAT.print_model ~header:false) sat_env in + * buf1#set_text model_text; *) pop_w#show () @@ -832,9 +831,6 @@ let goto_lemma (view:GTree.view) inst_model buffer env.last_tag <- t; with Not_found -> () - -let colormap () = Gdk.Color.get_system_colormap () - let set_color_inst inst_model renderer (istore:GTree.model) row = let id = istore#get ~row ~column:inst_model.icol_tag in let _, nb_inst, _, limit = Hashtbl.find inst_model.h id in @@ -988,8 +984,8 @@ let start_gui all_used_context = let w = GWindow.window ~title:"AltGr-Ergo" - ~allow_grow:true - ~allow_shrink:true + (* ~allow_grow:true *) + (* ~allow_shrink:true *) ~position:`CENTER ~width:window_width ~height:window_height () @@ -1385,9 +1381,9 @@ let start_gui all_used_context = [ `C ("Unsat cores", get_unsat_core (), set_unsat_core); (*`S;*) - `C ("Model", get_model (), set_model); - `C ("Complete model", get_complete_model (), set_complete_model); - `C ("All models", get_all_models (), set_all_models); + (* `C ("Model", get_model (), set_model); + * `C ("Complete model", get_complete_model (), set_complete_model); + * `C ("All models", get_all_models (), set_all_models); *) (*`S;*) `C ("Variables in triggers", get_triggers_var (), set_triggers_var); `C ("Greedy", get_greedy (), set_greedy); From d26d938f4e2ec5072eb216d7031c24a012e9c59b Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Fri, 14 Oct 2022 15:21:26 +0200 Subject: [PATCH 57/68] Putting model option in the right option list --- src/bin/common/parse_command.ml | 48 ++++++++++++++++----------------- 1 file changed, 23 insertions(+), 25 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index e2b191151..08d8fdc54 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -305,9 +305,20 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() + + +let mk_models_opt b = + if b then begin + set_interpretation IEvery; + set_instantiation_heuristic INormal; + set_sat_solver Tableaux + end; + `Ok () + let mk_output_opt - interpretation use_underscore unsat_core output_format model_type + interpretation use_underscore unsat_core output_format model_type models = + let `Ok () = mk_models_opt models in set_infer_output_format output_format; let output_format = match output_format with | None -> Native @@ -462,7 +473,7 @@ let halt_opt version_info where = with Failure f -> `Error (false, f) | Error (b, m) -> `Error (b, m) -let mk_opts file () () () () () () halt_opt (gc) () () () () () () () () () +let mk_opts file () () () () () () halt_opt (gc) () () () () () () () () = if halt_opt then `Ok false @@ -493,14 +504,6 @@ let mk_fmt_opt std_fmt err_fmt mdl_fmt set_fmt_mdl (value_of_fmt mdl_fmt); `Ok() -let mk_models_opt b = - if b then begin - set_interpretation IEvery; - set_instantiation_heuristic INormal; - set_sat_solver Tableaux - end; - `Ok () - (* Custom sections *) let s_debug = "DEBUG OPTIONS" @@ -988,10 +991,17 @@ let parse_output_opt = ) in - + let mdls = + let doc = + "Simply activates the models in alt-ergo. This is achieved by setting \ + some parameters by default: interpretation = every; instanciation heuristic = normal; \ + sat-solver = tableaux" + in + Arg.(value & flag & info ~doc ~docs ["models"]) + in Term.(ret (const mk_output_opt $ interpretation $ use_underscore $ unsat_core $ - output_format $ model_type + output_format $ model_type $ mdls )) let parse_profiling_opt = @@ -1304,18 +1314,6 @@ let parse_fmt_opt = std_formatter $ err_formatter $ mdl_formatter )) -let parse_models_opt = - let docs = s_models in - - let mdls = - let doc = - "Activates the models in alt-ergo. This is achieved by acitvating \ - some parameters: interpretation = every; instanciation heuristic = normal; \ - sat-solver = tableaux" - in - Arg.(value & flag & info ~doc ~docs ["models"]) - in Term.(ret (const mk_models_opt $ mdls)) - let main = let file = @@ -1384,7 +1382,7 @@ let main = parse_execution_opt $ parse_halt_opt $ parse_internal_opt $ parse_limit_opt $ parse_output_opt $ parse_profiling_opt $ parse_quantifiers_opt $ parse_sat_opt $ parse_term_opt $ - parse_theory_opt $ parse_fmt_opt $ parse_models_opt + parse_theory_opt $ parse_fmt_opt )) in let info = From d83fabe07e4d1bc6865cfbcbbd56d08ed5da5b4e Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Fri, 14 Oct 2022 15:24:40 +0200 Subject: [PATCH 58/68] Poetry --- src/bin/js/worker_js.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/bin/js/worker_js.ml b/src/bin/js/worker_js.ml index 2283b2990..f75bc3374 100644 --- a/src/bin/js/worker_js.ml +++ b/src/bin/js/worker_js.ml @@ -124,7 +124,7 @@ let main worker_id content = begin match kind with | Typed.Check | Typed.Cut -> { state with local = []; } - | _ -> { state with global = []; local = []; } + | Typed.Thm | Typed.Sat -> { state with global = []; local = []; } end | Typed.TAxiom (_, s, _, _) when Typed.is_global_hyp s -> let cnf = Cnf.make state.global td in From e2d8c81cb054b6ee9ac128390efd519ea27254b2 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Tue, 18 Oct 2022 17:56:26 +0200 Subject: [PATCH 59/68] Fix parse command --- src/bin/common/parse_command.ml | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 08d8fdc54..2fbfc8da2 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -305,8 +305,6 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation set_timelimit_per_goal timelimit_per_goal; `Ok() - - let mk_models_opt b = if b then begin set_interpretation IEvery; @@ -328,7 +326,8 @@ let mk_output_opt | None -> Value | Some v -> v in - set_interpretation interpretation; + if not models && interpretation != INone + then set_interpretation interpretation; set_interpretation_use_underscore use_underscore; set_unsat_core unsat_core; set_output_format output_format; @@ -1174,14 +1173,16 @@ let parse_sat_opt = info ["sat-plugin"] ~docs ~doc) in let sat_solver = + let default, sum_up = "CDCL-Tableaux", "satML" in let doc = Format.sprintf - "Choose the SAT solver to use. Default value is CDCL (i.e. satML \ + "Choose the SAT solver to use. Default value is %s (i.e. %s\ solver). Possible options are %s." + default sum_up (Arg.doc_alts ["CDCL"; "satML"; "CDCL-Tableaux"; "satML-Tableaux"; "Tableaux-CDCL"]) in let docv = "SAT" in - Arg.(value & opt string "CDCL-Tableaux" & + Arg.(value & opt string default & info ["sat-solver"] ~docv ~docs ~doc) in Term.(ret (const mk_sat_opt $ @@ -1380,8 +1381,9 @@ let main = parse_case_split_opt $ parse_context_opt $ parse_dbg_opt_spl1 $ parse_dbg_opt_spl2 $ parse_dbg_opt_spl3 $ parse_execution_opt $ parse_halt_opt $ parse_internal_opt $ - parse_limit_opt $ parse_output_opt $ parse_profiling_opt $ - parse_quantifiers_opt $ parse_sat_opt $ parse_term_opt $ + parse_limit_opt $ parse_profiling_opt $ + parse_quantifiers_opt $ parse_sat_opt $ + parse_term_opt $ parse_output_opt $ parse_theory_opt $ parse_fmt_opt )) in From 4b11720105bd514506b082231bf63e291d28d83e Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Fri, 4 Nov 2022 11:26:32 +0100 Subject: [PATCH 60/68] Poetry --- src/bin/common/parse_command.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 2fbfc8da2..dfc603ab9 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -993,7 +993,8 @@ let parse_output_opt = let mdls = let doc = "Simply activates the models in alt-ergo. This is achieved by setting \ - some parameters by default: interpretation = every; instanciation heuristic = normal; \ + some parameters by default: interpretation = every; instanciation \ + heuristic = normal; \ sat-solver = tableaux" in Arg.(value & flag & info ~doc ~docs ["models"]) From 919b98cd9d98dd61de18414768c4fdd3799e418e Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Tue, 8 Nov 2022 14:43:07 +0100 Subject: [PATCH 61/68] Adding a proper exception for unsupported features and removing 'at_exit' instruction --- src/lib/reasoners/adt.ml | 4 +-- src/lib/reasoners/bitv.ml | 10 ++++-- src/lib/reasoners/fun_sat.ml | 64 ++++++++++++++++++++---------------- src/lib/util/util.ml | 10 ++++++ src/lib/util/util.mli | 1 + 5 files changed, 55 insertions(+), 34 deletions(-) diff --git a/src/lib/reasoners/adt.ml b/src/lib/reasoners/adt.ml index ea765949b..e2ca01a1f 100644 --- a/src/lib/reasoners/adt.ml +++ b/src/lib/reasoners/adt.ml @@ -418,11 +418,11 @@ module Shostak (X : ALIEN) = struct let assign_value _ _ _ = Printer.print_err "[ADTs.models] assign_value currently not implemented"; - assert false + raise (Util.Not_implemented "Models for ADTs") let choose_adequate_model _ _ _ = Printer.print_err "[ADTs.models] choose_adequate_model currently not implemented"; - assert false + raise (Util.Not_implemented "Models for ADTs") end diff --git a/src/lib/reasoners/bitv.ml b/src/lib/reasoners/bitv.ml index 8b5f42956..e77f1d231 100644 --- a/src/lib/reasoners/bitv.ml +++ b/src/lib/reasoners/bitv.ml @@ -799,10 +799,14 @@ module Shostak(X : ALIEN) = struct let solve r1 r2 pb = {pb with sbt = List.rev_append (solve_bis r1 r2) pb.sbt} - let assign_value _ __ = - failwith "[Bitv.assign_value] not implemented for theory Bitv" + let assign_value _ _ _ = + Printer.print_err + "[Bitv.models] assign_value currently not implemented"; + raise (Util.Not_implemented "Models for bit-vectors") let choose_adequate_model _ _ = - assert false + Printer.print_err + "[Bitv.models] choose_adequate_model currently not implemented"; + raise (Util.Not_implemented "Models for bit-vectors") end diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 336a7b32f..8bff00e08 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1185,18 +1185,21 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct You may need to change your model generation strategy@,\ or to increase your timeout.@]" | Some env -> + Printer.print_fmt (Options.get_fmt_mdl ()) + "@[[FunSat]@, \ + A model has been computed. However, I failed \ + while computing it so may be incorrect.@]"; let prop_model = extract_prop_model ~complete_model:true env in Th.output_concrete_model (get_fmt_mdl ()) ~prop_model env.tbox; end; return_function () - - let () = - at_exit - (fun () -> - if not !terminated_normally && (get_interpretation ()) then - return_cached_model (fun () -> ()) - ) + (* let () = + * at_exit + * (fun () -> + * if not !terminated_normally && (get_interpretation ()) then + * return_cached_model (fun () -> ()) + * ) *) let return_answer env compute return_function = @@ -1232,7 +1235,6 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct else return_cached_model (fun () -> raise Util.Timeout) - let reduce_hypotheses tcp_cache tmp_cache env acc (hyp, gf, dep) = Debug.print_theory_instance hyp gf; let dep, acc = @@ -1375,27 +1377,31 @@ are not Th-reduced"; let normal_instantiation env try_greedy = - Debug.print_nb_related env; - let env = do_case_split env Util.BeforeMatching in - let env = compute_concrete_model env (get_every_interpretation ()) in - let env = new_inst_level env in - let mconf = - {Util.nb_triggers = get_nb_triggers (); - no_ematching = get_no_ematching(); - triggers_var = get_triggers_var (); - use_cs = false; - backward = Util.Normal; - greedy = get_greedy (); - } - in - let env, ok1 = inst_and_assume mconf env inst_predicates env.inst in - let env, ok2 = inst_and_assume mconf env inst_lemmas env.inst in - let env, ok3 = syntactic_th_inst env env.inst ~rm_clauses:false in - let env, ok4 = semantic_th_inst env env.inst ~rm_clauses:false ~loop:4 in - let env = do_case_split env Util.AfterMatching in - if ok1 || ok2 || ok3 || ok4 then env - else if try_greedy then greedy_instantiation env else env - + try + Debug.print_nb_related env; + let env = do_case_split env Util.BeforeMatching in + let env = compute_concrete_model env (get_every_interpretation ()) in + let env = new_inst_level env in + let mconf = + {Util.nb_triggers = get_nb_triggers (); + no_ematching = get_no_ematching(); + triggers_var = get_triggers_var (); + use_cs = false; + backward = Util.Normal; + greedy = get_greedy (); + } + in + let env, ok1 = inst_and_assume mconf env inst_predicates env.inst in + let env, ok2 = inst_and_assume mconf env inst_lemmas env.inst in + let env, ok3 = syntactic_th_inst env env.inst ~rm_clauses:false in + let env, ok4 = semantic_th_inst env env.inst ~rm_clauses:false ~loop:4 in + let env = do_case_split env Util.AfterMatching in + if ok1 || ok2 || ok3 || ok4 then env + else if try_greedy then greedy_instantiation env else env + with | Util.Not_implemented s -> + Printer.print_err "Feature %s is not implemented. \ + I can't conclude." s; + raise (I_dont_know env) (* should be merged with do_bcp/red/elim ? calls to debug hooks are missing *) diff --git a/src/lib/util/util.ml b/src/lib/util/util.ml index 672173403..4ebd6b793 100644 --- a/src/lib/util/util.ml +++ b/src/lib/util/util.ml @@ -14,6 +14,16 @@ exception Unsolvable exception Cmp of int +exception Not_implemented of string + +let () = + Printexc.register_printer + (function + | Not_implemented s -> + Some (Format.sprintf "Feature not implemented (%s)" s) + | _ -> None + ) + module MI = Map.Make(struct type t = int let compare (x: int) y = Stdlib.compare x y end) diff --git a/src/lib/util/util.mli b/src/lib/util/util.mli index 65699b9b3..9adae698f 100644 --- a/src/lib/util/util.mli +++ b/src/lib/util/util.mli @@ -13,6 +13,7 @@ exception Timeout exception Unsolvable exception Cmp of int +exception Not_implemented of string module MI : Map.S with type key = int module SI : Set.S with type elt = int From dfdb6c7c8d4fbf74cdc004c7f4e1c29b892e3b20 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Thu, 10 Nov 2022 13:50:25 +0100 Subject: [PATCH 62/68] Adding doc & some poetry --- alt-ergo-lib.opam | 2 +- alt-ergo-parsers.opam | 2 +- alt-ergo.opam | 2 +- altgr-ergo.opam | 2 +- .../Input_file_formats/Native/00_summary.md | 7 +- .../Native/04_setting_goals.md | 43 +- docs/sphinx_docs/Usage/index.md | 16 + dune-project | 2 +- src/bin/common/parse_command.ml | 22 +- src/lib/frontend/models.ml | 2 +- src/lib/frontend/models.mli | 12 +- src/lib/reasoners/fun_sat.ml | 5 +- src/lib/reasoners/uf.ml | 2 +- src/lib/structures/expr.ml | 514 ++++++++++++------ src/lib/structures/profile.mli | 5 + 15 files changed, 430 insertions(+), 208 deletions(-) diff --git a/alt-ergo-lib.opam b/alt-ergo-lib.opam index ac75bcc3f..e90d5eced 100644 --- a/alt-ergo-lib.opam +++ b/alt-ergo-lib.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "models" +version: "dev" synopsis: "The Alt-Ergo SMT prover library" description: """ This is the core library used in the Alt-Ergo SMT solver. diff --git a/alt-ergo-parsers.opam b/alt-ergo-parsers.opam index 6a2237fde..295a78d12 100644 --- a/alt-ergo-parsers.opam +++ b/alt-ergo-parsers.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "models" +version: "dev" synopsis: "The Alt-Ergo SMT prover parser library" description: """ This is the parser library used in the Alt-Ergo SMT solver. diff --git a/alt-ergo.opam b/alt-ergo.opam index a7068ad5b..f32a4eb31 100644 --- a/alt-ergo.opam +++ b/alt-ergo.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "models" +version: "dev" synopsis: "The Alt-Ergo SMT prover" description: """ Alt-Ergo is an automatic theorem prover of mathematical formulas. It was developed at LRI, and is now maintained at OCamlPro. diff --git a/altgr-ergo.opam b/altgr-ergo.opam index 445412c70..6574ccd3b 100644 --- a/altgr-ergo.opam +++ b/altgr-ergo.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "models" +version: "dev" synopsis: "The GUI for the Alt-Ergo SMT prover" description: """ Altgr-Ergo is the graphical interface for the Alt-Ergo SMT prover. diff --git a/docs/sphinx_docs/Input_file_formats/Native/00_summary.md b/docs/sphinx_docs/Input_file_formats/Native/00_summary.md index 3f836ba1a..2c5c1f060 100644 --- a/docs/sphinx_docs/Input_file_formats/Native/00_summary.md +++ b/docs/sphinx_docs/Input_file_formats/Native/00_summary.md @@ -33,8 +33,9 @@ Reserved keywords are the following. The list of all reserved keywords, in alphabetical order, is: ``` -ac, and, axiom, bitv, bool, case_split, check, cut, distinct, else, end, exists, extends, -false, forall, function, goal, if, in, int, let, logic, not, xor, predicate, prop, -real, rewriting, then, theory, true, type, unit, void, match, with, of +ac, and, axiom, bitv, bool, case_split, check, check_sat, chevk_valid, cut, +distinct, else, end, exists, extends, false, forall, function, goal, if, in, +int, let, logic, not, xor, predicate, prop, real, rewriting, then, theory, +true, type, unit, void, match, with, of ``` Note that preludes (additional theories which may be loaded) may reserve more keywords. diff --git a/docs/sphinx_docs/Input_file_formats/Native/04_setting_goals.md b/docs/sphinx_docs/Input_file_formats/Native/04_setting_goals.md index bb0086e2d..8b7df9c5d 100644 --- a/docs/sphinx_docs/Input_file_formats/Native/04_setting_goals.md +++ b/docs/sphinx_docs/Input_file_formats/Native/04_setting_goals.md @@ -49,4 +49,45 @@ In other word, `cut` and `check` allow to test if intermediate goals can be prov ::= 'check' ::= 'cut' ``` - + +## `check_valid` + +This keyword is an alias for `goal`. + +## `check_sat` + +This keyword is used just like `goal` and `check_valid`, but it describes a property that alt-ergo will +try to prove invalid. This keywork has been introduced in the version 2.5.0 as a part of the model +instanciation, and in this version `alt-ergo` never returns `SAT`, but `unknown` instead. + +### Example + +test.ae +``` +logic x, y : int + +check_sat g: x = y +``` + +``` +$ alt-ergo test.ae --model + +unknown + +(model + + ; Functions + + ; Constants + +(define-fun x () int 0) + +(define-fun y () int 0) + + ; Arrays not yet supported + + +) +File "test.ae", line 3, characters 14-19: I don't know (0.0030) (2 steps) (goal g) + +``` \ No newline at end of file diff --git a/docs/sphinx_docs/Usage/index.md b/docs/sphinx_docs/Usage/index.md index 92382c0e2..a21e03b9b 100644 --- a/docs/sphinx_docs/Usage/index.md +++ b/docs/sphinx_docs/Usage/index.md @@ -26,6 +26,22 @@ Alt-Ergo supports file extensions: See the [Input section] for more information about the format of the input files +### Generating models +Since 2.5.0, Alt-Ergo also generates models in the case it concludes on the satisfiability of +the formula. +There is two ways to activate model generation: +- `with the --interpretation=VALUE`, where VALUE can be equal to: + * "none", and alt-ergo will not generate models (by default); + * "first", and alt-ergo will output the first model it finds; + * "every", alt alt-ergo will compute a model before each decision + * "last", and alt-ergo will output the last model it computes before returning 'unknown'. + Note that this mode only works with the option `--sat-solver tableaux`. + +- with the `--model option`, setting the interpretation option to 'last', and the sat-solver +to 'tableaux. + +The default model format is the SMT format. + ### Output The results of an Alt-ergo's execution have the following form : ``` diff --git a/dune-project b/dune-project index b4018f328..ecb144523 100644 --- a/dune-project +++ b/dune-project @@ -5,7 +5,7 @@ (generate_opam_files true) (name alt-ergo) -(version models) +(version dev) (authors "Alt-Ergo developers") (maintainers "Alt-Ergo developers") (source (github OCamlPro/alt-ergo)) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index dfc603ab9..a2348ab20 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -307,7 +307,7 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation let mk_models_opt b = if b then begin - set_interpretation IEvery; + set_interpretation ILast; set_instantiation_heuristic INormal; set_sat_solver Tableaux end; @@ -934,16 +934,16 @@ let parse_output_opt = let interpretation = let doc = Format.sprintf - "Experimental support for counter-example generation. \ + "Best effort support for counter-example generation. \ $(docv) must be %s. %s shows the first computed interpretation. \ %s compute an interpretation before every decision, \ - %s before every instantiation and %s only before returning unknown. \ + and %s only before returning unknown. \ Note that $(b, --max-split) limitation will \ be ignored in model generation phase." (Arg.doc_alts - ["none"; "first"; "before_dec"; "before_inst"; "before_end"]) - (Arg.doc_quote "first") (Arg.doc_quote "before_dec") - (Arg.doc_quote "before_inst") (Arg.doc_quote "before_end") in + ["none"; "first"; "every"; "last"]) + (Arg.doc_quote "first") (Arg.doc_quote "every") + (Arg.doc_quote "last") in let docv = "VAL" in Arg.(value & opt interpretation_conv INone & info ["interpretation"] ~docv ~docs ~doc) in @@ -993,11 +993,11 @@ let parse_output_opt = let mdls = let doc = "Simply activates the models in alt-ergo. This is achieved by setting \ - some parameters by default: interpretation = every; instanciation \ + some parameters by default: interpretation = last; instanciation \ heuristic = normal; \ sat-solver = tableaux" in - Arg.(value & flag & info ~doc ~docs ["models"]) + Arg.(value & flag & info ~doc ~docs ["model"]) in Term.(ret (const mk_output_opt $ interpretation $ use_underscore $ unsat_core $ @@ -1304,16 +1304,16 @@ let parse_fmt_opt = Arg.(value & opt formatter_conv Stderr & info ["err-formatter"] ~docs ~doc) in - let mdl_formatter = + let model_output = let doc = Format.sprintf "Set the model formatter used by default to output model and interpretation. Possible values are %s." (Arg.doc_alts ["stdout"; "stderr"; ""]) in - Arg.(value & opt formatter_conv Stdout & info ["mdl-formatter"] ~docs ~doc) + Arg.(value & opt formatter_conv Stdout & info ["model-output"] ~docs ~doc) in Term.(ret (const mk_fmt_opt $ - std_formatter $ err_formatter $ mdl_formatter + std_formatter $ err_formatter $ model_output )) let main = diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index 81531223a..266c201e2 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -433,7 +433,7 @@ module Why3CounterExample = struct end (* of module Why3CounterExample *) -let output_concrete_model fmt props functions constants arrays = +let output_concrete_model fmt props ~functions ~constants ~arrays = if get_interpretation () then begin Printer.print_fmt ~flushed:false fmt "@[unknown@ "; Printer.print_fmt ~flushed:false fmt "@[(model@,"; diff --git a/src/lib/frontend/models.mli b/src/lib/frontend/models.mli index 9d94358a2..b454e7003 100644 --- a/src/lib/frontend/models.mli +++ b/src/lib/frontend/models.mli @@ -12,11 +12,15 @@ (** {1 Models module} *) (** Print the given counterexample on the given formatter with the - corresponding format setted with Options.get_output_format *) + corresponding format set with Options.get_output_format. + - functions: the functions of the model; + - constants: the variables of the model; + - arrays: (experimental) the arrays of the model. +*) val output_concrete_model : Format.formatter -> Expr.Set.t -> - Profile.V.t Profile.P.t -> - Profile.V.t Profile.P.t -> - Profile.V.t Profile.P.t -> + functions:Profile.V.t Profile.P.t -> + constants:Profile.V.t Profile.P.t -> + arrays:Profile.V.t Profile.P.t -> unit diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 8bff00e08..625912f77 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1262,9 +1262,8 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct end | E.Unit _ | E.Clause _ | E.Lemma _ | E.Skolem _ | E.Let _ | E.Iff _ | E.Xor _ -> - Printer.print_err - "Currently, arbitrary formulas in Hyps -are not Th-reduced"; + Printer.print_err "Currently, arbitrary formulas in Hyps \ + are not Th-reduced"; assert false | E.Not_a_form -> assert false diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index a4a902a6e..8c2e9ce89 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1087,7 +1087,7 @@ let output_concrete_model fmt ~prop_model env = if get_interpretation () then let functions, constants, arrays, _ = compute_concrete_model env in - Models.output_concrete_model fmt prop_model functions constants arrays + Models.output_concrete_model fmt prop_model ~functions ~constants ~arrays let save_cache () = LX.save_cache () diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index f5cdca0ec..52ccdce7c 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -376,218 +376,374 @@ let print_binders = print_one fmt e; List.iter (fun e -> fprintf fmt ", %a" print_one e) l -let rec print_silent fmt t = - let { f ; xs ; ty; bind; _ } = t in - match f, xs with - (* Formulas *) - | Sy.Form form, xs -> - begin - match form, xs, bind with - | Sy.F_Unit _, [f1; f2], _ -> - fprintf fmt "@[(%a /\\@ %a)@]" print_silent f1 print_silent f2 - - | Sy.F_Iff, [f1; f2], _ -> - fprintf fmt "@[(%a <->@ %a)@]" print_silent f1 print_silent f2 - - | Sy.F_Xor, [f1; f2], _ -> - fprintf fmt "@[(%a xor@ %a)@]" print_silent f1 print_silent f2 - - | Sy.F_Clause _, [f1; f2], _ -> - fprintf fmt "@[(%a \\/@ %a)@]" print_silent f1 print_silent f2 - - | Sy.F_Lemma, [], B_lemma { user_trs ; main ; name ; binders; _ } -> - if get_verbose () then - fprintf fmt "(lemma: %s forall %a[%a].@ %a)" - name - print_binders binders - print_triggers user_trs - print_silent main - else - fprintf fmt "(lem %s)" name +(* let print_list_sep sep pp fmt = + * Format.pp_print_list ~pp_sep:(fun fmt _ -> Format.fprintf fmt sep) pp fmt + * + * let print_list pp fmt = print_list_sep "," pp fmt *) + +module SmtPrinter = struct + + let rec print_formula fmt form xs bind = + match form, xs, bind with + | Sy.F_Unit _, [f1; f2], _ -> + fprintf fmt "@[(%a /\\@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Iff, [f1; f2], _ -> + fprintf fmt "@[(%a <->@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Xor, [f1; f2], _ -> + fprintf fmt "@[(%a xor@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Clause _, [f1; f2], _ -> + fprintf fmt "@[(%a \\/@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Lemma, [], B_lemma { user_trs ; main ; name ; binders; _ } -> + if get_verbose () then + fprintf fmt "(lemma: %s forall %a[%a].@ %a)" + name + print_binders binders + print_triggers user_trs + print_silent main + else + fprintf fmt "(lem %s)" name - | Sy.F_Skolem, [], B_skolem { main; binders; _ } -> - fprintf fmt "( %a)" - print_binders binders print_silent main + | Sy.F_Skolem, [], B_skolem { main; binders; _ } -> + fprintf fmt "( %a)" + print_binders binders print_silent main - | _ -> assert false - end + | _ -> assert false - | Sy.Let, [] -> - let x = match bind with B_let x -> x | _ -> assert false in - fprintf fmt - "(let%a %a =@ %a in@ %a)" - (fun fmt x -> if Options.get_verbose () then - fprintf fmt - " [sko = %a]" print x.let_sko) x - Sy.print x.let_v print x.let_e print_silent x.in_e - - (* Literals *) - | Sy.Lit lit, xs -> - begin - match lit, xs with - | Sy.L_eq, a::l -> - if get_output_smtlib () then - fprintf fmt "(= %a%a)" - print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l - else - fprintf fmt "(%a%a)" - print a (fun fmt -> List.iter (fprintf fmt " = %a" print)) l + and print_lit fmt lit xs = + match lit, xs with + | Sy.L_eq, a::l -> + fprintf fmt "(= %a%a)" + print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l + | Sy.L_neg_eq, [a; b] -> + fprintf fmt "(not (= %a %a))" print a print b - | Sy.L_neg_eq, [a; b] -> - if get_output_smtlib () then - fprintf fmt "(not (= %a %a))" print a print b - else - fprintf fmt "(%a <> %a)" print a print b + | Sy.L_neg_eq, a::l -> + fprintf fmt "(distinct %a%a)" + print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l - | Sy.L_neg_eq, a::l -> - if get_output_smtlib () then - fprintf fmt "(distinct %a%a)" - print a (fun fmt -> List.iter (fprintf fmt " %a" print)) l - else - fprintf fmt "distinct(%a%a)" - print a (fun fmt -> List.iter (fprintf fmt ", %a" print)) l + | Sy.L_built Sy.LE, [a;b] -> + fprintf fmt "(<= %a %a)" print a print b - | Sy.L_built Sy.LE, [a;b] -> - if get_output_smtlib () then - fprintf fmt "(<= %a %a)" print a print b - else - fprintf fmt "(%a <= %a)" print a print b + | Sy.L_built Sy.LT, [a;b] -> + fprintf fmt "(< %a %a)" print a print b - | Sy.L_built Sy.LT, [a;b] -> - if get_output_smtlib () then - fprintf fmt "(< %a %a)" print a print b - else - fprintf fmt "(%a < %a)" print a print b + | Sy.L_neg_built Sy.LE, [a; b] -> + fprintf fmt "(> %a %a)" print a print b - | Sy.L_neg_built Sy.LE, [a; b] -> - if get_output_smtlib () then - fprintf fmt "(> %a %a)" print a print b - else - fprintf fmt "(%a > %a)" print a print b + | Sy.L_neg_built Sy.LT, [a; b] -> + fprintf fmt "(>= %a %a)" print a print b - | Sy.L_neg_built Sy.LT, [a; b] -> - if get_output_smtlib () then - fprintf fmt "(>= %a %a)" print a print b - else - fprintf fmt "(%a >= %a)" print a print b + | Sy.L_neg_pred, [a] -> + fprintf fmt "(not %a)" print a - | Sy.L_neg_pred, [a] -> - fprintf fmt "(not %a)" print a + | Sy.L_built (Sy.IsConstr hs), [e] -> + fprintf fmt "((_ is %a) %a)" Hstring.print hs print e - | Sy.L_built (Sy.IsConstr hs), [e] -> - if get_output_smtlib () then - fprintf fmt "((_ is %a) %a)" Hstring.print hs print e - else - fprintf fmt "(%a ? %a)" print e Hstring.print hs + | Sy.L_neg_built (Sy.IsConstr hs), [e] -> + fprintf fmt "(not ((_ is %a) %a))" Hstring.print hs print e - | Sy.L_neg_built (Sy.IsConstr hs), [e] -> - if get_output_smtlib () then - fprintf fmt "(not ((_ is %a) %a))" Hstring.print hs print e - else - fprintf fmt "not (%a ? %a)" print e Hstring.print hs + | (Sy.L_built (Sy.LT | Sy.LE) | Sy.L_neg_built (Sy.LT | Sy.LE) + | Sy.L_neg_pred | Sy.L_eq | Sy.L_neg_eq + | Sy.L_built (Sy.IsConstr _) + | Sy.L_neg_built (Sy.IsConstr _)) , _ -> + assert false - | (Sy.L_built (Sy.LT | Sy.LE) | Sy.L_neg_built (Sy.LT | Sy.LE) - | Sy.L_neg_pred | Sy.L_eq | Sy.L_neg_eq - | Sy.L_built (Sy.IsConstr _) - | Sy.L_neg_built (Sy.IsConstr _)) , _ -> - assert false + and print_silent fmt t = + let { f ; xs ; ty; bind; _ } = t in + match f, xs with + (* Formulas *) + | Sy.Form form, xs -> print_formula fmt form xs bind + + | Sy.Let, [] -> + let x = match bind with B_let x -> x | _ -> assert false in + fprintf fmt + "(let%a %a =@ %a in@ %a)" + (fun fmt x -> if Options.get_verbose () then + fprintf fmt + " [sko = %a]" print x.let_sko) x + Sy.print x.let_v print x.let_e print_silent x.in_e + + (* Literals *) + | Sy.Lit lit, xs -> print_lit fmt lit xs + + | Sy.Op Sy.Get, [e1; e2] -> + if get_output_smtlib () then + fprintf fmt "(select %a %a)" print e1 print e2 + else + fprintf fmt "%a[%a]" print e1 print e2 + + | Sy.Op Sy.Set, [e1; e2; e3] -> + if get_output_smtlib () then + fprintf fmt "(store %a %a %a)" + print e1 + print e2 + print e3 + else + fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 - end + | Sy.Op Sy.Concat, [e1; e2] -> + fprintf fmt "%a@@%a" print e1 print e2 - | Sy.Op Sy.Get, [e1; e2] -> - if get_output_smtlib () then - fprintf fmt "(select %a %a)" print e1 print e2 - else - fprintf fmt "%a[%a]" print e1 print e2 - - | Sy.Op Sy.Set, [e1; e2; e3] -> - if get_output_smtlib () then - fprintf fmt "(store %a %a %a)" - print e1 - print e2 - print e3 - else - fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 + | Sy.Op Sy.Extract, [e1; e2; e3] -> + fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 - | Sy.Op Sy.Concat, [e1; e2] -> - fprintf fmt "%a@@%a" print e1 print e2 + | Sy.Op (Sy.Access field), [e] -> + if get_output_smtlib () then + fprintf fmt "(%s %a)" (Hstring.view field) print e + else + fprintf fmt "%a.%s" print e (Hstring.view field) + + | Sy.Op (Sy.Record), _ -> + begin match ty with + | Ty.Trecord { Ty.lbs = lbs; _ } -> + assert (List.length xs = List.length lbs); + fprintf fmt "{"; + ignore (List.fold_left2 (fun first (field,_) e -> + fprintf fmt "%s%s = %a" (if first then "" else "; ") + (Hstring.view field) print e; + false + ) true lbs xs); + fprintf fmt "}"; + | _ -> assert false + end - | Sy.Op Sy.Extract, [e1; e2; e3] -> - fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 + (* TODO: introduce PrefixOp in the future to simplify this ? *) + | Sy.Op op, [e1; e2] when op == Sy.Pow || op == Sy.Integer_round || + op == Sy.Max_real || op == Sy.Max_int || + op == Sy.Min_real || op == Sy.Min_int -> + fprintf fmt "%a(%a,%a)" Sy.print f print e1 print e2 - | Sy.Op (Sy.Access field), [e] -> - if get_output_smtlib () then - fprintf fmt "(%s %a)" (Hstring.view field) print e - else - fprintf fmt "%a.%s" print e (Hstring.view field) - - | Sy.Op (Sy.Record), _ -> - begin match ty with - | Ty.Trecord { Ty.lbs = lbs; _ } -> - assert (List.length xs = List.length lbs); - fprintf fmt "{"; - ignore (List.fold_left2 (fun first (field,_) e -> - fprintf fmt "%s%s = %a" (if first then "" else "; ") - (Hstring.view field) print e; - false - ) true lbs xs); - fprintf fmt "}"; - | _ -> assert false - end + (* TODO: introduce PrefixOp in the future to simplify this ? *) + | Sy.Op (Sy.Constr hs), ((_::_) as l) -> + fprintf fmt + "%a(%a)" Hstring.print hs (Util.print_list ~sep:"," ~pp:print) l - (* TODO: introduce PrefixOp in the future to simplify this ? *) - | Sy.Op op, [e1; e2] when op == Sy.Pow || op == Sy.Integer_round || - op == Sy.Max_real || op == Sy.Max_int || - op == Sy.Min_real || op == Sy.Min_int -> - fprintf fmt "%a(%a,%a)" Sy.print f print e1 print e2 + | Sy.Op _, [e1; e2] -> + fprintf fmt "(%a %a %a)" Sy.print f print e1 print e2 - (* TODO: introduce PrefixOp in the future to simplify this ? *) - | Sy.Op (Sy.Constr hs), ((_::_) as l) -> - fprintf fmt "%a(%a)" Hstring.print hs print_list l + | Sy.Op Sy.Destruct (hs, grded), [e] -> + fprintf fmt "%a#%s%a" + print e (if grded then "" else "!") Hstring.print hs - | Sy.Op _, [e1; e2] -> - if get_output_smtlib () then - fprintf fmt "(%a %a %a)" Sy.print f print e1 print e2 - else - fprintf fmt "(%a %a %a)" print e1 Sy.print f print e2 - | Sy.Op Sy.Destruct (hs, grded), [e] -> - fprintf fmt "%a#%s%a" - print e (if grded then "" else "!") Hstring.print hs + | Sy.In(lb, rb), [t] -> + fprintf fmt "(%a in %a, %a)" print t Sy.print_bound lb Sy.print_bound rb + | _, [] -> + fprintf fmt "%a" Sy.print f - | Sy.In(lb, rb), [t] -> - fprintf fmt "(%a in %a, %a)" print t Sy.print_bound lb Sy.print_bound rb + | _, _ -> + fprintf fmt "(%a %a)" Sy.print f (Util.print_list ~sep:"," ~pp:print) xs + and print_triggers fmt trs = + List.iter (fun { content = l; _ } -> + fprintf fmt "| %a@," (Util.print_list ~sep:"," ~pp:print) l; + ) trs - | _, [] -> - fprintf fmt "%a" Sy.print f + and print_verbose fmt t = print fmt t + (* Not displaying types when int SMT format *) - | _, _ -> - if get_output_smtlib () then - fprintf fmt "(%a %a)" Sy.print f print_list xs - else - fprintf fmt "%a(%a)" Sy.print f print_list xs + and print fmt t = + if Options.get_debug () then print_verbose fmt t + else print_silent fmt t + +end + +module AEPrinter = struct + + (* Same as SmtPrinter.print_formula *) + let rec print_formula fmt form xs bind = + match form, xs, bind with + | Sy.F_Unit _, [f1; f2], _ -> + fprintf fmt "@[(%a /\\@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Iff, [f1; f2], _ -> + fprintf fmt "@[(%a <->@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Xor, [f1; f2], _ -> + fprintf fmt "@[(%a xor@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Clause _, [f1; f2], _ -> + fprintf fmt "@[(%a \\/@ %a)@]" print_silent f1 print_silent f2 + + | Sy.F_Lemma, [], B_lemma { user_trs ; main ; name ; binders; _ } -> + if get_verbose () then + fprintf fmt "(lemma: %s forall %a[%a].@ %a)" + name + print_binders binders + print_triggers user_trs + print_silent main + else + fprintf fmt "(lem %s)" name + + | Sy.F_Skolem, [], B_skolem { main; binders; _ } -> + fprintf fmt "( %a)" + print_binders binders print_silent main + + | _ -> assert false + + and print_lit fmt lit xs = + match lit, xs with + | Sy.L_eq, a::l -> + fprintf fmt "(%a%a)" + print a (fun fmt -> List.iter (fprintf fmt " = %a" print)) l + + | Sy.L_neg_eq, [a; b] -> + fprintf fmt "(%a <> %a)" print a print b + + | Sy.L_neg_eq, a::l -> + fprintf fmt "distinct(%a%a)" + print a (fun fmt -> List.iter (fprintf fmt ", %a" print)) l + + | Sy.L_built Sy.LE, [a;b] -> + fprintf fmt "(%a <= %a)" print a print b + + | Sy.L_built Sy.LT, [a;b] -> + fprintf fmt "(%a < %a)" print a print b + + | Sy.L_neg_built Sy.LE, [a; b] -> + fprintf fmt "(%a > %a)" print a print b + + | Sy.L_neg_built Sy.LT, [a; b] -> + fprintf fmt "(%a >= %a)" print a print b + + | Sy.L_neg_pred, [a] -> + fprintf fmt "(not %a)" print a + + | Sy.L_built (Sy.IsConstr hs), [e] -> + fprintf fmt "(%a ? %a)" print e Hstring.print hs + + | Sy.L_neg_built (Sy.IsConstr hs), [e] -> + fprintf fmt "not (%a ? %a)" print e Hstring.print hs + + | (Sy.L_built (Sy.LT | Sy.LE) | Sy.L_neg_built (Sy.LT | Sy.LE) + | Sy.L_neg_pred | Sy.L_eq | Sy.L_neg_eq + | Sy.L_built (Sy.IsConstr _) + | Sy.L_neg_built (Sy.IsConstr _)) , _ -> + assert false + + and print_silent fmt t = + let { f ; xs ; ty; bind; _ } = t in + match f, xs with + (* Formulas *) + | Sy.Form form, xs -> print_formula fmt form xs bind + + | Sy.Let, [] -> + let x = match bind with B_let x -> x | _ -> assert false in + fprintf fmt + "(let%a %a =@ %a in@ %a)" + (fun fmt x -> if Options.get_verbose () then + fprintf fmt + " [sko = %a]" print x.let_sko) x + Sy.print x.let_v print x.let_e print_silent x.in_e + + (* Literals *) + | Sy.Lit lit, xs -> print_lit fmt lit xs + + | Sy.Op Sy.Get, [e1; e2] -> + if get_output_smtlib () then + fprintf fmt "(select %a %a)" print e1 print e2 + else + fprintf fmt "%a[%a]" print e1 print e2 + + | Sy.Op Sy.Set, [e1; e2; e3] -> + if get_output_smtlib () then + fprintf fmt "(store %a %a %a)" + print e1 + print e2 + print e3 + else + fprintf fmt "%a[%a<-%a]" print e1 print e2 print e3 -and print_verbose fmt t = - fprintf fmt "(%a : %a)" print_silent t Ty.print t.ty + | Sy.Op Sy.Concat, [e1; e2] -> + fprintf fmt "%a@@%a" print e1 print e2 -and print fmt t = - if Options.get_debug () then print_verbose fmt t - else print_silent fmt t + | Sy.Op Sy.Extract, [e1; e2; e3] -> + fprintf fmt "%a^{%a,%a}" print e1 print e2 print e3 + + | Sy.Op (Sy.Access field), [e] -> + if get_output_smtlib () then + fprintf fmt "(%s %a)" (Hstring.view field) print e + else + fprintf fmt "%a.%s" print e (Hstring.view field) + + | Sy.Op (Sy.Record), _ -> + begin match ty with + | Ty.Trecord { Ty.lbs = lbs; _ } -> + assert (List.length xs = List.length lbs); + fprintf fmt "{"; + ignore (List.fold_left2 (fun first (field,_) e -> + fprintf fmt "%s%s = %a" (if first then "" else "; ") + (Hstring.view field) print e; + false + ) true lbs xs); + fprintf fmt "}"; + | _ -> assert false + end + + (* TODO: introduce PrefixOp in the future to simplify this ? *) + | Sy.Op op, [e1; e2] when op == Sy.Pow || op == Sy.Integer_round || + op == Sy.Max_real || op == Sy.Max_int || + op == Sy.Min_real || op == Sy.Min_int -> + fprintf fmt "%a(%a,%a)" Sy.print f print e1 print e2 + + (* TODO: introduce PrefixOp in the future to simplify this ? *) + | Sy.Op (Sy.Constr hs), ((_::_) as l) -> + fprintf fmt "%a(%a)" + Hstring.print hs (Util.print_list ~sep:"," ~pp:print) l + + | Sy.Op _, [e1; e2] -> + if get_output_smtlib () then + fprintf fmt "(%a %a %a)" Sy.print f print e1 print e2 + else + fprintf fmt "(%a %a %a)" print e1 Sy.print f print e2 + + | Sy.Op Sy.Destruct (hs, grded), [e] -> + fprintf fmt "%a#%s%a" + print e (if grded then "" else "!") Hstring.print hs + + + | Sy.In(lb, rb), [t] -> + fprintf fmt "(%a in %a, %a)" print t Sy.print_bound lb Sy.print_bound rb + + + | _, [] -> + fprintf fmt "%a" Sy.print f + + | _, _ -> + fprintf fmt "%a(%a)" Sy.print f (Util.print_list ~sep:"," ~pp:print) xs + + and print_triggers fmt trs = + List.iter (fun { content = l; _ } -> + fprintf fmt "| %a@," (Util.print_list ~sep:"," ~pp:print) l; + ) trs + + and print_verbose fmt t = + fprintf fmt "(%a : %a)" print_silent t Ty.print t.ty + + and print fmt t = + if Options.get_debug () then print_verbose fmt t + else print_silent fmt t + +end -and print_list_sep sep fmt = function - | [] -> () - | [t] -> print fmt t - | t::l -> Format.fprintf fmt "%a%s%a" print t sep (print_list_sep sep) l +let print fmt = + if get_output_smtlib () + then SmtPrinter.print fmt + else AEPrinter.print fmt -and print_list fmt = print_list_sep "," fmt +let print_triggers fmt = + if get_output_smtlib () + then SmtPrinter.print_triggers fmt + else AEPrinter.print_triggers fmt -and print_triggers fmt trs = - List.iter (fun { content = l; _ } -> - fprintf fmt "| %a@," print_list l; - ) trs +let print_list_sep sep = Util.print_list ~sep ~pp:print +let print_list fmt = print_list_sep "," fmt (** Some auxiliary functions *) diff --git a/src/lib/structures/profile.mli b/src/lib/structures/profile.mli index b19aa3014..cbd63f70b 100644 --- a/src/lib/structures/profile.mli +++ b/src/lib/structures/profile.mli @@ -9,6 +9,11 @@ (* *) (******************************************************************************) +(** Maps of values for alt-ergo's models. + Elements are sorted by symbols/types (P) and accumulated as sets + of expressions matching the P.key type (V). +*) + module P : Map.S with type key = Symbols.t * Ty.t list * Ty.t From 205bfe9a20a3e3e29a9258e521c28945b025da2b Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Mon, 14 Nov 2022 11:17:09 +0100 Subject: [PATCH 63/68] Consistent inlining annotations --- src/lib/structures/expr.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index 52ccdce7c..90f556515 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -747,9 +747,9 @@ let print_list fmt = print_list_sep "," fmt (** Some auxiliary functions *) -let type_info t = t.ty -let symbol_info t = t.f -let get_infos t = t +let [@inline always] type_info t = t.ty +let [@inline always] symbol_info t = t.f +let [@inline always] get_infos t = t (* unused let is_term e = match e.f with From c8e6783e5794518543f6bc0f6845a72954736219 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Mon, 14 Nov 2022 15:39:15 +0100 Subject: [PATCH 64/68] Not updating instantiation heuristic in model option --- src/bin/common/parse_command.ml | 1 - src/lib/reasoners/fun_sat.ml | 4 ++++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index a2348ab20..99e2cdb8d 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -308,7 +308,6 @@ let mk_limit_opt age_bound fm_cross_limit timelimit_interpretation let mk_models_opt b = if b then begin set_interpretation ILast; - set_instantiation_heuristic INormal; set_sat_solver Tableaux end; `Ok () diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 625912f77..314be8c55 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1344,6 +1344,10 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct let greedy_instantiation env = match get_instantiation_heuristic () with | INormal -> + (* S: This seems spurious! + On example UFDT/20170428-Barrett/cdt-cade2015/data/gandl/cotree/ + x2015_09_10_16_49_52_978_1009894.smt_in.smt2, + this returns a wrong model. *) return_answer env (get_last_interpretation ()) (fun e -> raise (I_dont_know e)) | IAuto | IGreedy -> From c890d8886edd0a3846b79547b486f87e02d3df6c Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Thu, 17 Nov 2022 11:51:26 +0100 Subject: [PATCH 65/68] New name for Profile module --- src/lib/dune | 2 +- src/lib/frontend/models.ml | 8 ++++---- src/lib/frontend/models.mli | 6 +++--- src/lib/reasoners/uf.ml | 8 ++++---- src/lib/structures/{profile.ml => modelMap.ml} | 4 ++++ src/lib/structures/{profile.mli => modelMap.mli} | 13 ++++++++----- 6 files changed, 24 insertions(+), 17 deletions(-) rename src/lib/structures/{profile.ml => modelMap.ml} (97%) rename src/lib/structures/{profile.mli => modelMap.mli} (84%) diff --git a/src/lib/dune b/src/lib/dune index 7473851db..01bc817e3 100644 --- a/src/lib/dune +++ b/src/lib/dune @@ -39,7 +39,7 @@ ; structures Commands Errors Explanation Fpa_rounding Parsed Profiling Satml_types Symbols - Expr Var Ty Typed Xliteral Profile + Expr Var Ty Typed Xliteral ModelMap ; util Config Emap Gc_debug Hconsing Hstring Iheap Lists Loc MyDynlink MyUnix Numbers NumsNumbers NumbersInterface diff --git a/src/lib/frontend/models.ml b/src/lib/frontend/models.ml index 266c201e2..37531c497 100644 --- a/src/lib/frontend/models.ml +++ b/src/lib/frontend/models.ml @@ -312,10 +312,10 @@ module SmtlibCounterExample = struct defined_value let output_constants_counterexample fmt records cprofs = - Profile.iter + ModelMap.iter (fun (f, xs_ty, ty) st -> assert (xs_ty == []); - match Profile.V.elements st with + match ModelMap.V.elements st with | [[], rep] -> let rep = Format.asprintf "%a" x_print rep in let rep = @@ -332,7 +332,7 @@ module SmtlibCounterExample = struct let output_functions_counterexample fmt records fprofs = let records = ref records in - Profile.iter + ModelMap.iter (fun (f, xs_ty, ty) st -> let xs_ty_named = List.mapi (fun i ty -> ty,(sprintf "arg_%d" i) @@ -340,7 +340,7 @@ module SmtlibCounterExample = struct let rep = let representants = - Profile.V.fold (fun (xs_values,(_rep,srep)) acc -> + ModelMap.V.fold (fun (xs_values,(_rep,srep)) acc -> assert ((List.length xs_ty_named) = (List.length xs_values)); records := check_records !records xs_ty_named xs_values f ty srep; diff --git a/src/lib/frontend/models.mli b/src/lib/frontend/models.mli index b454e7003..5e588a830 100644 --- a/src/lib/frontend/models.mli +++ b/src/lib/frontend/models.mli @@ -20,7 +20,7 @@ val output_concrete_model : Format.formatter -> Expr.Set.t -> - functions:Profile.V.t Profile.P.t -> - constants:Profile.V.t Profile.P.t -> - arrays:Profile.V.t Profile.P.t -> + functions:ModelMap.t -> + constants:ModelMap.t -> + arrays:ModelMap.t -> unit diff --git a/src/lib/reasoners/uf.ml b/src/lib/reasoners/uf.ml index 8c2e9ce89..18144b9dd 100644 --- a/src/lib/reasoners/uf.ml +++ b/src/lib/reasoners/uf.ml @@ -1066,7 +1066,7 @@ let compute_concrete_model ({ make; _ } as env) = assert (xs_ta == []); fprofs, cprofs, - Profile.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, + ModelMap.add (f_ta,[X.type_info i], ty) ([e], rep) carrays, mrepr | _ -> assert false @@ -1074,14 +1074,14 @@ let compute_concrete_model ({ make; _ } as env) = | _ -> if tys == [] then - fprofs, Profile.add (f, tys, ty) (xs, rep) cprofs, carrays, + fprofs, ModelMap.add (f, tys, ty) (xs, rep) cprofs, carrays, mrepr else - Profile.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, + ModelMap.add (f, tys, ty) (xs, rep) fprofs, cprofs, carrays, mrepr ) make - (Profile.empty, Profile.empty, Profile.empty, ME.empty) + (ModelMap.empty, ModelMap.empty, ModelMap.empty, ME.empty) let output_concrete_model fmt ~prop_model env = if get_interpretation () then diff --git a/src/lib/structures/profile.ml b/src/lib/structures/modelMap.ml similarity index 97% rename from src/lib/structures/profile.ml rename to src/lib/structures/modelMap.ml index 23a669c61..72b671d81 100644 --- a/src/lib/structures/profile.ml +++ b/src/lib/structures/modelMap.ml @@ -61,6 +61,10 @@ module V = Set.Make | Invalid_argument _ -> List.length l1 - List.length l2 end) +type key = P.key +type elt = V.t +type t = V.t P.t + let add p v mp = let prof_p = try P.find p mp with Not_found -> V.empty in if V.mem v prof_p then mp diff --git a/src/lib/structures/profile.mli b/src/lib/structures/modelMap.mli similarity index 84% rename from src/lib/structures/profile.mli rename to src/lib/structures/modelMap.mli index cbd63f70b..d7a5133ac 100644 --- a/src/lib/structures/profile.mli +++ b/src/lib/structures/modelMap.mli @@ -21,13 +21,16 @@ module V : Set.S with type elt = (Expr.t * (Shostak.Combine.r * string)) list * (Shostak.Combine.r * string) +type key = P.key +type elt = V.t +type t = V.t P.t -val add : P.key -> V.elt -> V.t P.t -> V.t P.t +val add : key -> V.elt -> t -> t -val iter : (P.key -> 'a -> unit) -> 'a P.t -> unit +val iter : (key -> elt -> unit) -> t -> unit -val fold : (P.key -> 'a -> 'b -> 'b) -> 'a P.t -> 'b -> 'b +val fold : (key -> elt -> 'acc -> 'acc) -> t -> 'acc -> 'acc -val empty : 'a P.t +val empty : t -val is_empty : 'a P.t -> bool +val is_empty : t -> bool From 9d85c3319c8fdf25c2a10f5eaddb9281be09e96f Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Thu, 17 Nov 2022 11:54:11 +0100 Subject: [PATCH 66/68] Fix SMTLIB2 printer --- src/lib/reasoners/shostak.ml | 2 +- src/lib/structures/expr.ml | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/lib/reasoners/shostak.ml b/src/lib/reasoners/shostak.ml index 0793bbe16..a6b2aae25 100644 --- a/src/lib/reasoners/shostak.ml +++ b/src/lib/reasoners/shostak.ml @@ -605,7 +605,7 @@ struct let dist = List.filter (fun r -> is_bool_const r) distincts in match dist with | {v = Term e; _}::_ -> - Some (Expr.neg e, true) (* safety: consider it as case-splut *) + Some (Expr.neg e, true) (* safety: consider it as case-split *) | _::_ -> assert false | [] -> diff --git a/src/lib/structures/expr.ml b/src/lib/structures/expr.ml index 90f556515..1e135acf6 100644 --- a/src/lib/structures/expr.ml +++ b/src/lib/structures/expr.ml @@ -386,16 +386,16 @@ module SmtPrinter = struct let rec print_formula fmt form xs bind = match form, xs, bind with | Sy.F_Unit _, [f1; f2], _ -> - fprintf fmt "@[(%a /\\@ %a)@]" print_silent f1 print_silent f2 + fprintf fmt "@[(and %a %a)@]" print_silent f1 print_silent f2 | Sy.F_Iff, [f1; f2], _ -> - fprintf fmt "@[(%a <->@ %a)@]" print_silent f1 print_silent f2 + fprintf fmt "@[(= %a %a)@]" print_silent f1 print_silent f2 | Sy.F_Xor, [f1; f2], _ -> - fprintf fmt "@[(%a xor@ %a)@]" print_silent f1 print_silent f2 + fprintf fmt "@[(not (= %a %a))@]" print_silent f1 print_silent f2 | Sy.F_Clause _, [f1; f2], _ -> - fprintf fmt "@[(%a \\/@ %a)@]" print_silent f1 print_silent f2 + fprintf fmt "@[(or %a %a)@]" print_silent f1 print_silent f2 | Sy.F_Lemma, [], B_lemma { user_trs ; main ; name ; binders; _ } -> if get_verbose () then From f0c7dad6a02a53881afb7a46d286ec469a684cc3 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Thu, 17 Nov 2022 16:56:41 +0100 Subject: [PATCH 67/68] Poetry --- docs/sphinx_docs/Usage/index.md | 6 ++++-- src/bin/common/parse_command.ml | 5 ++--- src/lib/frontend/typechecker.ml | 1 - src/lib/structures/expr.mli | 6 +++--- src/lib/util/version.ml | 2 +- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/docs/sphinx_docs/Usage/index.md b/docs/sphinx_docs/Usage/index.md index a21e03b9b..3d5da2e5d 100644 --- a/docs/sphinx_docs/Usage/index.md +++ b/docs/sphinx_docs/Usage/index.md @@ -30,6 +30,9 @@ See the [Input section] for more information about the format of the input files Since 2.5.0, Alt-Ergo also generates models in the case it concludes on the satisfiability of the formula. There is two ways to activate model generation: + +- with the `--model` option; + - `with the --interpretation=VALUE`, where VALUE can be equal to: * "none", and alt-ergo will not generate models (by default); * "first", and alt-ergo will output the first model it finds; @@ -37,8 +40,7 @@ There is two ways to activate model generation: * "last", and alt-ergo will output the last model it computes before returning 'unknown'. Note that this mode only works with the option `--sat-solver tableaux`. -- with the `--model option`, setting the interpretation option to 'last', and the sat-solver -to 'tableaux. +NB: the `--model` option is equivalent to `--interpretation every --sat-solver tableaux`. The default model format is the SMT format. diff --git a/src/bin/common/parse_command.ml b/src/bin/common/parse_command.ml index 99e2cdb8d..bcff8928e 100644 --- a/src/bin/common/parse_command.ml +++ b/src/bin/common/parse_command.ml @@ -979,7 +979,7 @@ let parse_output_opt = let doc = Format.sprintf "Control the output model type of the solver, $(docv) must be %s." - (Arg.doc_alts [ "value"; "constraint" ]) + (Arg.doc_alts [ "value"; "constraints" ]) in let docv = "MTYP" in Arg.( @@ -1305,8 +1305,7 @@ let parse_fmt_opt = let model_output = let doc = Format.sprintf - "Set the model formatter used by default to output model and - interpretation. Possible values are %s." + "Set the output used for the model generation. Possible values are %s." (Arg.doc_alts ["stdout"; "stderr"; ""]) in Arg.(value & opt formatter_conv Stdout & info ["model-output"] ~docs ~doc) in diff --git a/src/lib/frontend/typechecker.ml b/src/lib/frontend/typechecker.ml index a124cac0d..b19b498d2 100644 --- a/src/lib/frontend/typechecker.ml +++ b/src/lib/frontend/typechecker.ml @@ -1958,7 +1958,6 @@ let type_goal acc env_g loc sort n goal = let rec type_and_intro_goal acc env sort n f = - (* let b = (\* smtfile() || smt2file() || satmode()*\) false in *) let axioms, (goal, env_g) = intro_hypothesis env (match sort with Sat -> false | _ -> true) f in let loc = f.pp_loc in diff --git a/src/lib/structures/expr.mli b/src/lib/structures/expr.mli index c9a990aae..7c4b38be5 100644 --- a/src/lib/structures/expr.mli +++ b/src/lib/structures/expr.mli @@ -168,9 +168,9 @@ val is_fresh : t -> bool val is_fresh_skolem : t -> bool val is_int : t -> bool val is_real : t -> bool -val [@inline always] type_info : t -> Ty.t -val [@inline always] symbol_info : t -> Symbols.t -val [@inline always] get_infos : t -> view +val type_info : t -> Ty.t +val symbol_info : t -> Symbols.t +val get_infos : t -> view (** Labeling and models *) diff --git a/src/lib/util/version.ml b/src/lib/util/version.ml index 30d76e9e5..67710c686 100644 --- a/src/lib/util/version.ml +++ b/src/lib/util/version.ml @@ -29,7 +29,7 @@ (* WARNING: a "cut" is performed on the following file in the Makefile. DO NOT CHANGE its format *) -let _version="models" +let _version="dev" let _release_commit = "(not released)" From f0223f2d7d1b4d2a6558473f099e025a6c1a5580 Mon Sep 17 00:00:00 2001 From: Steven de Oliveira Date: Thu, 17 Nov 2022 17:25:03 +0100 Subject: [PATCH 68/68] Rebase artifacts --- src/lib/reasoners/fun_sat.ml | 2 +- src/lib/reasoners/uf.mli | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/lib/reasoners/fun_sat.ml b/src/lib/reasoners/fun_sat.ml index 314be8c55..b9cae95c9 100644 --- a/src/lib/reasoners/fun_sat.ml +++ b/src/lib/reasoners/fun_sat.ml @@ -1919,7 +1919,7 @@ module Make (Th : Theory.S) : Sat_solver_sig.S = struct {env with tbox = Th.assume_th_elt env.tbox th_elt dep} let reinit_ctx () = - all_models_sat_env := None; + (* all_models_sat_env := None; *) latest_saved_env := None; terminated_normally := false; Steps.reinit_steps (); diff --git a/src/lib/reasoners/uf.mli b/src/lib/reasoners/uf.mli index e31772603..389d12b79 100644 --- a/src/lib/reasoners/uf.mli +++ b/src/lib/reasoners/uf.mli @@ -66,7 +66,6 @@ val make : t -> Expr.t -> r (* may raise Not_found *) val is_normalized : t -> r -> bool val assign_next : t -> (r Xliteral.view * bool * Th_util.lit_origin) list * t -val output_concrete_model : t -> unit (** {2 Counterexample function} *)