diff options
41 files changed, 911 insertions, 3483 deletions
@@ -17,6 +17,8 @@ setup.log *.v.d *.aux *.vo +*.vok +*.vos *.d .lia.cache .nia.cache @@ -28,7 +30,7 @@ src/Makefile.conf src/Makefile.local src/smtcoq_plugin.ml4 src/versions/native/Structures.v -src/g_smtcoq.ml4 +src/g_smtcoq.mlg src/smtcoq_plugin.mlpack src/Tactics.v src/versions/standard/Int63/Int63.v @@ -6,16 +6,16 @@ SMTCoq is designed to work on computers equipped with a POSIX (Unix or a clone) operating system. It is known to work under GNU/Linux (i386 and amd64) and Mac OS X. -The simplest way is to install it using opam. You can also install it -from the sources (this is mandatory if you want to use the native -version, see below). +<!-- The simplest way is to install it using opam. You can also install it --> +<!-- from the sources (this is mandatory if you want to use the native --> +<!-- version, see below). --> You will also need to [install the provers](#installation-of-the-provers) you want to use. ## Requirements -You need to have OCaml version >= 4.09.0 and Coq version 8.9.0. +You need to have OCaml version >= 4.09.0 and Coq version 8.11.*. The easiest way to install these two pieces of software is through opam. > **Warning**: The version of Coq that you plan to use must have been compiled @@ -26,23 +26,23 @@ The easiest way to install these two pieces of software is through opam. If you want to use SMTCoq with high performance to check large proof certificates, you need to use the [version of Coq with native data-structures](https://github.com/smtcoq/native-coq) instead of -Coq-8.9 (warning: this allows one to use the vernacular commands but not +Coq-8.11 (warning: this allows one to use the vernacular commands but not the tactics). -### Installation via opam (recommended) +<!-- ### Installation via opam (recommended) --> -Simply add the coq-extra-dev repo to opam: -```bash -opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev -``` -and install SMTCoq: -```bash -opam install coq-smtcoq -``` +<!-- Simply add the coq-extra-dev repo to opam: --> +<!-- ```bash --> +<!-- opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev --> +<!-- ``` --> +<!-- and install SMTCoq: --> +<!-- ```bash --> +<!-- opam install coq-smtcoq --> +<!-- ``` --> -### Installation from the sources, using opam (not recommended) +### Installation from the sources, using opam <!-- (not recommended) --> #### Install opam @@ -75,16 +75,16 @@ opam switch create ocaml-base-compiler.4.09.0 #### Install Coq -After OCaml is installed, you can install Coq-8.9.0 through opam. +After OCaml is installed, you can install Coq-8.11.0 through opam. ```bash -opam install coq.8.9.0 +opam install coq.8.11.0 ``` If you also want to install CoqIDE at the same time you can do ```bash -opam install coq.8.9.0 coqide.8.9.0 +opam install coq.8.11.0 coqide.8.11.0 ``` but you might need to install some extra packages and libraries for your system @@ -102,66 +102,66 @@ make install ``` -### Installation from the sources, with official Coq 8.9 release (not recommended) - -1. Download the last stable version of Coq 8.9: -```bash -wget https://github.com/coq/coq/archive/V8.9.0.tar.gz -``` - and compile it by following the instructions available in the - repository (make sure you use OCaml 4.09.0 for that). We recommand - that you do not install it, but only compile it in local: -```bash -./configure -local -make -``` - -2. Set an environment variable COQBIN to the directory where Coq's - binaries are; for instance: -```bash -export COQBIN=/home/jdoe/coq-8.9.0/bin/ -``` - (the final slash is mandatory). - -3. Compile and install SMTCoq by using the following commands in the src directory. -``` -./configure.sh -make -make install -``` - - -### Installation with native-coq (not recommended except for high performances) - -> **Warning**: this installation procedure is recommended only to use -> the vernacular commands efficiently (in particular, to check very -> large proof certificates). It does not allow one to use the tactics. - -1. Download the git version of Coq with native compilation: -```bash -git clone https://github.com/smtcoq/native-coq.git -``` - and compile it by following the instructions available in the - repository. We recommand that you do not install it, but only compile - it in local: -```bash -./configure -local -make -``` - -2. Set an environment variable COQBIN to the directory where Coq's - binaries are; for instance: -```bash -export COQBIN=/home/jdoe/native-coq/bin/ -``` - (the final slash is mandatory). - -3. Compile and install SMTCoq by using the following commands in the src directory. -``` -./configure.sh -native -make -make install -``` +<!-- ### Installation from the sources, with official Coq 8.9 release (not recommended) --> + +<!-- 1. Download the last stable version of Coq 8.9: --> +<!-- ```bash --> +<!-- wget https://github.com/coq/coq/archive/V8.9.0.tar.gz --> +<!-- ``` --> +<!-- and compile it by following the instructions available in the --> +<!-- repository (make sure you use OCaml 4.09.0 for that). We recommand --> +<!-- that you do not install it, but only compile it in local: --> +<!-- ```bash --> +<!-- ./configure -local --> +<!-- make --> +<!-- ``` --> + +<!-- 2. Set an environment variable COQBIN to the directory where Coq's --> +<!-- binaries are; for instance: --> +<!-- ```bash --> +<!-- export COQBIN=/home/jdoe/coq-8.9.0/bin/ --> +<!-- ``` --> +<!-- (the final slash is mandatory). --> + +<!-- 3. Compile and install SMTCoq by using the following commands in the src directory. --> +<!-- ``` --> +<!-- ./configure.sh --> +<!-- make --> +<!-- make install --> +<!-- ``` --> + + +<!-- ### Installation with native-coq (not recommended except for high performances) --> + +<!-- > **Warning**: this installation procedure is recommended only to use --> +<!-- > the vernacular commands efficiently (in particular, to check very --> +<!-- > large proof certificates). It does not allow one to use the tactics. --> + +<!-- 1. Download the git version of Coq with native compilation: --> +<!-- ```bash --> +<!-- git clone https://github.com/smtcoq/native-coq.git --> +<!-- ``` --> +<!-- and compile it by following the instructions available in the --> +<!-- repository. We recommand that you do not install it, but only compile --> +<!-- it in local: --> +<!-- ```bash --> +<!-- ./configure -local --> +<!-- make --> +<!-- ``` --> + +<!-- 2. Set an environment variable COQBIN to the directory where Coq's --> +<!-- binaries are; for instance: --> +<!-- ```bash --> +<!-- export COQBIN=/home/jdoe/native-coq/bin/ --> +<!-- ``` --> +<!-- (the final slash is mandatory). --> + +<!-- 3. Compile and install SMTCoq by using the following commands in the src directory. --> +<!-- ``` --> +<!-- ./configure.sh -native --> +<!-- make --> +<!-- make install --> +<!-- ``` --> ## Installation of the provers diff --git a/examples/Example.v b/examples/Example.v index 2d48776..a7ca413 100644 --- a/examples/Example.v +++ b/examples/Example.v @@ -11,7 +11,7 @@ (* [Require Import SMTCoq.SMTCoq.] loads the SMTCoq library. - If you are using native-coq instead of Coq 8.9, replace it with: + If you are using native-coq instead of Coq 8.11, replace it with: Require Import SMTCoq. *) diff --git a/src/BEST_PRACTICE.md b/src/BEST_PRACTICE.md index 783ef82..a61ec79 100644 --- a/src/BEST_PRACTICE.md +++ b/src/BEST_PRACTICE.md @@ -5,6 +5,14 @@ No axiom should be added. No library adding axioms should be imported (except Int63 and Array). +## Hints + +Every hint should be put in a hint database, whose name starts with +"smtcoq_". There should be a different database for each part of SMTCoq +(e.g., one for each theory). The general database that is used across +the project is named `smtcoq_core`. + + # Code organization ## Documentation Every OCaml module comes with a documented interface. @@ -815,26 +815,26 @@ Section List2. | In2_hd : forall l, In j l -> In2 i j (i::l) | In2_tl : forall k l, In2 i j l -> In2 i j (k::l). - Local Hint Constructors In2. + Local Hint Constructors In2 : smtcoq_in2. Lemma In2_app : forall i j l m, In2 i j (l ++ m) <-> In2 i j l \/ (In i l /\ In j m) \/ In2 i j m. Proof. - intros i j; induction l as [ |t l IHl]; simpl; intro m; split; auto. - intros [H|[[H _]|H]]; auto. + intros i j; induction l as [ |t l IHl]; simpl; intro m; split; auto with smtcoq_in2. + intros [H|[[H _]|H]]; auto with smtcoq_in2. inversion H. elim H. intro H; inversion H; clear H. - subst i l0; rewrite in_app_iff in H1; destruct H1 as [H1|H1]; auto. - subst k l0; rewrite IHl in H1; destruct H1 as [H1|[[H1 H2]|H1]]; auto. + subst i l0; rewrite in_app_iff in H1; destruct H1 as [H1|H1]; auto with smtcoq_in2. + subst k l0; rewrite IHl in H1; destruct H1 as [H1|[[H1 H2]|H1]]; auto with smtcoq_in2. intros [H|[[[H|H] H1]|H]]. inversion H; clear H. - subst i l0; constructor 1; rewrite in_app_iff; auto. - subst k l0; constructor 2; rewrite IHl; left; auto. - subst t; constructor 1; rewrite in_app_iff; auto. - constructor 2; rewrite IHl; right; left; auto. - constructor 2; rewrite IHl; right; right; auto. + subst i l0; constructor 1; rewrite in_app_iff; auto with smtcoq_in2. + subst k l0; constructor 2; rewrite IHl; left; auto with smtcoq_in2. + subst t; constructor 1; rewrite in_app_iff; auto with smtcoq_in2. + constructor 2; rewrite IHl; right; left; auto with smtcoq_in2. + constructor 2; rewrite IHl; right; right; auto with smtcoq_in2. Qed. @@ -848,17 +848,17 @@ Section List2. Lemma In2_rev_aux : forall i j l acc, In2 i j (rev_aux acc l) <-> In2 i j acc \/ (In i l /\ In j acc) \/ In2 j i l. Proof. - intros i j; induction l as [ |t q IHq]; simpl; intro acc; split; auto. - intros [H|[[H _]|H]]; auto. + intros i j; induction l as [ |t q IHq]; simpl; intro acc; split; auto with smtcoq_in2. + intros [H|[[H _]|H]]; auto with smtcoq_in2. elim H. inversion H. - rewrite IHq; clear IHq; intros [H|[[H1 H2]|H]]; auto. - inversion H; auto. - inversion H2; auto; clear H2; subst t; right; right; auto. - intros [H|[[[H1|H1] H2]|H]]; rewrite IHq; clear IHq; auto. - subst t; auto. - right; left; split; auto; constructor 2; auto. - inversion H; clear H; auto; subst j l; right; left; split; auto; constructor 1; auto. + rewrite IHq; clear IHq; intros [H|[[H1 H2]|H]]; auto with smtcoq_in2. + inversion H; auto with smtcoq_in2. + inversion H2; auto with smtcoq_in2; clear H2; subst t; right; right; auto with smtcoq_in2. + intros [H|[[[H1|H1] H2]|H]]; rewrite IHq; clear IHq; auto with smtcoq_in2. + subst t; auto with smtcoq_in2. + right; left; split; auto with smtcoq_in2; constructor 2; auto with smtcoq_in2. + inversion H; clear H; auto with smtcoq_in2; subst j l; right; left; split; auto with smtcoq_in2; constructor 1; auto with smtcoq_in2. Qed. @@ -867,7 +867,7 @@ Section List2. Lemma In2_rev : forall i j l, In2 i j (rev l) <-> In2 j i l. Proof. - intros i j l; unfold rev; rewrite In2_rev_aux; split; auto; intros [H|[[_ H]|H]]; auto; inversion H. + intros i j l; unfold rev; rewrite In2_rev_aux; split; auto with smtcoq_in2; intros [H|[[_ H]|H]]; auto with smtcoq_in2; inversion H. Qed. @@ -877,15 +877,15 @@ Section List2. intros [H1 H2]; generalize H1 H2; clear H1 H2; induction l as [ |t q IHq]. intro H1; inversion H1. intros H1 H2; inversion H1; clear H1. - subst t; inversion H2; auto; elim H; auto. + subst t; inversion H2; auto with smtcoq_in2; elim H; auto with smtcoq_in2. inversion H2; clear H2. - subst t; auto. - destruct (IHq H0 H1) as [H2|H2]; auto. + subst t; auto with smtcoq_in2. + destruct (IHq H0 H1) as [H2|H2]; auto with smtcoq_in2. intros [H1|H1]; induction H1 as [H1|t q H1 [IH1 IH2]]. - split; [constructor 1|constructor 2]; auto. - split; constructor 2; auto. - split; [constructor 2|constructor 1]; auto. - split; constructor 2; auto. + split; [constructor 1|constructor 2]; auto with smtcoq_in2. + split; constructor 2; auto with smtcoq_in2. + split; [constructor 2|constructor 1]; auto with smtcoq_in2. + split; constructor 2; auto with smtcoq_in2. Qed. End List2. @@ -944,32 +944,32 @@ Section Distinct. distinct_aux acc' q end. - Local Hint Constructors In2. + Local Hint Constructors In2 : smtcoq_in2. Lemma distinct_aux_spec : forall l acc, distinct_aux acc l = true <-> acc = true /\ (forall i j, In2 i j l -> eq i j = false). Proof. induction l as [ |t q IHq]; simpl. intro acc; split. - intro H; split; auto; intros i j H1; inversion H1. - intros [H _]; auto. + intro H; split; auto with smtcoq_in2; intros i j H1; inversion H1. + intros [H _]; auto with smtcoq_in2. intro acc; rewrite (IHq (distinct_aux2 acc t q)), distinct_aux2_spec; split. - intros [[H1 H2] H3]; split; auto; intros i j H; inversion H; auto. - intros [H1 H2]; repeat split; auto. + intros [[H1 H2] H3]; split; auto with smtcoq_in2; intros i j H; inversion H; auto with smtcoq_in2. + intros [H1 H2]; repeat split; auto with smtcoq_in2. Qed. Lemma distinct_aux_spec_neg : forall l acc, distinct_aux acc l = false <-> acc = false \/ (exists i j, In2 i j l /\ eq i j = true). Proof. induction l as [ |t q IHq]; simpl. - intro acc; split; auto; intros [H|[i [j [H _]]]]; auto; inversion H. + intro acc; split; auto with smtcoq_in2; intros [H|[i [j [H _]]]]; auto with smtcoq_in2; inversion H. intro acc; rewrite (IHq (distinct_aux2 acc t q)), distinct_aux2_spec_neg; split. - intros [[H|[i [H1 H2]]]|[i [j [H1 H2]]]]; auto. - right; exists t; exists i; auto. - right; exists i; exists j; auto. - intros [H|[i [j [H1 H2]]]]; auto; inversion H1; clear H1. - subst i l; left; right; exists j; auto. - subst k l; right; exists i; exists j; auto. + intros [[H|[i [H1 H2]]]|[i [j [H1 H2]]]]; auto with smtcoq_in2. + right; exists t; exists i; auto with smtcoq_in2. + right; exists i; exists j; auto with smtcoq_in2. + intros [H|[i [j [H1 H2]]]]; auto with smtcoq_in2; inversion H1; clear H1. + subst i l; left; right; exists j; auto with smtcoq_in2. + subst k l; right; exists i; exists j; auto with smtcoq_in2. Qed. Definition distinct := distinct_aux true. @@ -977,13 +977,13 @@ Section Distinct. Lemma distinct_spec : forall l, distinct l = true <-> (forall i j, In2 i j l -> eq i j = false). Proof. - unfold distinct; intro l; rewrite distinct_aux_spec; split; auto; intros [_ H]; auto. + unfold distinct; intro l; rewrite distinct_aux_spec; split; auto with smtcoq_in2; intros [_ H]; auto with smtcoq_in2. Qed. Lemma distinct_false_spec : forall l, distinct l = false <-> (exists i j, In2 i j l /\ eq i j = true). Proof. - unfold distinct; intro l; rewrite distinct_aux_spec_neg; split; auto; intros [H|H]; auto; discriminate. + unfold distinct; intro l; rewrite distinct_aux_spec_neg; split; auto with smtcoq_in2; intros [H|H]; auto with smtcoq_in2; discriminate. Qed. End Distinct. diff --git a/src/QInst.v b/src/QInst.v index 724a482..cb533ee 100644 --- a/src/QInst.v +++ b/src/QInst.v @@ -27,7 +27,7 @@ Proof. installed when we compile SMTCoq. *) Qed. -Hint Resolve impl_split. +Hint Resolve impl_split : smtcoq_core. (* verit silently transforms an <implb (a || b) c> into a <or (not a) c> or into a <or (not b) c> when instantiating such a quantified theorem *) @@ -69,7 +69,7 @@ Ltac vauto := eapply impl_or_split_left; apply H end; apply H); - auto. + auto with smtcoq_core. diff --git a/src/SMT_terms.v b/src/SMT_terms.v index a85804c..1df1ab7 100644 --- a/src/SMT_terms.v +++ b/src/SMT_terms.v @@ -18,7 +18,7 @@ Local Open Scope list_scope. Local Open Scope array_scope. Local Open Scope int63_scope. -Hint Unfold is_true. +Hint Unfold is_true : smtcoq_core. (* Remark: I use Notation instead of Definition du eliminate conversion check during the type checking *) @@ -125,11 +125,11 @@ Module Form. destruct h;simpl;intros;trivial; try (apply afold_left_eq;unfold is_true in H0; rewrite PArray.forallb_spec in H0;intros; - auto using Lit.interp_eq_compat). + auto using Lit.interp_eq_compat with smtcoq_core). - f_equal;auto using Lit.interp_eq_compat. - apply afold_right_eq;unfold is_true in H0; rewrite PArray.forallb_spec in H0;intros; - auto using Lit.interp_eq_compat. + auto using Lit.interp_eq_compat with smtcoq_core. - unfold is_true in H0;rewrite !andb_true_iff in H0;decompose [and] H0; rewrite !(Lit.interp_eq_compat f1 f2);auto. - unfold is_true in H0;rewrite !andb_true_iff in H0;decompose [and] H0; @@ -138,7 +138,7 @@ Module Form. rewrite !(Lit.interp_eq_compat f1 f2);auto. - replace (List.map (Lit.interp f2) l) with (List.map (Lit.interp f1) l); auto. unfold is_true in H0. rewrite List.forallb_forall in H0. - apply List_map_ext_in. intros x Hx. apply Lit.interp_eq_compat; auto. + apply List_map_ext_in. intros x Hx. apply Lit.interp_eq_compat; auto with smtcoq_core. Qed. Definition wf := PArray.forallbi lt_form t_form. @@ -589,11 +589,11 @@ Module Typ. (* TODO : Move this *) Lemma not_false : ~ false. Proof. intro;discriminate. Qed. - Hint Resolve not_false. + Hint Resolve not_false : smtcoq_core. Lemma is_true_true : true. Proof. reflexivity. Qed. - Hint Resolve is_true_true. + Hint Resolve is_true_true : smtcoq_core. Lemma not_is_true_eq_false : forall b:bool, ~ b <-> b = false. Proof. exact not_true_iff_false. Qed. @@ -1231,8 +1231,8 @@ Qed. intros [op|op h|op h1 h2|op ha i i0|f args | i e ]; simpl. (* Constants *) left; destruct op; simpl. - exists Typ.Tpositive; auto. - exists Typ.TZ; auto. + exists Typ.Tpositive; auto with smtcoq_core. + exists Typ.TZ; auto with smtcoq_core. exists (Typ.TBV n); now rewrite N.eqb_refl. (* Unary operators *) destruct op; simpl; @@ -1440,7 +1440,7 @@ Qed. right. intros. rewrite andb_false_r. easy. (* N-ary operators *) destruct f as [ty]; simpl; case (List.forallb (fun t1 : int => Typ.eqb (get_type t1) ty) args). - left; exists Typ.Tbool; auto. + left; exists Typ.Tbool; auto with smtcoq_core. right; intro T; rewrite andb_false_r; auto. (* Application *) case (v_type Typ.ftype interp_ft (t_func .[ i])); intros; apply check_args_dec. diff --git a/src/Trace.v b/src/Trace.v index e7c7d22..86250a2 100644 --- a/src/Trace.v +++ b/src/Trace.v @@ -280,7 +280,7 @@ Module Cnf_Checker. checker_b t_form l b c = true -> Lit.interp (Form.interp_state_var (PArray.get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l = b. Proof. - unfold checker_b; intros t_var t_form l b c; case b; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l); auto; intros H1 H2; elim (checker_correct H2 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); auto; rewrite Lit.interp_neg, H1; auto. + unfold checker_b; intros t_var t_form l b c; case b; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l); auto with smtcoq_core; intros H1 H2; elim (checker_correct H2 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); auto with smtcoq_core; rewrite Lit.interp_neg, H1; auto with smtcoq_core. Qed. Definition checker_eq t_form l1 l2 l (c:certif) := @@ -297,8 +297,8 @@ Module Cnf_Checker. Lit.interp (Form.interp_state_var (PArray.get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l2. Proof. unfold checker_eq; intros t_var t_form l1 l2 l c; rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _|intros a ls Heq]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int63Properties.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form). - unfold checker in H3; destruct c as (nclauses, t, confl); rewrite andb_true_iff in H3; destruct H3 as [H3 _]; destruct (Form.check_form_correct (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) _ H3) as [[Ht1 Ht2] Ht3]; split; auto. - destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l2); intro Heq2; auto; elim (checker_correct H3 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite Heq; simpl; rewrite Heq1, Heq2; auto. + unfold checker in H3; destruct c as (nclauses, t, confl); rewrite andb_true_iff in H3; destruct H3 as [H3 _]; destruct (Form.check_form_correct (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) _ H3) as [[Ht1 Ht2] Ht3]; split; auto with smtcoq_core. + destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (get t_var) (fun _ s => BITVECTOR_LIST.zeros s) t_form) l2); intro Heq2; auto with smtcoq_core; elim (checker_correct H3 (rho:=get t_var) (rhobv:=fun _ s => BITVECTOR_LIST.zeros s)); unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_core; rewrite Heq; simpl; rewrite Heq1, Heq2; auto with smtcoq_core. Qed. End Cnf_Checker. @@ -433,49 +433,49 @@ Inductive step := |pos orig1 orig2 res|pos orig1 orig2 res |pos orig1 orig2 res|pos orig1 orig2 res|pos orig1 orig2 res|pos orig1 orig2 res |pos cl |pos orig res |pos orig res |pos orig res | pos orig1 orig2 res | pos orig1 orig2 res |pos res|pos res - |pos res |pos prem_id prem concl p|pos lemma plemma concl p]; simpl; try apply S.valid_set_clause; auto. - - apply S.valid_set_resolve; auto. - - apply S.valid_set_weaken; auto. - - apply valid_check_flatten; auto; intros h1 h2 H. - + rewrite (Syntactic.check_hatom_correct_bool _ _ _ Ha1 Ha2 _ _ H); auto. - + rewrite (Syntactic.check_neg_hatom_correct_bool _ _ _ H10 Ha1 Ha2 _ _ H); auto. - - apply valid_check_True; auto. - - apply valid_check_False; auto. - - apply valid_check_BuildDef; auto. - - apply valid_check_BuildDef2; auto. - - apply valid_check_BuildProj; auto. - - apply valid_check_ImmBuildDef; auto. - - apply valid_check_ImmBuildDef2; auto. - - apply valid_check_ImmBuildProj; auto. - - apply valid_check_trans; auto. - - apply valid_check_congr; auto. - - apply valid_check_congr_pred; auto. - - apply valid_check_micromega; auto. - - apply valid_check_diseq; auto. - - apply valid_check_spl_arith; auto. - - apply valid_check_distinct_elim; auto. - - eapply valid_check_bbVar; eauto. - - apply valid_check_bbConst; auto. - - apply valid_check_bbOp; auto. - - apply valid_check_bbNot; auto. - - apply valid_check_bbNeg; auto. - - apply valid_check_bbAdd; auto. - - apply valid_check_bbConcat; auto. - - apply valid_check_bbMult; auto. - - apply valid_check_bbUlt; auto. - - apply valid_check_bbSlt; auto. - - apply valid_check_bbEq; auto. - - apply valid_check_bbDiseq; auto. - - apply valid_check_bbExtract; auto. - - apply valid_check_bbZextend; auto. - - apply valid_check_bbSextend; auto. - - apply valid_check_bbShl; auto. - - apply valid_check_bbShr; auto. - - apply valid_check_roweq; auto. - - apply valid_check_rowneq; auto. - - apply valid_check_ext; auto. - - apply valid_check_hole; auto. - - apply valid_check_forall_inst with lemma; auto. + |pos res |pos prem_id prem concl p|pos lemma plemma concl p]; simpl; try apply S.valid_set_clause; auto with smtcoq_core. + - apply S.valid_set_resolve; auto with smtcoq_core. + - apply S.valid_set_weaken; auto with smtcoq_core. + - apply valid_check_flatten; auto with smtcoq_core; intros h1 h2 H. + + rewrite (Syntactic.check_hatom_correct_bool _ _ _ Ha1 Ha2 _ _ H); auto with smtcoq_core. + + rewrite (Syntactic.check_neg_hatom_correct_bool _ _ _ H10 Ha1 Ha2 _ _ H); auto with smtcoq_core. + - apply valid_check_True; auto with smtcoq_core. + - apply valid_check_False; auto with smtcoq_core. + - apply valid_check_BuildDef; auto with smtcoq_core. + - apply valid_check_BuildDef2; auto with smtcoq_core. + - apply valid_check_BuildProj; auto with smtcoq_core. + - apply valid_check_ImmBuildDef; auto with smtcoq_core. + - apply valid_check_ImmBuildDef2; auto with smtcoq_core. + - apply valid_check_ImmBuildProj; auto with smtcoq_core. + - apply valid_check_trans; auto with smtcoq_core. + - apply valid_check_congr; auto with smtcoq_core. + - apply valid_check_congr_pred; auto with smtcoq_core. + - apply valid_check_micromega; auto with smtcoq_core. + - apply valid_check_diseq; auto with smtcoq_core. + - apply valid_check_spl_arith; auto with smtcoq_core. + - apply valid_check_distinct_elim; auto with smtcoq_core. + - eapply valid_check_bbVar; eauto with smtcoq_core. + - apply valid_check_bbConst; auto with smtcoq_core. + - apply valid_check_bbOp; auto with smtcoq_core. + - apply valid_check_bbNot; auto with smtcoq_core. + - apply valid_check_bbNeg; auto with smtcoq_core. + - apply valid_check_bbAdd; auto with smtcoq_core. + - apply valid_check_bbConcat; auto with smtcoq_core. + - apply valid_check_bbMult; auto with smtcoq_core. + - apply valid_check_bbUlt; auto with smtcoq_core. + - apply valid_check_bbSlt; auto with smtcoq_core. + - apply valid_check_bbEq; auto with smtcoq_core. + - apply valid_check_bbDiseq; auto with smtcoq_core. + - apply valid_check_bbExtract; auto with smtcoq_core. + - apply valid_check_bbZextend; auto with smtcoq_core. + - apply valid_check_bbSextend; auto with smtcoq_core. + - apply valid_check_bbShl; auto with smtcoq_core. + - apply valid_check_bbShr; auto with smtcoq_core. + - apply valid_check_roweq; auto with smtcoq_core. + - apply valid_check_rowneq; auto with smtcoq_core. + - apply valid_check_ext; auto with smtcoq_core. + - apply valid_check_hole; auto with smtcoq_core. + - apply valid_check_forall_inst with lemma; auto with smtcoq_core. Qed. Definition euf_checker (* t_atom t_form *) s t := @@ -490,8 +490,8 @@ Inductive step := ~ (S.valid rho s). Proof. unfold euf_checker; intros (* t_i t_func t_atom t_form *) rho H1 H2 H10; apply _checker__correct. - intros c H; apply C.is_false_correct; auto. - apply step_checker_correct; auto. + intros c H; apply C.is_false_correct; auto with smtcoq_core. + apply step_checker_correct; auto with smtcoq_core. Qed. Inductive certif := @@ -516,11 +516,11 @@ Inductive step := forall s d used_roots, S.valid rho s -> valid t_func t_atom t_form d -> S.valid rho (add_roots s d used_roots). Proof. - intros (* t_i t_func t_atom t_form *) rho H1 H2 H10 s d used_roots H3; unfold valid; intro H4; pose (H5 := (afold_left_andb_true_inv _ _ _ H4)); unfold add_roots; assert (Valuation.wf rho) by (destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H]; auto); case used_roots. - intro ur; apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i H6 Ha; apply S.valid_set_clause; auto; case_eq (ur .[ i] < length d). - intro; unfold C.valid; simpl; rewrite H5; auto. - intros; apply C.interp_true; auto. - apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto; intros a i H6 Ha; apply S.valid_set_clause; auto; unfold C.valid; simpl; rewrite H5; auto. + intros (* t_i t_func t_atom t_form *) rho H1 H2 H10 s d used_roots H3; unfold valid; intro H4; pose (H5 := (afold_left_andb_true_inv _ _ _ H4)); unfold add_roots; assert (Valuation.wf rho) by (destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H]; auto with smtcoq_core); case used_roots. + intro ur; apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto with smtcoq_core; intros a i H6 Ha; apply S.valid_set_clause; auto with smtcoq_core; case_eq (ur .[ i] < length d). + intro; unfold C.valid; simpl; rewrite H5; auto with smtcoq_core. + intros; apply C.interp_true; auto with smtcoq_core. + apply (foldi_right_Ind _ _ (fun _ a => S.valid rho a)); auto with smtcoq_core; intros a i H6 Ha; apply S.valid_set_clause; auto with smtcoq_core; unfold C.valid; simpl; rewrite H5; auto with smtcoq_core. Qed. Definition checker (* t_i t_func t_atom t_form *) d used_roots (c:certif) := @@ -711,7 +711,7 @@ Inductive step := checker (* t_i t_func t_atom t_form *) d used_roots c = true -> ~ (valid t_func t_atom t_form d). Proof. - unfold checker; intros (* t_i t_func t_atom t_form *) d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[[H1 H2] H10] H3] H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H4]; auto. + unfold checker; intros (* t_i t_func t_atom t_form *) d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[[H1 H2] H10] H3] H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H1) as [_ H4]; auto with smtcoq_core. Qed. Definition checker_b (* t_i t_func t_atom t_form *) l (b:bool) (c:certif) := @@ -723,7 +723,7 @@ Inductive step := checker_b (* t_func t_atom t_form *) l b c = true -> Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l = b. Proof. - unfold checker_b; intros (* t_i t_func t_atom t_form *) l b (nclauses, t, confl); case b; intros H2; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l); auto; intros H1; elim (checker_correct H2); auto; unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; auto; rewrite Lit.interp_neg, H1; auto. + unfold checker_b; intros (* t_i t_func t_atom t_form *) l b (nclauses, t, confl); case b; intros H2; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l); auto with smtcoq_core; intros H1; elim (checker_correct H2); auto with smtcoq_core; unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; auto with smtcoq_core; rewrite Lit.interp_neg, H1; auto with smtcoq_core. Qed. Definition checker_eq (* t_i t_func t_atom t_form *) l1 l2 l (c:certif) := @@ -741,8 +741,8 @@ Inductive step := Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l2. Proof. unfold checker_eq; intros (* t_i t_func t_atom t_form *) l1 l2 l (nclauses, t, confl); rewrite !andb_true_iff; case_eq (t_form .[ Lit.blit l]); [intros _ _|intros _|intros _|intros _ _ _|intros _ _|intros _ _|intros _ _|intros _ _ _|intros l1' l2' Heq|intros _ _ _ _|intros a ls Heq]; intros [[H1 H2] H3]; try discriminate; rewrite andb_true_iff in H2; rewrite !Int63Properties.eqb_spec in H2; destruct H2 as [H2 H4]; subst l1' l2'; case_eq (Lit.is_pos l); intro Heq'; rewrite Heq' in H1; try discriminate; clear H1; assert (H:PArray.default t_form = Form.Ftrue /\ Form.wf t_form). - unfold checker in H3; rewrite !andb_true_iff in H3; destruct H3 as [[[H3 _] _] _]; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H3) as [[Ht1 Ht2] Ht3]; split; auto. - destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l2); intro Heq2; auto; elim (checker_correct H3); unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite Heq; simpl; rewrite Heq1, Heq2; auto. + unfold checker in H3; rewrite !andb_true_iff in H3; destruct H3 as [[[H3 _] _] _]; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) _ H3) as [[Ht1 Ht2] Ht3]; split; auto with smtcoq_core. + destruct H as [H1 H2]; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l1); intro Heq1; case_eq (Lit.interp (Form.interp_state_var (Atom.interp_form_hatom t_i t_func t_atom) (Atom.interp_form_hatom_bv t_i t_func t_atom) t_form) l2); intro Heq2; auto with smtcoq_core; elim (checker_correct H3); unfold valid; apply afold_left_andb_true; intros i Hi; rewrite get_make; unfold Lit.interp; rewrite Heq'; unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_core; rewrite Heq; simpl; rewrite Heq1, Heq2; auto with smtcoq_core. Qed. @@ -762,7 +762,7 @@ Inductive step := forall t_i t_func, Atom.wt t_i t_func t_atom -> ~ valid t_func t_atom t_form d. Proof. - unfold checker_ext; intros t_atom t_form d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[H1 H2] H3]; intros t_i t_func H10 H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [_ H4]; auto. + unfold checker_ext; intros t_atom t_form d used_roots (nclauses, t, confl); rewrite !andb_true_iff; intros [[H1 H2] H3]; intros t_i t_func H10 H; eelim euf_checker_correct; try eassumption; apply add_roots_correct; try eassumption; apply S.valid_make; destruct (Form.check_form_correct (Atom.interp_form_hatom t_i t_func t_atom) _ H1) as [_ H4]; auto with smtcoq_core. Qed. *) diff --git a/src/array/FArray.v b/src/array/FArray.v index a17817f..8048e60 100644 --- a/src/array/FArray.v +++ b/src/array/FArray.v @@ -44,7 +44,7 @@ Module Raw. Lemma eqb_elt_eq x y : eqb_elt x y = true <-> x = y. Proof. unfold eqb_elt. case (eq_dec x y); split; easy. Qed. - Hint Immediate eqb_key_eq eqb_elt_eq. + Hint Immediate eqb_key_eq eqb_elt_eq : smtcoq_array. Definition farray := list (key * elt). @@ -57,8 +57,8 @@ Module Raw. (* Definition ltke (a b : (key * elt)) := *) (* lt (fst a) (fst b) \/ ( (fst a) = (fst b) /\ lt (snd a) (snd b)). *) - Hint Unfold ltk (* ltke *) eqk eqke. - Hint Extern 2 (eqke ?a ?b) => split. + Hint Unfold ltk (* ltke *) eqk eqke : smtcoq_array. + Hint Extern 2 (eqke ?a ?b) => split : smtcoq_array. Global Instance lt_key_strorder : StrictOrder (lt : key -> key -> Prop). Proof. apply StrictOrder_OrdType. Qed. @@ -95,7 +95,7 @@ Module Raw. Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l. + Hint Immediate ltk_right_r ltk_right_l : smtcoq_array. Notation Sort := (sort ltk). Notation Inf := (lelistA (ltk)). @@ -105,7 +105,7 @@ Module Raw. Notation NoDupA := (NoDupA eqk). - Hint Unfold MapsTo In. + Hint Unfold MapsTo In : smtcoq_array. (* Instance ke_ord: OrdType (key * elt). *) (* Proof. *) @@ -154,52 +154,52 @@ Module Raw. (* eqk, eqke are equalities *) Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. + Proof. auto with smtcoq_array. Qed. Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. + Proof. auto with smtcoq_array. Qed. Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. + Proof. auto with smtcoq_array. Qed. Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. Proof. unfold eqke; intuition. Qed. Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. + Proof. eauto with smtcoq_array. Qed. Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. Proof. - unfold eqke; intuition; [ eauto | congruence ]. + unfold eqke; intuition; [ eauto with smtcoq_array | congruence ]. Qed. Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto. Qed. + Proof. eauto with smtcoq_array. Qed. Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold ltk, eqk. intros. apply lt_not_eq; auto. Qed. + Proof. unfold ltk, eqk. intros. apply lt_not_eq; auto with smtcoq_array. Qed. Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. unfold eqke, ltk; intuition; simpl in *; subst. - apply lt_not_eq in H. auto. + apply lt_not_eq in H. auto with smtcoq_array. Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : smtcoq_array. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : smtcoq_array. + Hint Immediate eqk_sym eqke_sym : smtcoq_array. Global Instance eqk_equiv : Equivalence eqk. - Proof. split; eauto. Qed. + Proof. split; eauto with smtcoq_array. Qed. Global Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto. Qed. + Proof. split; eauto with smtcoq_array. Qed. Global Instance ltk_strorder : StrictOrder ltk. Proof. split. unfold Irreflexive, Reflexive, complement. - intros. apply lt_not_eq in H; auto. + intros. apply lt_not_eq in H; auto with smtcoq_array. unfold Transitive. intros x y z. apply lt_trans. Qed. @@ -207,13 +207,13 @@ Module Raw. (* Proof. *) (* split. *) (* unfold Irreflexive, Reflexive, complement. *) - (* intros. apply lt_not_eq in H; auto. *) + (* intros. apply lt_not_eq in H; auto with smtcoq_array. *) (* unfold Transitive. apply lt_trans. *) (* Qed. *) Global Instance eq_equiv : @Equivalence (key * elt) eq. Proof. - split; auto. + split; auto with smtcoq_array. unfold Transitive. apply eq_trans. Qed. @@ -230,13 +230,13 @@ Module Raw. Global Instance ltk_compatk : Proper (eqk==>eqk==>iff) ltk. Proof. intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto with smtcoq_array. Qed. Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk. Proof. intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute. - compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. + compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto with smtcoq_array. Qed. Global Instance ltk_asym : Asymmetric ltk. @@ -251,8 +251,8 @@ Module Raw. destruct x, x'. simpl in *. intro. symmetry in H. - apply lt_not_eq in H. auto. - subst. auto. + apply lt_not_eq in H. auto with smtcoq_array. + subst. auto with smtcoq_array. Qed. Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. @@ -265,8 +265,8 @@ Module Raw. intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; intros; subst; trivial. Qed. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. + Hint Resolve eqk_not_ltk : smtcoq_array. + Hint Immediate ltk_eqk eqk_ltk : smtcoq_array. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. @@ -274,19 +274,19 @@ Module Raw. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk. + Hint Resolve InA_eqke_eqk : smtcoq_array. (* Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. *) (* Proof. *) - (* intros; apply InA_eqA with p; auto with *. *) + (* intros; apply InA_eqA with p; auto with smtcoq_array with *. *) (* Qed. *) (* Lemma In_eq : forall l x y, eq x y -> InA eqke x l -> InA eqke y l. *) - (* Proof. intros. rewrite <- H; auto. Qed. *) + (* Proof. intros. rewrite <- H; auto with smtcoq_array. Qed. *) (* Lemma ListIn_In : forall l x, List.In x l -> InA eqk x l. *) - (* Proof. apply In_InA. split; auto. unfold Transitive. *) - (* unfold eqk; intros. rewrite H, <- H0. auto. *) + (* Proof. apply In_InA. split; auto with smtcoq_array. unfold Transitive. *) + (* unfold eqk; intros. rewrite H, <- H0. auto with smtcoq_array. *) (* Qed. *) (* Lemma Inf_lt : forall l x y, ltk x y -> Inf y l -> Inf x l. *) @@ -300,12 +300,12 @@ Module Raw. Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. firstorder. - exists x; auto. + exists x; auto with smtcoq_array. induction H. destruct y. - exists e; auto. + exists e; auto with smtcoq_array. destruct IHInA as [e H0]. - exists e; auto. + exists e; auto with smtcoq_array. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. @@ -315,7 +315,7 @@ Module Raw. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. + destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto with smtcoq_array. Qed. Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. @@ -324,8 +324,8 @@ Module Raw. Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. + Hint Immediate Inf_eq : smtcoq_array. + Hint Resolve Inf_lt : smtcoq_array. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -339,11 +339,11 @@ Module Raw. intros; red; intros. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). - eapply Sort_Inf_In; eauto. - red; simpl; auto. + eapply Sort_Inf_In; eauto with smtcoq_array. + red; simpl; auto with smtcoq_array. Qed. - Hint Resolve Sort_Inf_NotIn. + Hint Resolve Sort_Inf_NotIn : smtcoq_array. Lemma Sort_NoDupA: forall l, Sort l -> NoDupA l. Proof. @@ -352,14 +352,14 @@ Module Raw. Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. Proof. - inversion 1; intros; eapply Sort_Inf_In; eauto. + inversion 1; intros; eapply Sort_Inf_In; eauto with smtcoq_array. Qed. Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. - inversion_clear 2; auto. - left; apply Sort_In_cons_1 with l; auto. + inversion_clear 2; auto with smtcoq_array. + left; apply Sort_In_cons_1 with l; auto with smtcoq_array. Qed. Lemma Sort_In_cons_3 : @@ -372,7 +372,7 @@ Module Raw. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. inversion 1. - inversion_clear H0; eauto. + inversion_clear H0; eauto with smtcoq_array. destruct H1; simpl in *; intuition. Qed. @@ -388,7 +388,7 @@ Module Raw. inversion_clear 1; compute in H0; intuition. Qed. - Hint Resolve In_inv_2 In_inv_3. + Hint Resolve In_inv_2 In_inv_3 : smtcoq_array. (** * FMAPLIST interface implementaion *) @@ -405,11 +405,11 @@ Module Raw. intro abs. inversion abs. Qed. - Hint Resolve empty_1. + Hint Resolve empty_1 : smtcoq_array. Lemma empty_sorted : Sort empty. Proof. - unfold empty; auto. + unfold empty; auto with smtcoq_array. Qed. Lemma MapsTo_inj : forall x e e' l (Hl:Sort l), @@ -441,7 +441,7 @@ Module Raw. + unfold eqk in H, H0. simpl in *. subst. inversion_clear HH. inversion_clear HH0. - unfold eqke in *. simpl in *. destruct H, H1; subst; auto. + unfold eqke in *. simpl in *. destruct H, H1; subst; auto with smtcoq_array. apply InA_eqke_eqk in H1. inversion_clear Hl. specialize (Sort_Inf_In H2 H3 H1). @@ -460,15 +460,15 @@ Module Raw. Proof. unfold Empty, MapsTo. intros m. - case m;auto. + case m;auto with smtcoq_array. intros (k,e) l inlist. - absurd (InA eqke (k, e) ((k, e) :: l));auto. + absurd (InA eqke (k, e) ((k, e) :: l));auto with smtcoq_array. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. Proof. intros m. - case m;auto. + case m;auto with smtcoq_array. intros p l abs. inversion abs. Qed. @@ -494,15 +494,15 @@ Module Raw. - simpl. case_eq (compare x k'); trivial. + intros _x0 e0. absurd (In x ((k', _x) :: l));try assumption. - apply Sort_Inf_NotIn with _x;auto. + apply Sort_Inf_NotIn with _x;auto with smtcoq_array. + intros _x0 e0. apply IHb. - elim (sort_inv sorted);auto. - elim (In_inv belong1);auto. + elim (sort_inv sorted);auto with smtcoq_array. + elim (In_inv belong1);auto with smtcoq_array. intro abs. - absurd (eq x k'); auto. + absurd (eq x k'); auto with smtcoq_array. symmetry in abs. - apply lt_not_eq in abs; auto. + apply lt_not_eq in abs; auto with smtcoq_array. Qed. Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. @@ -510,10 +510,10 @@ Module Raw. intros m Hm x; generalize Hm; clear Hm; unfold In,MapsTo. induction m as [ |[k' _x] l IHb]; intros sorted hyp;try ((inversion hyp);fail). revert hyp. simpl. case_eq (compare x k'); intros _x0 e0 hyp;try ((inversion hyp);fail). - - exists _x; auto. - - induction IHb; auto. - + exists x0; auto. - + inversion_clear sorted; auto. + - exists _x; auto with smtcoq_array. + - induction IHb; auto with smtcoq_array. + + exists x0; auto with smtcoq_array. + + inversion_clear sorted; auto with smtcoq_array. Qed. Lemma mem_3 : forall m (Hm:Sort m) x, mem x m = false -> ~ In x m. @@ -539,8 +539,8 @@ Module Raw. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x. unfold MapsTo. - induction m as [ |[k' _x] l IHb];simpl; intro e';try now (intro eqfind; inversion eqfind; auto). - case_eq (compare x k'); intros _x0 e0 eqfind; inversion eqfind; auto. + induction m as [ |[k' _x] l IHb];simpl; intro e';try now (intro eqfind; inversion eqfind; auto with smtcoq_array). + case_eq (compare x k'); intros _x0 e0 eqfind; inversion eqfind; auto with smtcoq_array. Qed. Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. @@ -551,11 +551,11 @@ Module Raw. - case_eq (compare x k'); intros _x0 e1; subst. + inversion_clear 2. * clear e1;compute in H0; destruct H0. - apply lt_not_eq in H; auto. now contradict H. + apply lt_not_eq in H; auto with smtcoq_array. now contradict H. * clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute. (* order. *) intros. - apply (lt_trans k') in _x0; auto. + apply (lt_trans k') in _x0; auto with smtcoq_array. apply lt_not_eq in _x0. now contradict _x0. + clear e1;inversion_clear 2. @@ -564,7 +564,7 @@ Module Raw. (* order. *) intros. apply lt_not_eq in H. now contradict H. - + clear e1; do 2 inversion_clear 1; auto. + + clear e1; do 2 inversion_clear 1; auto with smtcoq_array. compute in H2; destruct H2. (* order. *) subst. apply lt_not_eq in _x0. now contradict _x0. @@ -587,7 +587,7 @@ Module Raw. Proof. intros m x y e; generalize y; clear y. unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1]; simpl; auto. + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1]; simpl; auto with smtcoq_array. Qed. Lemma add_2 : forall m x y e e', @@ -595,14 +595,14 @@ Module Raw. Proof. intros m x y e e'. generalize y e; clear y e; unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e0];simpl;auto; clear e0. - subst;auto. + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e0];simpl;auto with smtcoq_array; clear e0. + subst;auto with smtcoq_array. intros y' e'' eqky'; inversion_clear 1; destruct H0; simpl in *. (* order. *) subst. now contradict eqky'. - auto. - auto. + auto with smtcoq_array. + auto with smtcoq_array. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. @@ -611,10 +611,10 @@ Module Raw. Proof. intros m x y e e'. generalize y e; clear y e; unfold MapsTo. induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];simpl; intros. - apply (In_inv_3 H0); compute; auto. - apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. - inversion_clear H0; auto. + apply (In_inv_3 H0); compute; auto with smtcoq_array. + apply (In_inv_3 H0); compute; auto with smtcoq_array. + constructor 2; apply (In_inv_3 H0); compute; auto with smtcoq_array. + inversion_clear H0; auto with smtcoq_array. Qed. Lemma add_Inf : forall (m:farray)(x x':key)(e e':elt), @@ -628,7 +628,7 @@ Module Raw. compute in H0,H1. simpl; case (compare x x''); intuition. Qed. - Hint Resolve add_Inf. + Hint Resolve add_Inf : smtcoq_array. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). Proof. @@ -636,9 +636,9 @@ Module Raw. simpl; intuition. intros. destruct a as (x',e'). - simpl; case (compare x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. + simpl; case (compare x x'); intuition; inversion_clear Hm; auto with smtcoq_array. + constructor; auto with smtcoq_array. + apply Inf_eq with (x',e'); auto with smtcoq_array. Qed. (** * [remove] *) @@ -661,22 +661,22 @@ Module Raw. red; inversion 1; inversion H0. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto with smtcoq_array. clear e0. inversion Hm. subst. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto with smtcoq_array. (* clear e0;inversion_clear Hm. *) - (* apply Sort_Inf_NotIn with x0; auto. *) - (* apply Inf_eq with (k',x0);auto; compute; apply eq_trans with x; auto. *) + (* apply Sort_Inf_NotIn with x0; auto with smtcoq_array. *) + (* apply Inf_eq with (k',x0);auto with smtcoq_array; compute; apply eq_trans with x; auto with smtcoq_array. *) clear e0;inversion_clear Hm. - assert (notin:~ In y (remove y l)) by auto. + assert (notin:~ In y (remove y l)) by auto with smtcoq_array. intros (x1,abs). inversion_clear abs. compute in H1; destruct H1. subst. apply lt_not_eq in _x; now contradict _x. - apply notin; exists x1; auto. + apply notin; exists x1; auto with smtcoq_array. Qed. @@ -684,41 +684,41 @@ Module Raw. ~ eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto; + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto with smtcoq_array; match goal with | [H: compare _ _ = _ |- _ ] => clear H | _ => idtac end. - inversion_clear 3; auto. + inversion_clear 3; auto with smtcoq_array. compute in H1; destruct H1. subst; now contradict H. - inversion_clear 1; inversion_clear 2; auto. + inversion_clear 1; inversion_clear 2; auto with smtcoq_array. Qed. Lemma remove_3 : forall m (Hm:Sort m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold MapsTo. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto. - inversion_clear 1; inversion_clear 1; auto. + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto with smtcoq_array. + inversion_clear 1; inversion_clear 1; auto with smtcoq_array. Qed. Lemma remove_4_aux : forall m (Hm:Sort m) x y, ~ eq x y -> In y m -> In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. - induction m as [ |[k' x0] l IHf]; simpl; [ |case_eq (compare x k'); intros _x e1];subst;auto; + induction m as [ |[k' x0] l IHf]; simpl; [ |case_eq (compare x k'); intros _x e1];subst;auto with smtcoq_array; match goal with | [H: compare _ _ = _ |- _ ] => clear H | _ => idtac end. rewrite In_alt. - inversion_clear 3; auto. + inversion_clear 3; auto with smtcoq_array. inversion H2. unfold eqk in H3. simpl in H3. subst. now contradict H0. apply In_alt. - exists x. auto. + exists x. auto with smtcoq_array. apply lt_not_eq in _x. intros. inversion_clear Hm. @@ -729,27 +729,27 @@ Module Raw. destruct (eq_dec k' y). exists x0. apply InA_cons_hd. - split; simpl; auto. + split; simpl; auto with smtcoq_array. inversion H3. unfold eqk in H4. simpl in H4; subst. now contradict n. assert ((exists e : elt, MapsTo y e (remove x l)) -> (exists e : elt, MapsTo y e ((k', x0) :: remove x l))). intros. destruct H6. exists x2. - apply InA_cons_tl. auto. + apply InA_cons_tl. auto with smtcoq_array. apply H6. - apply IHf; auto. + apply IHf; auto with smtcoq_array. apply In_alt. - exists x1. auto. + exists x1. auto with smtcoq_array. Qed. Lemma remove_4 : forall m (Hm:Sort m) x y, ~ eq x y -> In y m <-> In y (remove x m). Proof. split. - apply remove_4_aux; auto. + apply remove_4_aux; auto with smtcoq_array. revert H. generalize Hm; clear Hm. - induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto; + induction m as [ |[k' _x] l IHb]; simpl; [ |case_eq (compare x k'); intros _x0 e1];subst;auto with smtcoq_array; match goal with | [H: compare _ _ = _ |- _ ] => clear H | _ => idtac @@ -758,7 +758,7 @@ Module Raw. (* rewrite In_alt in *. *) destruct H0 as (e, H0). exists e. - apply InA_cons_tl. auto. + apply InA_cons_tl. auto with smtcoq_array. intros. apply lt_not_eq in _x0. inversion_clear Hm. @@ -766,11 +766,11 @@ Module Raw. destruct H0. (* destruct (eq_dec k' y). *) exists _x. - apply InA_cons_hd. split; simpl; auto. + apply InA_cons_hd. split; simpl; auto with smtcoq_array. specialize (IHb H1 H H0). inversion IHb. exists x0. - apply InA_cons_tl. auto. + apply InA_cons_tl. auto with smtcoq_array. Qed. Lemma remove_Inf : forall (m:farray)(Hm : Sort m)(x x':key)(e':elt), @@ -784,9 +784,9 @@ Module Raw. compute in H0. simpl; case (compare x x''); intuition. inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. + apply Inf_lt with (x'',e''); auto with smtcoq_array. Qed. - Hint Resolve remove_Inf. + Hint Resolve remove_Inf : smtcoq_array. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). Proof. @@ -794,7 +794,7 @@ Module Raw. simpl; intuition. intros. destruct a as (x',e'). - simpl; case (compare x x'); intuition; inversion_clear Hm; auto. + simpl; case (compare x x'); intuition; inversion_clear Hm; auto with smtcoq_array. Qed. (** * [elements] *) @@ -804,25 +804,25 @@ Module Raw. Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. - auto. + auto with smtcoq_array. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. Proof. - auto. + auto with smtcoq_array. Qed. Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). Proof. - auto. + auto with smtcoq_array. Qed. Lemma elements_3w : forall m (Hm:Sort m), NoDupA (elements m). Proof. intros. apply Sort_NoDupA. - apply elements_3; auto. + apply elements_3; auto with smtcoq_array. Qed. (** * [fold] *) @@ -836,7 +836,7 @@ Module Raw. Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. - intros; revert i; induction m as [ |[k e]]; simpl; auto. + intros; revert i; induction m as [ |[k e]]; simpl; auto with smtcoq_array. Qed. (** * [equal] *) @@ -860,7 +860,7 @@ Module Raw. Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; auto; unfold Equivb; intuition; subst. + revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; auto with smtcoq_array; unfold Equivb; intuition; subst. - destruct (H0 x') as [_ H3]. assert (H2: In x' nil). { @@ -873,53 +873,53 @@ Module Raw. apply H3. exists e. now constructor. } elim H2. intros x0 Hx0. inversion Hx0. - - case_eq (compare x x'); simpl; subst;auto; unfold Equivb; + - case_eq (compare x x'); simpl; subst;auto with smtcoq_array; unfold Equivb; intuition; subst. + destruct (H0 x). assert (In x ((x',e')::l')). - apply H2; auto. - exists e; auto. + apply H2; auto with smtcoq_array. + exists e; auto with smtcoq_array. destruct (In_inv H4). (* order. *) clear H. apply lt_not_eq in l0; now contradict l0. inversion_clear Hm'. assert (Inf (x,e) l'). - apply Inf_lt with (x',e'); auto. + apply Inf_lt with (x',e'); auto with smtcoq_array. elim (Sort_Inf_NotIn H6 H8 H5). + match goal with H: compare _ _ = _ |- _ => clear H end. assert (cmp_e_e':cmp e e' = true). - apply H1 with x'; auto. + apply H1 with x'; auto with smtcoq_array. rewrite cmp_e_e'; simpl. - apply IHl; auto. - inversion_clear Hm; auto. - inversion_clear Hm'; auto. + apply IHl; auto with smtcoq_array. + inversion_clear Hm; auto with smtcoq_array. + inversion_clear Hm'; auto with smtcoq_array. unfold Equivb; intuition. destruct (H0 k). assert (In k ((x',e) ::l)). - destruct H as (e'', hyp); exists e''; auto. - destruct (In_inv (H2 H4)); auto. + destruct H as (e'', hyp); exists e''; auto with smtcoq_array. + destruct (In_inv (H2 H4)); auto with smtcoq_array. inversion_clear Hm. elim (Sort_Inf_NotIn H6 H7). - destruct H as (e'', hyp); exists e''; auto. - apply MapsTo_eq with k; auto. + destruct H as (e'', hyp); exists e''; auto with smtcoq_array. + apply MapsTo_eq with k; auto with smtcoq_array. destruct (H0 k). assert (In k ((x',e') ::l')). - destruct H as (e'', hyp); exists e''; auto. - destruct (In_inv (H3 H4)); auto. + destruct H as (e'', hyp); exists e''; auto with smtcoq_array. + destruct (In_inv (H3 H4)); auto with smtcoq_array. subst. inversion_clear Hm'. now elim (Sort_Inf_NotIn H5 H6). - apply H1 with k; destruct (eq_dec x' k); auto. + apply H1 with k; destruct (eq_dec x' k); auto with smtcoq_array. + destruct (H0 x'). assert (In x' ((x,e)::l)). - apply H3; auto. - exists e'; auto. + apply H3; auto with smtcoq_array. + exists e'; auto with smtcoq_array. destruct (In_inv H4). (* order. *) clear H; subst; apply lt_not_eq in l0; now contradict l0. inversion_clear Hm. assert (Inf (x',e') l). - apply Inf_lt with (x,e); auto. + apply Inf_lt with (x,e); auto with smtcoq_array. elim (Sort_Inf_NotIn H6 H8 H5). Qed. @@ -927,7 +927,7 @@ Module Raw. equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; subst;auto; unfold Equivb; + revert m'; induction m as [ |[x e] l IHl]; intros [ |[x' e'] l']; simpl; subst;auto with smtcoq_array; unfold Equivb; intuition; try discriminate; subst; try match goal with H: compare _ _ = _ |- _ => clear H end. - inversion H0. @@ -936,19 +936,19 @@ Module Raw. destruct (andb_prop _ _ H); clear H. destruct (IHl _ H1 H4 H7). destruct (In_inv H0). - exists e'; constructor; split; trivial; apply eq_trans with x; auto. + exists e'; constructor; split; trivial; apply eq_trans with x; auto with smtcoq_array. destruct (H k). destruct (H10 H9) as (e'',hyp). - exists e''; auto. + exists e''; auto with smtcoq_array. - revert H; case_eq (compare x x'); intros _x _ H; try inversion H. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHl _ H1 H4 H7). destruct (In_inv H0). - exists e; constructor; split; trivial; apply eq_trans with x'; auto. + exists e; constructor; split; trivial; apply eq_trans with x'; auto with smtcoq_array. destruct (H k). destruct (H11 H9) as (e'',hyp). - exists e''; auto. + exists e''; auto with smtcoq_array. - revert H; case_eq (compare x x'); intros _x _ H; [inversion H| |inversion H]. inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. @@ -956,16 +956,16 @@ Module Raw. inversion_clear H0. + destruct H9; simpl in *; subst. inversion_clear H1. - * destruct H0; simpl in *; subst; auto. + * destruct H0; simpl in *; subst; auto with smtcoq_array. * elim (Sort_Inf_NotIn H4 H5). - exists e'0; apply MapsTo_eq with x'; auto. + exists e'0; apply MapsTo_eq with x'; auto with smtcoq_array. (* order. *) + inversion_clear H1. - * destruct H0; simpl in *; subst; auto. + * destruct H0; simpl in *; subst; auto with smtcoq_array. elim (Sort_Inf_NotIn H2 H3). - exists e0; apply MapsTo_eq with x'; auto. + exists e0; apply MapsTo_eq with x'; auto with smtcoq_array. (* order. *) - * apply H8 with k; auto. + * apply H8 with k; auto with smtcoq_array. Qed. (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) @@ -979,18 +979,18 @@ Module Raw. inversion H0; subst. destruct x; destruct y; compute in H1, H2. split; intros. - apply equal_2; auto. + apply equal_2; auto with smtcoq_array. simpl. case (compare k k0); subst; intro HH; try (apply lt_not_eq in HH; now contradict HH). rewrite H2; simpl. - apply equal_1; auto. - apply equal_2; auto. + apply equal_1; auto with smtcoq_array. + apply equal_2; auto with smtcoq_array. generalize (equal_1 H H0 H3). simpl. case (compare k k0); subst; intro HH; try (apply lt_not_eq in HH; now contradict HH). - rewrite H2; simpl; auto. + rewrite H2; simpl; auto with smtcoq_array. Qed. End Array. @@ -1580,7 +1580,7 @@ Section FArray. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. Qed. - Hint Resolve add_neq_o. + Hint Resolve add_neq_o : smtcoq_array. Lemma MapsTo_fun : forall m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. @@ -1838,6 +1838,8 @@ Arguments extensionnality2 {_} {_} {_} {_} {_} {_} {_} {_} {_} _ _ _. Arguments select_at_diff {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} {_} _ _ _. +Declare Scope farray_scope. + Notation "a '[' i ']'" := (select a i) (at level 1, format "a [ i ]") : farray_scope. Notation "a '[' i '<-' v ']'" := (store a i v) (at level 1, format "a [ i <- v ]") : farray_scope. diff --git a/src/bva/BVList.v b/src/bva/BVList.v index a53970b..6d64190 100644 --- a/src/bva/BVList.v +++ b/src/bva/BVList.v @@ -2684,6 +2684,8 @@ Qed. End RAWBITVECTOR_LIST. +Declare Scope bv_scope. + Module BITVECTOR_LIST <: BITVECTOR. Include RAW2BITVECTOR(RAWBITVECTOR_LIST). diff --git a/src/bva/Bva_checker.v b/src/bva/Bva_checker.v index 180fbcf..50cb0c0 100644 --- a/src/bva/Bva_checker.v +++ b/src/bva/Bva_checker.v @@ -1554,7 +1554,7 @@ Proof. intros l a H. rewrite H. unfold RAWBITVECTOR_LIST.bv_eq, RAWBITVECTOR_LIST.size, RAWBITVECTOR_LIST.bits in *. - rewrite RAWBITVECTOR_LIST.List_eq_refl; auto. + rewrite RAWBITVECTOR_LIST.List_eq_refl; auto with smtcoq_core. apply inj_iff in wf0. now do 2 rewrite id' in wf0. Qed. diff --git a/src/configure.sh b/src/configure.sh index 21b7232..57a4161 100755 --- a/src/configure.sh +++ b/src/configure.sh @@ -8,7 +8,7 @@ rm -f ${pre}Makefile.conf rm -f ${pre}Makefile.local rm -f ${pre}smtcoq_plugin.ml4 rm -f ${pre}versions/native/Structures.v -rm -f ${pre}g_smtcoq.ml4 +rm -f ${pre}g_smtcoq.mlg rm -f ${pre}smtcoq_plugin.mlpack rm -f ${pre}Tactics.v rm -f ${pre}versions/standard/Int63/Int63.v @@ -28,7 +28,7 @@ if [ $@ -a $@ = -native ]; then else cp ${pre}versions/standard/_CoqProject ${pre}_CoqProject cp ${pre}versions/standard/Makefile.local ${pre}Makefile.local - cp ${pre}versions/standard/g_smtcoq_standard.ml4 ${pre}g_smtcoq.ml4 + cp ${pre}versions/standard/g_smtcoq_standard.mlg ${pre}g_smtcoq.mlg cp ${pre}versions/standard/smtcoq_plugin_standard.mlpack ${pre}smtcoq_plugin.mlpack cp ${pre}versions/standard/Int63/Int63_standard.v ${pre}versions/standard/Int63/Int63.v cp ${pre}versions/standard/Int63/Int63Native_standard.v ${pre}versions/standard/Int63/Int63Native.v @@ -39,4 +39,6 @@ else cp ${pre}versions/standard/Structures_standard.v ${pre}versions/standard/Structures.v cp ${pre}versions/standard/Tactics_standard.v ${pre}Tactics.v coq_makefile -f _CoqProject -o Makefile + # work around https://github.com/coq/coq/issues/12603 + sed -i 's/^CAMLDONTLINK=unix,str$/CAMLDONTLINK=num,str,unix,dynlink,threads/' Makefile fi diff --git a/src/euf/Euf.v b/src/euf/Euf.v index 7818246..5b4fa93 100644 --- a/src/euf/Euf.v +++ b/src/euf/Euf.v @@ -180,7 +180,7 @@ Section certif. apply C.interp_true. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form);trivial. Qed. - Hint Resolve valid_C_true. + Hint Resolve valid_C_true : smtcoq_euf. Local Notation interp := (Atom.interp t_i t_func t_atom). @@ -210,9 +210,9 @@ Section certif. C.interp rho (get_eq (Lit.blit l) f). Proof. intros l f Hf;unfold get_eq. - case_eq (t_form.[Lit.blit l]);trivial;intros. - case_eq (t_atom.[i]);trivial;intros. - destruct b;trivial. + case_eq (t_form.[Lit.blit l]);trivial with smtcoq_euf;intros. + case_eq (t_atom.[i]);trivial with smtcoq_euf;intros. + destruct b;trivial with smtcoq_euf. generalize wt_t_atom;unfold Atom.wt;unfold is_true; rewrite PArray.forallbi_spec;intros. assert (i < length t_atom). @@ -279,48 +279,48 @@ Section certif. C.interp rho (check_trans_aux t1 t2 eqs res c). Proof. induction eqs;simpl;intros. - apply get_eq_interp;intros. + - apply get_eq_interp;intros. match goal with |- context [if ?b then _ else _] => case_eq b end; - intros;trivial. + intros;trivial with smtcoq_euf. simpl;rewrite Lit.interp_lit;unfold Var.interp. - destruct H1;[ | rewrite H1,orb_true_r;auto]. + destruct H1;[ | rewrite H1,orb_true_r;auto with smtcoq_euf smtcoq_core]. rewrite orb_true_iff, !andb_true_iff in H7;destruct H7 as [[H7 H8] | [H7 H8]]. rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst. - tunicity. subst t. rewrite H4, H1;auto. + tunicity. subst t. rewrite H4, H1;auto with smtcoq_euf smtcoq_core. rewrite eqb_spec in H7. rewrite eqb_spec in H8. subst. - tunicity. subst t;rewrite interp_binop_eqb_sym in H1;rewrite H4, H1;auto. - apply get_eq_interp;intros. + tunicity. subst t;rewrite interp_binop_eqb_sym in H1;rewrite H4, H1;auto with smtcoq_euf smtcoq_core. + - apply get_eq_interp;intros. destruct (Int63Properties.reflect_eqb t2 b);subst;tunicity; try subst t. - apply (IHeqs u);trivial. + + apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (4:= H1);trivial. rewrite interp_binop_eqb_sym;trivial. - destruct (Int63Properties.reflect_eqb t2 a0); subst;tunicity; try subst t. - apply (IHeqs u);trivial. + + destruct (Int63Properties.reflect_eqb t2 a0); subst;tunicity; try subst t. + * apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (4:= H1);trivial. - destruct (Int63Properties.reflect_eqb t1 b);subst;tunicity; try subst t. - apply (IHeqs u);trivial. + * destruct (Int63Properties.reflect_eqb t1 b);subst;tunicity; try subst t. + -- apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (5:= H1);trivial. - destruct (Int63Properties.reflect_eqb t1 a0);[subst;tunicity;try subst t|auto]. + -- destruct (Int63Properties.reflect_eqb t1 a0);[subst;tunicity;try subst t|auto with smtcoq_euf smtcoq_core]. apply (IHeqs u);trivial. simpl;unfold is_true;rewrite orb_true_iff. rewrite Lit.interp_nlit;unfold Var.interp. - (* Attention ici on utilise la decidabilit'e de l'egalit'e sur u *) + (* Warning: here, we use decidability of equality over u *) case_eq (rho (Lit.blit a));[rewrite H4; intros | simpl;auto]. destruct H1;[left | auto]. apply interp_binop_eqb_trans with (5:= H1);trivial. @@ -332,9 +332,9 @@ Section certif. C.interp rho (check_trans res eqs). Proof. unfold check_trans;intros res [ | leq eqs]. - apply get_eq_interp;intros. + - apply get_eq_interp;intros. destruct (Int63Properties.reflect_eqb a b). - unfold C.interp; simpl; rewrite orb_false_r. + + unfold C.interp; simpl; rewrite orb_false_r. unfold Lit.interp; simpl; rewrite Lit.is_pos_lit. unfold Var.interp; simpl; rewrite Lit.blit_lit. rewrite H1. @@ -344,12 +344,12 @@ Section certif. unfold Atom.interp_hatom. rewrite HHb;simpl;rewrite Typ.cast_refl;simpl. apply Typ.i_eqb_refl. - auto. - apply get_eq_interp;intros. + + auto with smtcoq_euf. + - apply get_eq_interp;intros. apply check_trans_aux_correct with t;trivial. simpl;rewrite Lit.interp_nlit;unfold Var.interp. rewrite <- H1. (* Attention ici on utilise la decidabilit'e de l'egalit'e sur t *) - destruct (rho (Lit.blit leq));auto. + destruct (rho (Lit.blit leq));auto with smtcoq_core. Qed. Inductive Forall2 A B (P:A->B->Prop) : list A -> list B -> Prop := @@ -362,16 +362,16 @@ Section certif. (Forall2 _ _ (fun a b => interp_hatom a = interp_hatom b) l r -> C.interp rho c) -> C.interp rho (build_congr lp l r c). Proof. - induction lp;destruct l;destruct r;simpl;trivial;intros. + induction lp;destruct l;destruct r;simpl;trivial with smtcoq_euf smtcoq_core;intros. apply H;constructor. destruct a. apply get_eq_interp;intros. match goal with |- context [if ?x then _ else _] => - case_eq x;intros;auto end. + case_eq x;intros;auto with smtcoq_euf smtcoq_core end. apply IHlp;simpl;intros. rewrite Lit.interp_nlit;unfold Var.interp. - case_eq (rho (Lit.blit i1));intros;simpl;[ | auto]. - apply H;constructor;trivial. + case_eq (rho (Lit.blit i1));intros;simpl;[ | auto with smtcoq_euf smtcoq_core]. + apply H;constructor;trivial with smtcoq_euf smtcoq_core. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H3. rewrite Typ.eqb_spec in H4. unfold Atom.get_type in H3, H4. rewrite H3,H4. intros [va HHa] [vb HHb]. revert H7;rewrite H2;unfold Atom.apply_binop; simpl. unfold Atom.interp_hatom. @@ -381,11 +381,11 @@ Section certif. rewrite orb_true_iff, !andb_true_iff in H5;destruct H5 as [ [H5 H7] | [H5 H7]]. rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst. - rewrite HHa, HHb;trivial. + rewrite HHa, HHb;trivial with smtcoq_euf smtcoq_core. rewrite eqb_spec in H5. rewrite eqb_spec in H7. subst. - rewrite HHa, HHb;trivial. - destruct (Int63Properties.reflect_eqb i i0);[subst | auto]. - apply IHlp;intros;apply H;constructor;auto. + rewrite HHa, HHb;trivial with smtcoq_euf smtcoq_core. + destruct (Int63Properties.reflect_eqb i i0);[subst | auto with smtcoq_euf smtcoq_core]. + apply IHlp;intros;apply H;constructor;auto with smtcoq_euf smtcoq_core. Qed. Lemma valid_check_congr : @@ -393,71 +393,71 @@ Section certif. C.interp rho (check_congr leq eqs). Proof. unfold check_congr;intros leq eqs;apply get_eq_interp;intros. - case_eq (t_atom .[ a]);intros;auto; - case_eq (t_atom .[ b]);intros;auto. + case_eq (t_atom .[ a]);intros;auto with smtcoq_euf smtcoq_core; + case_eq (t_atom .[ b]);intros;auto with smtcoq_euf smtcoq_core. (* uop *) - destruct (Atom.reflect_uop_eqb u u0);[subst | auto]. + destruct (Atom.reflect_uop_eqb u u0);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;intros. simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp. rewrite H1. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb]. unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl. rewrite HHb, HHa. simpl. - rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa. - rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb. + rewrite Atom.t_interp_wf in HHa; auto with smtcoq_euf smtcoq_core. rewrite H4 in HHa. simpl in HHa. + rewrite Atom.t_interp_wf in HHb; auto with smtcoq_euf smtcoq_core. rewrite H5 in HHb. simpl in HHb. rewrite Typ.cast_refl;simpl. assert (Atom.Bval t_i t va = Atom.Bval t_i t vb). inversion H6;subst. unfold Atom.interp_hatom in H10. - rewrite <- HHa; rewrite <- HHb, H10;trivial. + rewrite <- HHa; rewrite <- HHb, H10;trivial with smtcoq_euf smtcoq_core. inversion H7. - apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial. + apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial with smtcoq_euf smtcoq_core. rewrite H9. apply Typ.i_eqb_refl. - intros x y;destruct (Typ.reflect_eqb x y);auto. + intros x y;destruct (Typ.reflect_eqb x y);auto with smtcoq_euf smtcoq_core. (* bop *) - destruct (Atom.reflect_bop_eqb b0 b1);[subst | auto]. + destruct (Atom.reflect_bop_eqb b0 b1);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;intros. simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp. rewrite H1. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb]. unfold Atom.apply_binop. unfold Atom.interp_hatom;simpl. rewrite HHb, HHa;simpl. - rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa. - rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb. + rewrite Atom.t_interp_wf in HHa; auto with smtcoq_euf smtcoq_core. rewrite H4 in HHa. simpl in HHa. + rewrite Atom.t_interp_wf in HHb; auto with smtcoq_euf smtcoq_core. rewrite H5 in HHb. simpl in HHb. rewrite Typ.cast_refl;simpl. assert (Atom.Bval t_i t va = Atom.Bval t_i t vb). inversion H6;clear H6;subst. inversion H12;clear H12;subst. unfold Atom.interp_hatom in H10, H8. - rewrite <- HHa. rewrite <- HHb, H10, H8;trivial. + rewrite <- HHa. rewrite <- HHb, H10, H8;trivial with smtcoq_euf smtcoq_core. inversion H7. - apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial. + apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial with smtcoq_euf smtcoq_core. rewrite H9. apply Typ.i_eqb_refl. - intros x y;destruct (Typ.reflect_eqb x y);auto. + intros x y;destruct (Typ.reflect_eqb x y);auto with smtcoq_euf smtcoq_core. (* op *) - destruct (Int63Properties.reflect_eqb i i0);[subst | auto]. + destruct (Int63Properties.reflect_eqb i i0);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;intros. simpl;rewrite Lit.interp_lit, orb_false_r;unfold Var.interp. rewrite H1. generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom b). rewrite Typ.eqb_spec in H2. rewrite Typ.eqb_spec in H3. unfold Atom.get_type in H2, H3. rewrite H2,H3. intros [va HHa] [vb HHb]. unfold Atom.apply_binop;unfold Atom.interp_hatom;simpl. rewrite HHb, HHa;simpl. - rewrite Atom.t_interp_wf in HHa; auto. rewrite H4 in HHa. simpl in HHa. - rewrite Atom.t_interp_wf in HHb; auto. rewrite H5 in HHb. simpl in HHb. + rewrite Atom.t_interp_wf in HHa; auto with smtcoq_euf smtcoq_core. rewrite H4 in HHa. simpl in HHa. + rewrite Atom.t_interp_wf in HHb; auto with smtcoq_euf smtcoq_core. rewrite H5 in HHb. simpl in HHb. rewrite Typ.cast_refl;simpl. assert (Atom.Bval t_i t va = Atom.Bval t_i t vb). rewrite <- HHa;rewrite <- HHb;destruct (t_func.[i0]). apply f_equal;clear HHa HHb va vb H5 H4. - induction H6;simpl;trivial. + induction H6;simpl;trivial with smtcoq_euf smtcoq_core. unfold Atom.interp_hatom in H4. - rewrite IHForall2, H4;trivial. + rewrite IHForall2, H4;trivial with smtcoq_euf smtcoq_core. inversion H7. - apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial. + apply Eqdep_dec.inj_pair2_eq_dec in H9;trivial with smtcoq_euf smtcoq_core. rewrite H9. apply Typ.i_eqb_refl. - intros x y;destruct (Typ.reflect_eqb x y);auto. + intros x y;destruct (Typ.reflect_eqb x y);auto with smtcoq_euf smtcoq_core. Qed. Lemma valid_check_congr_pred : @@ -465,11 +465,11 @@ Section certif. C.interp rho (check_congr_pred lpa lpb eqs). Proof. unfold check_congr_pred;intros. - case_eq (t_form.[Lit.blit lpa]);auto. - case_eq (t_form.[Lit.blit lpb]);auto;intros. - case_eq (t_atom.[i0]);auto; case_eq (t_atom.[i]);auto;intros. + case_eq (t_form.[Lit.blit lpa]);auto with smtcoq_euf smtcoq_core. + case_eq (t_form.[Lit.blit lpb]);auto with smtcoq_euf smtcoq_core;intros. + case_eq (t_atom.[i0]);auto with smtcoq_euf smtcoq_core; case_eq (t_atom.[i]);auto with smtcoq_euf smtcoq_core;intros. (* uop *) - destruct (Atom.reflect_uop_eqb u0 u);[subst | auto]. + destruct (Atom.reflect_uop_eqb u0 u);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;simpl;intros. rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp. replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)). @@ -485,12 +485,12 @@ Section certif. rewrite H2, def_t_atom;discriminate. apply H4 in H5;apply H4 in H6;clear H4. unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl. - rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial. + rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial with smtcoq_euf smtcoq_core. apply f_equal;apply f_equal. - inversion H3;clear H3;subst;trivial. + inversion H3;clear H3;subst;trivial with smtcoq_euf smtcoq_core. (* bop *) - destruct (Atom.reflect_bop_eqb b0 b);[subst | auto]. + destruct (Atom.reflect_bop_eqb b0 b);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;simpl;intros. rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp. replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)). @@ -506,13 +506,13 @@ Section certif. rewrite H2, def_t_atom;discriminate. apply H4 in H5;apply H4 in H6;clear H4. unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl. - rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial. + rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial with smtcoq_euf smtcoq_core. inversion H3;clear H3;subst. inversion H11;clear H11;subst. - apply f_equal; apply f_equal2;trivial. + apply f_equal; apply f_equal2;trivial with smtcoq_euf smtcoq_core. (* op *) - destruct (Int63Properties.reflect_eqb i2 i1);[subst | auto]. + destruct (Int63Properties.reflect_eqb i2 i1);[subst | auto with smtcoq_euf smtcoq_core]. apply build_congr_correct;simpl;intros. rewrite orb_false_r, Lit.interp_lit, Lit.interp_nlit;unfold Var.interp. replace (rho (Lit.blit lpb)) with (rho (Lit.blit lpa)). @@ -528,11 +528,11 @@ Section certif. rewrite H2, def_t_atom;discriminate. apply H4 in H5;apply H4 in H6;clear H4. unfold Atom.interp_form_hatom, Atom.interp_hatom;simpl. - rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial. + rewrite !Atom.t_interp_wf, H1, H2;simpl;trivial with smtcoq_euf smtcoq_core. apply f_equal;destruct (t_func.[i1]);apply f_equal. clear H H0 H1 H2 H5 H6. - induction H3;simpl;trivial. - unfold Atom.interp_hatom in H;rewrite H, IHForall2;trivial. + induction H3;simpl;trivial with smtcoq_euf smtcoq_core. + unfold Atom.interp_hatom in H;rewrite H, IHForall2;trivial with smtcoq_euf smtcoq_core. Qed. End Proof. diff --git a/src/lfsc/ast.ml b/src/lfsc/ast.ml index 454bc0a..36c2f79 100644 --- a/src/lfsc/ast.ml +++ b/src/lfsc/ast.ml @@ -198,7 +198,7 @@ let compare_symbol s1 s2 = match s1.sname, s2.sname with | Name n1, Name n2 -> Hstring.compare n1 n2 | Name _, _ -> -1 | _, Name _ -> 1 - | S_Hole i1, S_Hole i2 -> Pervasives.compare i1 i2 + | S_Hole i1, S_Hole i2 -> Stdlib.compare i1 i2 let rec compare_term ?(mod_eq=false) t1 t2 = match t1.value, t2.value with @@ -250,7 +250,7 @@ let rec compare_term ?(mod_eq=false) t1 t2 = match t1.value, t2.value with | SideCond (_, _, _, t), _ -> compare_term ~mod_eq t t2 | _, SideCond (_, _, _, t) -> compare_term ~mod_eq t1 t - | Hole i1, Hole i2 -> Pervasives.compare i1 i2 + | Hole i1, Hole i2 -> Stdlib.compare i1 i2 and compare_term_list ?(mod_eq=false) l1 l2 = match l1, l2 with diff --git a/src/lfsc/builtin.ml b/src/lfsc/builtin.ml index 86899df..75ea11e 100644 --- a/src/lfsc/builtin.ml +++ b/src/lfsc/builtin.ml @@ -616,7 +616,7 @@ let cong s1 s2 a1 b1 a2 b2 u1 u2 = module MInt = Map.Make (struct type t = int - let compare = Pervasives.compare + let compare = Stdlib.compare end) module STerm = Set.Make (Term) diff --git a/src/lfsc/shashcons.mli b/src/lfsc/shashcons.mli index 049ec5f..ca46efa 100644 --- a/src/lfsc/shashcons.mli +++ b/src/lfsc/shashcons.mli @@ -47,6 +47,7 @@ module type S = val iter : (t -> unit) -> unit (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, @@ -83,6 +84,7 @@ module type S_consed = val iter : (key hash_consed -> unit) -> unit (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int (** Return statistics on the table. The numbers are, in order: table length, number of entries, sum of bucket lengths, diff --git a/src/lia/Lia.v b/src/lia/Lia.v index c214c3b..46bbc5d 100644 --- a/src/lia/Lia.v +++ b/src/lia/Lia.v @@ -113,7 +113,7 @@ Section certif. | Some z => (vm, PEc z) | None => let (vm,p) := find_var vm h in - (vm,PEX Z p) + (vm,PEX p) end end. @@ -157,7 +157,7 @@ Section certif. Section Build_form. Definition build_not2 i f := - fold (fun f' => N (N (A:=Formula Z) f')) 1 i f. + fold (fun f' : BFormula (Formula Z) => N (N f')) 1 i f. Variable build_var : vmap -> var -> option (vmap*BFormula (Formula Z)). @@ -166,11 +166,11 @@ Section certif. match f with | Form.Fatom h => match build_formula vm h with - | Some (vm,f) => Some (vm, A f) + | Some (vm,f) => Some (vm, A f tt) | None => None end - | Form.Ftrue => Some (vm, TT (Formula Z)) - | Form.Ffalse => Some (vm, FF (Formula Z)) + | Form.Ftrue => Some (vm, TT) + | Form.Ffalse => Some (vm, FF) | Form.Fnot2 i l => match build_var vm (Lit.blit l) with | Some (vm, f) => @@ -181,7 +181,7 @@ Section certif. end | Form.Fand args => let n := length args in - if n == 0 then Some (vm,TT (Formula Z)) + if n == 0 then Some (vm,TT) else foldi (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,Cj f1' f2') | None => None end | None => None end) 1 (n-1) (let l := args.[0] in match build_var vm (Lit.blit l) with @@ -190,7 +190,7 @@ Section certif. end) | Form.For args => let n := length args in - if n == 0 then Some (vm,FF (Formula Z)) + if n == 0 then Some (vm,FF) else foldi (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,D f1' f2') | None => None end | None => None end) 1 (n-1) (let l := args.[0] in match build_var vm (Lit.blit l) with @@ -211,7 +211,7 @@ Section certif. end | Form.Fimp args => let n := length args in - if n == 0 then Some (vm,TT (Formula Z)) + if n == 0 then Some (vm,TT) else if n <= 1 then let l := args.[0] in match build_var vm (Lit.blit l) with @@ -219,7 +219,7 @@ Section certif. | None => None end else - foldi_down (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,I f2' f1') | None => None end | None => None end) (n-2) 0 (let l := args.[n-1] in + foldi_down (fun i f1 => match f1 with | Some(vm',f1') => let l := (args.[i]) in match build_var vm' (Lit.blit l) with | Some(vm2,f2) => let f2' := if Lit.is_pos l then f2 else N f2 in Some(vm2,I f2' None f1') | None => None end | None => None end) (n-2) 0 (let l := args.[n-1] in match build_var vm (Lit.blit l) with | Some (vm',f) => if Lit.is_pos l then Some (vm',f) else Some (vm',N f) | None => None @@ -295,7 +295,7 @@ Section certif. Definition build_clause vm cl := match build_clause_aux vm cl with - | Some (vm, bf) => Some (vm, I bf (FF _)) + | Some (vm, bf) => Some (vm, I bf None FF) | None => None end. @@ -479,11 +479,11 @@ Section certif. Fixpoint bounded_bformula (p:positive) (bf:BFormula (Formula Z)) := match bf with - | @TT _ | @FF _ | @X _ _ => true - | A f => bounded_formula p f + | @TT _ | @FF _ | @X _ _ _ _ _ => true + | A f _ => bounded_formula p f | Cj bf1 bf2 | D bf1 bf2 - | I bf1 bf2 => bounded_bformula p bf1 && bounded_bformula p bf2 + | I bf1 _ bf2 => bounded_bformula p bf1 && bounded_bformula p bf2 | N bf => bounded_bformula p bf end. @@ -523,7 +523,7 @@ Section certif. check_atom h Typ.TZ -> match build_z_atom h with | Some z => (vm, PEc z) - | None => let (vm0, p) := find_var vm h in (vm0, PEX Z p) + | None => let (vm0, p) := find_var vm h in (vm0, PEX p) end = (vm', pe) -> wf_vmap vm -> wf_vmap vm' /\ @@ -1020,13 +1020,15 @@ Transparent build_z_atom. intros;apply build_formula_atom_correct with (get_type t_i t_func t_atom h);trivial. unfold wt, is_true in wt_t_atom;rewrite forallbi_spec in wt_t_atom. - case_eq (h < length t_atom);intros Heq;unfold get_type;auto. + case_eq (h < length t_atom);intros Heq;unfold get_type;auto with smtcoq_core. unfold get_type'. rewrite !PArray.get_outofbound, default_t_interp, def_t_atom;trivial; try reflexivity. rewrite length_t_interp;trivial. Qed. + Local Notation eval_f := (eval_f (fun x => x)). + Lemma build_not2_pos_correct : forall vm f l i, bounded_bformula (fst vm) f -> (rho (Lit.blit l) <-> eval_f (Zeval_formula (interp_vmap vm)) f) -> Lit.is_pos l -> bounded_bformula (fst vm) (build_not2 i f) /\ (Form.interp interp_form_hatom interp_form_hatom_bv t_form (Form.Fnot2 i l) <-> eval_f (Zeval_formula (interp_vmap vm)) (build_not2 i f)). Proof. @@ -1083,7 +1085,7 @@ Transparent build_z_atom. Proof. intros vm vm' Hnth. unfold is_true;induction bf;simpl;try tauto. - destruct a;unfold bounded_formula;simpl. + destruct t;unfold bounded_formula;simpl. rewrite andb_true_iff;intros (H1, H2). rewrite !(interp_pexpr_le _ _ Hnth);tauto. rewrite andb_true_iff;intros (H1,H2);rewrite IHbf1, IHbf2;tauto. @@ -1123,12 +1125,12 @@ Transparent build_z_atom. (* Ftrue *) intros H H1; inversion H; subst vm'; subst bf; split; auto; split; [omega| ]; do 4 split; auto. (* Ffalse *) - intros H H1; inversion H; subst vm'; subst bf; split; auto; split; [omega| ]; do 3 (split; auto); discriminate. + intros H H1; inversion H; subst vm'; subst bf; split; auto; split; [omega| ]; do 3 (split; auto with smtcoq_core); discriminate. (* Fnot2 *) case_eq (build_var vm (Lit.blit l)); try discriminate; intros [vm0 f] Heq H H1; inversion H; subst vm0; subst bf; destruct (Hbv _ _ _ _ Heq H1) as [H2 [H3 [H4 [H5 H6]]]]; do 3 (split; auto); case_eq (Lit.is_pos l); [apply build_not2_pos_correct|apply build_not2_neg_correct]; auto. (* Fand *) simpl; unfold afold_left; case (length l == 0). - intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto; split; [omega| ]; do 3 (split; auto). + intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto with smtcoq_core; split; [omega| ]; do 3 (split; auto with smtcoq_core). revert vm' bf; apply (foldi_ind2 _ _ (fun f1 b => forall vm' bf, f1 = Some (vm', bf) -> wf_vmap vm -> wf_vmap vm' /\ (Pos.to_nat (fst vm) <= Pos.to_nat (fst vm'))%nat /\ (forall p : positive, (Pos.to_nat p < Pos.to_nat (fst vm))%nat -> nth_error (snd vm) (Pos.to_nat (fst vm - p) - 1) = nth_error (snd vm') (Pos.to_nat (fst vm' - p) - 1)) /\ bounded_bformula (fst vm') bf /\ (b = true <-> eval_f (Zeval_formula (interp_vmap vm')) bf))). intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. intros H3 H4; rewrite <- H14 in H4; rewrite H4 in H3; discriminate. @@ -1136,104 +1138,76 @@ Transparent build_z_atom. intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. intros p H15; rewrite H7; auto; apply H12; eauto with arith. split. - simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto. - simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite andb_true_r; try rewrite andb_false_r; try (intros; split; auto); try discriminate; intros [H20 H21]; auto. + simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite andb_true_r; try rewrite andb_false_r; try (intros; split; auto with smtcoq_core); try discriminate; intros [H20 H21]; auto with smtcoq_core. (* For *) simpl; unfold afold_left; case (length l == 0). - intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto; split; [omega| ]; do 3 (split; auto); discriminate. + intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto with smtcoq_core; split; [omega| ]; do 3 (split; auto with smtcoq_core); discriminate. revert vm' bf; apply (foldi_ind2 _ _ (fun f1 b => forall vm' bf, f1 = Some (vm', bf) -> wf_vmap vm -> wf_vmap vm' /\ (Pos.to_nat (fst vm) <= Pos.to_nat (fst vm'))%nat /\ (forall p : positive, (Pos.to_nat p < Pos.to_nat (fst vm))%nat -> nth_error (snd vm) (Pos.to_nat (fst vm - p) - 1) = nth_error (snd vm') (Pos.to_nat (fst vm' - p) - 1)) /\ bounded_bformula (fst vm') bf /\ (b = true <-> eval_f (Zeval_formula (interp_vmap vm')) bf))). - intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. + intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto with smtcoq_core); unfold Lit.interp; rewrite Heq2; auto with smtcoq_core; simpl; split. intros H3 H4; rewrite <- H14 in H4; rewrite H4 in H3; discriminate. - intro H3; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto; intro H4; elim H3; rewrite <- H14; auto. - intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H15; rewrite H7; auto; apply H12; eauto with arith. + intro H3; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto with smtcoq_core; intro H4; elim H3; rewrite <- H14; auto with smtcoq_core. + intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H15; rewrite H7; auto with smtcoq_core; apply H12; eauto with smtcoq_core arith. split. - simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto. - simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite orb_false_r; try rewrite orb_true_r; auto; try (intros [H20|H20]; auto; discriminate); right; intro H20; discriminate. + simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); try rewrite orb_false_r; try rewrite orb_true_r; auto with smtcoq_core; try (intros [H20|H20]; auto with smtcoq_core; discriminate); right; intro H20; discriminate. (* Fimp *) simpl; unfold afold_right; case (length l == 0). - intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto; split; [omega| ]; do 3 (split; auto). + intro H; inversion H; subst vm'; subst bf; simpl; intro H1; split; auto with smtcoq_core; split; [omega| ]; do 3 (split; auto with smtcoq_core). case (length l <= 1). - case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H3 [H4 [H5 [H6 H7]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. + case_eq (build_var vm (Lit.blit (l .[ 0]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ 0])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H3 [H4 [H5 [H6 H7]]]]; do 4 (split; auto with smtcoq_core); unfold Lit.interp; rewrite Heq2; auto with smtcoq_core; simpl; split. intros H8 H9; rewrite <- H7 in H9; rewrite H9 in H8; discriminate. - intro H8; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto; intro H9; rewrite H7 in H9; elim H8; auto. + intro H8; case_eq (Var.interp rho (Lit.blit (l .[ 0]))); auto with smtcoq_core; intro H9; rewrite H7 in H9; elim H8; auto with smtcoq_core. revert vm' bf; apply (foldi_down_ind2 _ _ (fun f1 b => forall vm' bf, f1 = Some (vm', bf) -> wf_vmap vm -> wf_vmap vm' /\ (Pos.to_nat (fst vm) <= Pos.to_nat (fst vm'))%nat /\ (forall p : positive, (Pos.to_nat p < Pos.to_nat (fst vm))%nat -> nth_error (snd vm) (Pos.to_nat (fst vm - p) - 1) = nth_error (snd vm') (Pos.to_nat (fst vm' - p) - 1)) /\ bounded_bformula (fst vm') bf /\ (b = true <-> eval_f (Zeval_formula (interp_vmap vm')) bf))). - intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ length l - 1]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ length l - 1])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto); unfold Lit.interp; rewrite Heq2; auto; simpl; split. + intros vm' bf; case_eq (build_var vm (Lit.blit (l .[ length l - 1]))); try discriminate; intros [vm0 f] Heq; case_eq (Lit.is_pos (l .[ length l - 1])); intros Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq H2) as [H10 [H11 [H12 [H13 H14]]]]; do 4 (split; auto with smtcoq_core); unfold Lit.interp; rewrite Heq2; auto with smtcoq_core; simpl; split. intros H3 H4; rewrite <- H14 in H4; rewrite H4 in H3; discriminate. - intro H3; case_eq (Var.interp rho (Lit.blit (l .[ length l - 1]))); auto; intro H4; elim H3; rewrite <- H14; auto. - intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H15; rewrite H7; auto; apply H12; eauto with arith. + intro H3; case_eq (Var.interp rho (Lit.blit (l .[ length l - 1]))); auto with smtcoq_core; intro H4; elim H3; rewrite <- H14; auto with smtcoq_core. + intros i a b _ H1; case a; try discriminate; intros [vm0 f0] IH vm' bf; case_eq (build_var vm0 (Lit.blit (l .[ i]))); try discriminate; intros [vm1 f1] Heq H2 H3; inversion H2; subst vm'; subst bf; destruct (IH _ _ (refl_equal (Some (vm0, f0))) H3) as [H5 [H6 [H7 [H8 H9]]]]; destruct (Hbv _ _ _ _ Heq H5) as [H10 [H11 [H12 [H13 H14]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H15; rewrite H7; auto with smtcoq_core; apply H12; eauto with smtcoq_core arith. split. - simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto. - simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); auto; try discriminate; simpl; intro H; apply H; discriminate. + simpl; rewrite (bounded_bformula_le _ _ H11 _ H8); case (Lit.is_pos (l .[ i])); rewrite H13; auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H12 _ H8) in H9; rewrite <- H9; case_eq (Lit.is_pos (l .[ i])); intro Heq2; simpl; rewrite <- H14; unfold Lit.interp; rewrite Heq2; split; case (Var.interp rho (Lit.blit (l .[ i]))); auto with smtcoq_core; try discriminate; simpl; intro H; apply H; discriminate. (* Fxor *) - simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H18; rewrite H5; auto; rewrite H10; eauto with arith. + simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H18; rewrite H5; auto with smtcoq_core; rewrite H10; eauto with smtcoq_core arith. split. - case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto. - simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto; try discriminate; simpl. - intros [_ [H20|H20]]; elim H20; reflexivity. - intros _; split; [left; reflexivity|right; intro H20; discriminate]. - intros _; split; [right; reflexivity|left; intro H20; discriminate]. - intros [[H20|H20] _]; discriminate. - intros [_ [H20|H20]]; elim H20; [reflexivity|discriminate]. - intros [[H20|H20] _]; [discriminate|elim H20; reflexivity]. - intros _; split; [right|left]; discriminate. - intros [[H20|H20] _]; [elim H20; reflexivity|discriminate]. - intros [_ [H20|H20]]; elim H20; [discriminate|reflexivity]. - intros _; split; [left|right]; discriminate. - intros [[H20|H20] _]; elim H20; reflexivity. - intros _; split; [right; discriminate|left; intro H21; apply H21; reflexivity]. - intros _; split; [left; discriminate|right; intro H21; apply H21; reflexivity]. - intros [_ [H20|H20]]; elim H20; discriminate. + case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto with smtcoq_core; try discriminate; simpl; intuition. (* Fiff *) - simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H18; rewrite H5; auto; rewrite H10; eauto with arith. + simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H18; rewrite H5; auto with smtcoq_core; rewrite H10; eauto with smtcoq_core arith. split. - case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto. - simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto; try discriminate; simpl. - intros [_ [H20|H20]]; [elim H20; reflexivity|discriminate]. - intros [[H20|H20] _]; [discriminate|elim H20; reflexivity]. - intros _; split; [right|left]; discriminate. - intros [_ [H20|H20]]; elim H20; reflexivity. - intros _; split; [left; reflexivity|right; discriminate]. - intros _; split; [right; intro H20; apply H20; reflexivity|left; discriminate]. - intros [[H20|H20] _]; [ |elim H20]; discriminate. - intros [[H20|H20] _]; elim H20; reflexivity. - intros _; split; [right; discriminate|left; intro H20; apply H20; reflexivity]. - intros _; split; [left; discriminate|right; reflexivity]. - intros [_ [H20|H20]]; [elim H20| ]; discriminate. - intros [[H20|H20] _]; elim H20; [reflexivity|discriminate]. - intros [_ [H20|H20]]; elim H20; [discriminate|reflexivity]. - intros _; split; [left|right]; discriminate. + case (Lit.is_pos a); case (Lit.is_pos b); simpl; rewrite H11; rewrite (bounded_bformula_le _ _ H9 _ H6); auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H10 _ H6) in H7; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; unfold Lit.interp; rewrite Ha, Hb; simpl; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); case (Var.interp rho (Lit.blit b))); split; auto with smtcoq_core; try discriminate; simpl; intuition. (* Fite *) - simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2; case_eq (build_var vm2 (Lit.blit c)); try discriminate; intros [vm3 f3] Heq3 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; destruct (Hbv _ _ _ _ Heq3 H8) as [H13 [H14 [H15 [H16 H17]]]]; split; auto; split; [eauto with arith| ]; split. - intros p H18; rewrite H5; auto; rewrite H10; eauto with arith. - assert (H18: (Pos.to_nat (fst vm1) <= Pos.to_nat (fst vm3))%nat) by eauto with arith. + simpl; case_eq (build_var vm (Lit.blit a)); try discriminate; intros [vm1 f1] Heq1; case_eq (build_var vm1 (Lit.blit b)); try discriminate; intros [vm2 f2] Heq2; case_eq (build_var vm2 (Lit.blit c)); try discriminate; intros [vm3 f3] Heq3 H1 H2; inversion H1; subst vm'; subst bf; destruct (Hbv _ _ _ _ Heq1 H2) as [H3 [H4 [H5 [H6 H7]]]]; destruct (Hbv _ _ _ _ Heq2 H3) as [H8 [H9 [H10 [H11 H12]]]]; destruct (Hbv _ _ _ _ Heq3 H8) as [H13 [H14 [H15 [H16 H17]]]]; split; auto with smtcoq_core; split; [eauto with smtcoq_core arith| ]; split. + intros p H18; rewrite H5; auto with smtcoq_core; rewrite H10; eauto with smtcoq_core arith. + assert (H18: (Pos.to_nat (fst vm1) <= Pos.to_nat (fst vm3))%nat) by eauto with smtcoq_core arith. split. - case (Lit.is_pos a); case (Lit.is_pos b); case (Lit.is_pos c); simpl; rewrite H16; rewrite (bounded_bformula_le _ _ H14 _ H11); rewrite (bounded_bformula_le _ _ H18 _ H6); auto. - simpl; rewrite (interp_bformula_le _ _ H15 _ H11) in H12; rewrite (interp_bformula_le _ vm3) in H7; [ |intros p Hp; rewrite H10; eauto with arith|auto]; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; case_eq (Lit.is_pos c); intro Hc; unfold Lit.interp; rewrite Ha, Hb, Hc; simpl; rewrite <- H17; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); [case (Var.interp rho (Lit.blit b))|case (Var.interp rho (Lit.blit c))]); split; auto; try discriminate; try (intros [[H20 H21]|[H20 H21]]; auto); try (intros _; left; split; auto; discriminate); try (intros _; right; split; auto; discriminate); try (elim H20; discriminate); try (elim H21; discriminate); try (simpl; intro H; left; split; auto; discriminate); try (revert H; case (Var.interp rho (Lit.blit c)); discriminate); try (revert H; case (Var.interp rho (Lit.blit b)); discriminate); try (intro H20; rewrite H20 in H; discriminate); simpl. - intro H; right; split; auto. - intro H; right; split; auto. - intro H; right; split; auto. + case (Lit.is_pos a); case (Lit.is_pos b); case (Lit.is_pos c); simpl; rewrite H16; rewrite (bounded_bformula_le _ _ H14 _ H11); rewrite (bounded_bformula_le _ _ H18 _ H6); auto with smtcoq_core. + simpl; rewrite (interp_bformula_le _ _ H15 _ H11) in H12; rewrite (interp_bformula_le _ vm3) in H7; [ |intros p Hp; rewrite H10; eauto with smtcoq_core arith|auto with smtcoq_core]; case_eq (Lit.is_pos a); intro Ha; case_eq (Lit.is_pos b); intro Hb; case_eq (Lit.is_pos c); intro Hc; unfold Lit.interp; rewrite Ha, Hb, Hc; simpl; rewrite <- H17; rewrite <- H12; rewrite <- H7; (case (Var.interp rho (Lit.blit a)); [case (Var.interp rho (Lit.blit b))|case (Var.interp rho (Lit.blit c))]); split; auto with smtcoq_core; try discriminate; try (intros [[H20 H21]|[H20 H21]]; auto with smtcoq_core); try (intros _; left; split; auto with smtcoq_core; discriminate); try (intros _; right; split; auto with smtcoq_core; discriminate); try (elim H20; discriminate); try (elim H21; discriminate); try (simpl; intro H; left; split; auto with smtcoq_core; discriminate); try (revert H; case (Var.interp rho (Lit.blit c)); discriminate); try (revert H; case (Var.interp rho (Lit.blit b)); discriminate); try (intro H20; rewrite H20 in H; discriminate); simpl. + intro H; right; split; auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. intro H20; rewrite H20 in H; discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - right; split; auto; intro H20; rewrite H20 in H; discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - intro H; right; split; auto. - intro H; right; split; auto. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + right; split; auto with smtcoq_core; intro H20; rewrite H20 in H; discriminate. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core. intro H; left; split; try discriminate; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. intro H; left; split; try discriminate; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. - intro H; right; split; auto; revert H; case (Var.interp rho (Lit.blit c)); discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - intro H; right; split; auto; revert H; case (Var.interp rho (Lit.blit c)); discriminate. - revert H21; case (Var.interp rho (Lit.blit c)); auto. - intro H; left; split; auto; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. - intro H; left; split; auto; revert H; case (Var.interp rho (Lit.blit b)); discriminate. - revert H21; case (Var.interp rho (Lit.blit b)); auto. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit c)); discriminate. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + intro H; right; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit c)); discriminate. + revert H21; case (Var.interp rho (Lit.blit c)); auto with smtcoq_core. + intro H; left; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit b)); discriminate. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. + intro H; left; split; auto with smtcoq_core; revert H; case (Var.interp rho (Lit.blit b)); discriminate. + revert H21; case (Var.interp rho (Lit.blit b)); auto with smtcoq_core. Qed. @@ -1251,8 +1225,8 @@ Transparent build_z_atom. Proof. unfold build_var; apply foldi_down_cont_ind; try discriminate. intros i cont _ Hlen Hrec v vm vm' bf; unfold is_true; intros H1 H2; replace (Var.interp rho v) with (Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form.[v])). - apply (build_hform_correct cont); auto. - unfold Var.interp; rewrite <- wf_interp_form; auto. + apply (build_hform_correct cont); auto with smtcoq_core. + unfold Var.interp; rewrite <- wf_interp_form; auto with smtcoq_core. Qed. @@ -1285,17 +1259,17 @@ Transparent build_z_atom. unfold build_nlit; intros l vm vm' bf; case_eq (build_form vm (t_form .[ Lit.blit (Lit.neg l)])); try discriminate. intros [vm1 f] Heq H1 H2; inversion H1; subst vm1; subst bf; case_eq (Lit.is_pos (Lit.neg l)); intro Heq2. replace (negb (Lit.interp rho l)) with (Form.interp interp_form_hatom interp_form_hatom_bv t_form (t_form .[ Lit.blit (Lit.neg l)])). - apply build_form_correct; auto. + apply build_form_correct; auto with smtcoq_core. unfold Lit.interp; replace (Lit.is_pos l) with false. - rewrite negb_involutive; unfold Var.interp; rewrite <- wf_interp_form; auto; rewrite Lit.blit_neg; auto. - rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto; intro H; rewrite H in Heq2; discriminate. - simpl; destruct (build_form_correct (t_form .[ Lit.blit (Lit.neg l)]) vm vm' f Heq H2) as [H3 [H4 [H5 [H6 [H7 H8]]]]]; do 4 (split; auto); split. + rewrite negb_involutive; unfold Var.interp; rewrite <- wf_interp_form; auto with smtcoq_core; rewrite Lit.blit_neg; auto with smtcoq_core. + rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto with smtcoq_core; intro H; rewrite H in Heq2; discriminate. + simpl; destruct (build_form_correct (t_form .[ Lit.blit (Lit.neg l)]) vm vm' f Heq H2) as [H3 [H4 [H5 [H6 [H7 H8]]]]]; do 4 (split; auto with smtcoq_core); split. intros H9 H10; pose (H11 := H8 H10); unfold Lit.interp in H9; replace (Lit.is_pos l) with true in H9. - unfold Var.interp in H9; rewrite <- wf_interp_form in H11; auto; rewrite Lit.blit_neg in H11; rewrite H11 in H9; discriminate. - rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto; intro H; rewrite H in Heq2; discriminate. - intro H9; case_eq (Lit.interp rho l); intro Heq3; auto; elim H9; apply H7; unfold Lit.interp in Heq3; replace (Lit.is_pos l) with true in Heq3. - unfold Var.interp in Heq3; rewrite <- wf_interp_form; auto; rewrite Lit.blit_neg; auto. - rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto; intro H; rewrite H in Heq2; discriminate. + unfold Var.interp in H9; rewrite <- wf_interp_form in H11; auto with smtcoq_core; rewrite Lit.blit_neg in H11; rewrite H11 in H9; discriminate. + rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto with smtcoq_core; intro H; rewrite H in Heq2; discriminate. + intro H9; case_eq (Lit.interp rho l); intro Heq3; auto with smtcoq_core; elim H9; apply H7; unfold Lit.interp in Heq3; replace (Lit.is_pos l) with true in Heq3. + unfold Var.interp in Heq3; rewrite <- wf_interp_form; auto with smtcoq_core; rewrite Lit.blit_neg; auto with smtcoq_core. + rewrite Lit.is_pos_neg in Heq2; case_eq (Lit.is_pos l); auto with smtcoq_core; intro H; rewrite H in Heq2; discriminate. Qed. @@ -1403,7 +1377,7 @@ Transparent build_z_atom. rewrite H0, def_t_atom;discriminate. apply H1 in H2;clear H1;rewrite H0 in H2;simpl in H2. rewrite !andb_true_iff in H2;decompose [and] H2;clear H2. - apply Hf with (2:= H0);trivial. auto. + apply Hf with (2:= H0);trivial. auto with smtcoq_core. rewrite wf_interp_form, H;simpl. unfold Atom.interp_form_hatom, Atom.interp_hatom at 1;simpl. rewrite Atom.t_interp_wf, H0;simpl;trivial. @@ -1434,7 +1408,7 @@ Transparent build_z_atom. rewrite H0, def_t_atom;discriminate. apply H1 in H2;clear H1;rewrite H0 in H2;simpl in H2. rewrite !andb_true_iff in H2;decompose [and] H2;clear H2. - simpl; apply Hf with (2:= H0);trivial. auto. + simpl; apply Hf with (2:= H0);trivial. auto with smtcoq_core. rewrite wf_interp_form, H;simpl. unfold Atom.interp_form_hatom, Atom.interp_hatom at 1;simpl. rewrite Atom.t_interp_wf, H0;simpl;trivial. @@ -1480,7 +1454,7 @@ Transparent build_z_atom. case_eq (build_clause empty_vmap cl). intros (vm1, bf) Heq. destruct (build_clause_correct _ _ _ _ Heq). - red;simpl;auto. + red;simpl;auto with smtcoq_core. decompose [and] H0. case_eq (ZTautoChecker bf c);intros Heq2. unfold C.valid;rewrite H5. @@ -1512,11 +1486,11 @@ Transparent build_z_atom. rewrite wf_interp_form, H;simpl. case_eq (Lit.interp rho (a.[0]) || Lit.interp rho (a.[1]) || Lit.interp rho (a.[2])). intros;repeat (rewrite orb_true_iff in H19);destruct H19. destruct H19. - apply (afold_left_orb_true int 0); subst; auto. + apply (afold_left_orb_true int 0); subst; auto with smtcoq_core. apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 1); auto. + apply (afold_left_orb_true int 1); auto with smtcoq_core. apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 2); auto. + apply (afold_left_orb_true int 2); auto with smtcoq_core. apply ltb_spec;rewrite H0;compute;trivial. intros; repeat (rewrite orb_false_iff in H19);destruct H19. destruct H19. unfold Lit.interp in H19. @@ -1534,7 +1508,7 @@ Transparent build_z_atom. destruct (Typ.reflect_eqb (get_type t_i t_func t_atom b0) Typ.TZ) as [H12|H12]; [intros _|discriminate]. generalize H6. clear H6. destruct (Typ.reflect_eqb (get_type t_i t_func t_atom b0) t) as [H6|H6]; [intros _|discriminate]. - rewrite <- H6. auto. + rewrite <- H6. auto with smtcoq_core. rewrite H26 in H19. case_eq (interp_atom (t_atom .[ b1])); intros t1 v1 Heq1. assert (H50: t1 = Typ.TZ). @@ -1560,11 +1534,11 @@ Transparent build_z_atom. rewrite wf_interp_form, H;simpl. case_eq (Lit.interp rho (a.[0]) || Lit.interp rho (a.[1]) || Lit.interp rho (a.[2])). intros;repeat (rewrite orb_true_iff in H19);destruct H19. destruct H19. - apply (afold_left_orb_true int 0); auto. + apply (afold_left_orb_true int 0); auto with smtcoq_core. apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 1); auto. + apply (afold_left_orb_true int 1); auto with smtcoq_core. apply ltb_spec;rewrite H0;compute;trivial. - apply (afold_left_orb_true int 2); auto. + apply (afold_left_orb_true int 2); auto with smtcoq_core. apply ltb_spec;rewrite H0;compute;trivial. intros; repeat (rewrite orb_false_iff in H19);destruct H19. destruct H19. unfold Lit.interp in H19. @@ -1581,7 +1555,7 @@ Transparent build_z_atom. unfold Var.interp in H23; rewrite H10 in H23. rewrite <-H22, <- H20 in H21. assert (t = Typ.TZ). - rewrite Typ.eqb_spec in H6; rewrite Typ.eqb_spec in H18; subst; auto. + rewrite Typ.eqb_spec in H6; rewrite Typ.eqb_spec in H18; subst; auto with smtcoq_core. rewrite H26 in H19. case_eq (interp_atom (t_atom .[ b0])); intros t1 v1 Heq1. assert (H50: t1 = Typ.TZ). diff --git a/src/lia/lia.ml b/src/lia/lia.ml index 4444816..dce79ee 100644 --- a/src/lia/lia.ml +++ b/src/lia/lia.ml @@ -13,9 +13,7 @@ (*** Linking SMT Terms to Micromega Terms ***) open Util open Structures.Micromega_plugin_Micromega -open Structures.Micromega_plugin_Coq_micromega -open SmtMisc open SmtForm open SmtAtom @@ -29,14 +27,6 @@ let rec pos_of_int i = then XO(pos_of_int (i lsr 1)) else XI(pos_of_int (i lsr 1)) -let z_of_int i = - if i = 0 - then Z0 - else - if i > 0 - then Zpos (pos_of_int i) - else Zneg (pos_of_int (-i)) - type my_tbl = {tbl:(hatom,int) Hashtbl.t; mutable count:int} @@ -117,8 +107,6 @@ let smt_Atom_to_micromega_formula tbl ha = (* specialized fold *) -let default_constr = lazy (Structures.econstr_of_constr (mkInt 0)) -let default_tag = Structures.Micromega_plugin_Mutils.Tag.from 0 (* morphism for general formulas *) let binop_array g tbl op def t = @@ -135,12 +123,10 @@ let binop_array g tbl op def t = let rec smt_Form_to_coq_micromega_formula tbl l = let v = match Form.pform l with - | Fatom ha -> - A (smt_Atom_to_micromega_formula tbl ha, - default_tag, Lazy.force default_constr) + | Fatom ha -> A (smt_Atom_to_micromega_formula tbl ha, Tt) | Fapp (Ftrue, _) -> TT | Fapp (Ffalse, _) -> FF - | Fapp (Fand, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> C (x,y)) TT l + | Fapp (Fand, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> Cj (x,y)) TT l | Fapp (For, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> D (x,y)) FF l | Fapp (Fxor, l) -> failwith "todo:Fxor" | Fapp (Fimp, l) -> binop_array smt_Form_to_coq_micromega_formula tbl (fun x y -> I (x,None,y)) TT l @@ -162,49 +148,206 @@ let binop_list tbl op def l = | [] -> def | f::l -> List.fold_left (fun x y -> op x (smt_Form_to_coq_micromega_formula tbl y)) (smt_Form_to_coq_micromega_formula tbl f) l +let smt_clause_to_coq_micromega_formula tbl cl = + binop_list tbl (fun x y -> Cj (x,y)) TT (List.map Form.neg cl) -(* let rec binop_list tbl op def l = *) -(* match l with *) -(* | [] -> def *) -(* | [f] -> smt_Form_to_coq_micromega_formula tbl f *) -(* | f::l -> *) -(* op (smt_Form_to_coq_micromega_formula tbl f) (binop_list tbl op def l) *) - -(* and smt_Form_to_coq_micromega_formula tbl l = *) -(* let v = *) -(* match Form.pform l with *) -(* | Fatom ha -> *) -(* A (smt_Atom_to_micromega_formula tbl ha, *) -(* default_tag,default_constr) *) -(* | Fapp (Ftrue, _) -> TT *) -(* | Fapp (Ffalse, _) -> FF *) -(* | Fapp (Fand, l) -> binop_list tbl (fun x y -> C (x,y)) TT l *) -(* | Fapp (For, l) -> binop_list tbl (fun x y -> D (x,y)) FF l *) -(* | Fapp (Fxor, l) -> failwith "todo:Fxor" *) -(* | Fapp (Fimp, l) -> binop_list tbl (fun x y -> I (x,None,y)) TT l *) -(* | Fapp (Fiff, l) -> failwith "todo:Fiff" *) -(* | Fapp (Fite, l) -> failwith "todo:Fite" *) -(* | Fapp (Fnot2 _, l) -> smt_Form_to_coq_micromega_formula tbl l *) -(* in *) -(* if Form.is_pos l then v *) -(* else N(v) *) +(* backported from Coq *) +type ('option,'a,'prf,'model) prover = { + name : string ; (* name of the prover *) + get_option : unit ->'option ; (* find the options of the prover *) + prover : ('option * 'a list) -> ('prf, 'model) Structures.Micromega_plugin_Certificate.res ; (* the prover itself *) + hyps : 'prf -> Structures.Micromega_plugin_Mutils.ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) + compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) + pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) + pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) +} -let smt_clause_to_coq_micromega_formula tbl cl = - binop_list tbl (fun x y -> C(x,y)) TT (List.map Form.neg cl) +let lia_enum = ref true +let max_depth = max_int +let lia_proof_depth = ref max_depth +let get_lia_option () = + (!Structures.Micromega_plugin_Certificate.use_simplex,!lia_enum,!lia_proof_depth) + +let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Structures.Micromega_plugin_Micromega.denorm e , o) l) + +module CacheZ = Structures.Micromega_plugin_Persistent_cache.PHashtable(struct + type prover_option = bool * bool* int + type t = prover_option * ((Structures.Micromega_plugin_Micromega.z Structures.Micromega_plugin_Micromega.pol * Structures.Micromega_plugin_Micromega.op1) list) + let equal = (=) + let hash = Hashtbl.hash +end) + +let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Structures.Micromega_plugin_Certificate.lia ce b) s) + +let xhyps_of_cone base acc prf = + let open Structures.Micromega_plugin_Micromega in + + let rec xtract e acc = + match e with + | PsatzC _ | PsatzZ | PsatzSquare _ -> acc + | PsatzIn n -> let n = (Structures.Micromega_plugin_Mutils.CoqToCaml.nat n) in + if n >= base + then Structures.Micromega_plugin_Mutils.ISet.add (n-base) acc + else acc + | PsatzMulC(_,c) -> xtract c acc + | PsatzAdd(e1,e2) | PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in + + xtract prf acc + +let hyps_of_pt pt = + let open Structures.Micromega_plugin_Micromega in + + let rec xhyps base pt acc = + match pt with + | DoneProof -> acc + | RatProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | CutProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | EnumProof (c1, c2, l) -> + let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in + List.fold_left (fun s x -> xhyps (base + 1) x s) s l + | ExProof (_, pt) -> xhyps (base + 3) pt acc + in + + xhyps 0 pt Structures.Micromega_plugin_Mutils.ISet.empty + +let compact_cone prf f = + let open Structures.Micromega_plugin_Micromega in + + let np n = Structures.Micromega_plugin_Mutils.CamlToCoq.nat (f (Structures.Micromega_plugin_Mutils.CoqToCaml.nat n)) in + + let rec xinterp prf = + match prf with + | PsatzC _ | PsatzZ | PsatzSquare _ -> prf + | PsatzIn n -> PsatzIn (np n) + | PsatzMulC(e,c) -> PsatzMulC(e,xinterp c) + | PsatzAdd(e1,e2) -> PsatzAdd(xinterp e1,xinterp e2) + | PsatzMulE(e1,e2) -> PsatzMulE(xinterp e1,xinterp e2) in + + xinterp prf + +let compact_pt pt f = + let open Structures.Micromega_plugin_Micromega in + let translate ofset x = if x < ofset then x else f (x - ofset) + ofset in + let rec compact_pt ofset pt = + match pt with + | DoneProof -> DoneProof + | RatProof (c, pt) -> + RatProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | CutProof (c, pt) -> + CutProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | EnumProof (c1, c2, l) -> + EnumProof + ( compact_cone c1 (translate ofset) + , compact_cone c2 (translate ofset) + , map (fun x -> compact_pt (ofset + 1) x) l ) + | ExProof (x, pt) -> ExProof (x, compact_pt (ofset + 3) pt) + in + compact_pt 0 pt + +let pp_nat o n = Printf.fprintf o "%i" (Structures.Micromega_plugin_Mutils.CoqToCaml.nat n) + +let pp_positive o x = Printf.fprintf o "%i" (Structures.Micromega_plugin_Mutils.CoqToCaml.positive x) + +let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (Structures.Micromega_plugin_Mutils.CoqToCaml.z_big_int x)) + +let pp_list op cl elt o l = + let rec _pp o l = + match l with + | [] -> () + | [e] -> Printf.fprintf o "%a" elt e + | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in + Printf.fprintf o "%s%a%s" op _pp l cl + +let pp_pol pp_c o e = + let open Structures.Micromega_plugin_Micromega in + let rec pp_pol o e = + match e with + | Pc n -> Printf.fprintf o "Pc %a" pp_c n + | Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol + | PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in + pp_pol o e + +let pp_psatz pp_z o e = + let open Structures.Micromega_plugin_Micromega in + let rec pp_cone o e = + match e with + | PsatzIn n -> + Printf.fprintf o "(In %a)%%nat" pp_nat n + | PsatzMulC(e,c) -> + Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c + | PsatzSquare e -> + Printf.fprintf o "(%a^2)" (pp_pol pp_z) e + | PsatzAdd(e1,e2) -> + Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 + | PsatzMulE(e1,e2) -> + Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 + | PsatzC p -> + Printf.fprintf o "(%a)%%positive" pp_z p + | PsatzZ -> + Printf.fprintf o "0" in + pp_cone o e + +let rec pp_proof_term o p = + let open Structures.Micromega_plugin_Micromega in + match p with + | DoneProof -> Printf.fprintf o "D" + | RatProof (cone, rst) -> + Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | CutProof (cone, rst) -> + Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | EnumProof (c1, c2, rst) -> + Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + (pp_list "[" "]" pp_proof_term) + rst + | ExProof (p, prf) -> + Printf.fprintf o "Ex[%a,%a]" pp_positive p pp_proof_term prf + +let linear_Z = { + name = "lia"; + get_option = get_lia_option; + prover = memo_zlinear_prover ; + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + +let find_witness p polys1 = + let open Structures.Micromega_plugin_Certificate in + let polys1 = List.map fst polys1 in + match p.prover (p.get_option (), polys1) with + | Model m -> Model m + | Unknown -> Unknown + | Prf prf -> Prf(prf,p) + +let witness_list prover l = + let open Structures.Micromega_plugin_Certificate in + let rec xwitness_list l = + match l with + | [] -> Prf [] + | e :: l -> + match xwitness_list l with + | Model (m,e) -> Model (m,e) + | Unknown -> Unknown + | Prf l -> + match find_witness prover e with + | Model m -> Model (m,e) + | Unknown -> Unknown + | Prf w -> Prf (w::l) in + xwitness_list l + +let witness_list_tags = witness_list -(* backported from Coq-8.8.2 *) -(* val tauto_lia : Mc.z formula -> Certificate.Mc.zArithProof list option *) let tauto_lia ff = let prover = linear_Z in - let cnf_ff,_ = Structures.Micromega_plugin_Coq_micromega.cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in - match witness_list_tags [prover] cnf_ff with - | None -> None - | Some l -> Some (List.map fst l) + let cnf_ff,_ = Structures.Micromega_plugin_Micromega.cnfZ ff in + match witness_list_tags prover cnf_ff with + | Structures.Micromega_plugin_Certificate.Prf l -> Some (List.map fst l) + | _ -> None (* call to micromega solver *) let build_lia_certif cl = let tbl = create_tbl 13 in let f = I(smt_clause_to_coq_micromega_formula tbl cl, None, FF) in - tbl, f, tauto_lia f - + tauto_lia f diff --git a/src/lia/lia.mli b/src/lia/lia.mli index 9d4ee6b..fb58db8 100644 --- a/src/lia/lia.mli +++ b/src/lia/lia.mli @@ -10,60 +10,6 @@ (**************************************************************************) -val pos_of_int : int -> Structures.Micromega_plugin_Micromega.positive -val z_of_int : int -> Structures.Micromega_plugin_Micromega.z -type my_tbl -val get_atom_var : my_tbl -> SmtAtom.hatom -> int -val create_tbl : int -> my_tbl -val smt_Atom_to_micromega_pos : - SmtAtom.hatom -> Structures.Micromega_plugin_Micromega.positive -val smt_Atom_to_micromega_Z : - SmtAtom.hatom -> Structures.Micromega_plugin_Micromega.z -val smt_Atom_to_micromega_pExpr : - my_tbl -> - SmtAtom.hatom -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Micromega.pExpr -val smt_binop_to_micromega_formula : - my_tbl -> - SmtAtom.bop -> - SmtAtom.hatom -> - SmtAtom.hatom -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Micromega.formula -val smt_Atom_to_micromega_formula : - my_tbl -> - SmtAtom.hatom -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Micromega.formula -val binop_array : - ('a -> 'b -> 'c) -> 'a -> ('c -> 'c -> 'c) -> 'c -> 'b array -> 'c -val smt_Form_to_coq_micromega_formula : - my_tbl -> - SmtAtom.Form.t -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -val binop_list : - my_tbl -> - (Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula) -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -> - SmtAtom.Form.t list -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula -val smt_clause_to_coq_micromega_formula : - my_tbl -> - SmtAtom.Form.t list -> - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula val build_lia_certif : SmtAtom.Form.t list -> - my_tbl * - Structures.Micromega_plugin_Micromega.z - Structures.Micromega_plugin_Coq_micromega.formula * Structures.Micromega_plugin_Certificate.Mc.zArithProof list option diff --git a/src/smtlib2/smtlib2_genConstr.ml b/src/smtlib2/smtlib2_genConstr.ml index f938671..7e58aa3 100644 --- a/src/smtlib2/smtlib2_genConstr.ml +++ b/src/smtlib2/smtlib2_genConstr.ml @@ -111,7 +111,7 @@ let declare_sort rt sym = declare_sort_from_name rt (string_of_symbol sym) let declare_fun_from_name rt ro s tyl ty = let coqTy = List.fold_right (fun typ c -> - Term.mkArrow (interp_to_coq rt typ) c) + Structures.mkArrow (interp_to_coq rt typ) c) tyl (interp_to_coq rt ty) in let cons_v = Structures.declare_new_variable (Structures.mkId ("Smt_var_"^s)) coqTy in let op = Op.declare ro cons_v (Array.of_list tyl) ty None in diff --git a/src/spl/Arithmetic.v b/src/spl/Arithmetic.v index 05c999d..3f5cd16 100644 --- a/src/spl/Arithmetic.v +++ b/src/spl/Arithmetic.v @@ -63,8 +63,6 @@ Section Arith. Let wf_rho : Valuation.wf rho. Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto. Qed. - Hint Immediate wf_rho. - Lemma valid_check_spl_arith : forall orig, C.valid rho orig -> @@ -76,7 +74,7 @@ Section Arith. (* List with one element *) intros H res l; case_eq (build_clause Lia.empty_vmap (Lit.neg li :: res :: nil)); [ |intros; apply C.interp_true; auto]. intros (vm1, bf) Heq; destruct (Lia.build_clause_correct _ _ _ t_func ch_atom ch_form wt_t_atom _ _ _ _ Heq) as [H1 H0]. - red; simpl; auto. + red; simpl; auto with smtcoq_core. decompose [and] H0; case_eq (ZTautoChecker bf l); [intros Heq3|intros; apply C.interp_true; auto]. unfold C.valid; replace (C.interp rho (res :: nil)) with (C.interp rho (Lit.neg li :: res :: nil)). rewrite H6; apply ZTautoChecker_sound with l;trivial. diff --git a/src/spl/Operators.v b/src/spl/Operators.v index f0aba15..fb3e379 100644 --- a/src/spl/Operators.v +++ b/src/spl/Operators.v @@ -279,28 +279,28 @@ intros. destruct H0; now contradict H0. Lemma wf_t_form : wf t_form. Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto. Qed. - Local Hint Immediate wf_t_atom default_t_atom default_t_form wf_t_form. + Local Hint Immediate wf_t_atom default_t_atom default_t_form wf_t_form : smtcoq_spl_op. Lemma interp_check_distinct : forall ha diseq, check_distinct ha diseq = true -> interp_form_hatom ha = afold_left bool int true andb (Lit.interp rho) diseq. Proof. - intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H2]]]; rewrite check_diseqs_spec in H2; destruct H2 as [H2 H3]; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. + intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H2]]]; rewrite check_diseqs_spec in H2; destruct H2 as [H2 H3]; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. intros l H4; case_eq (distinct (Typ.i_eqb t_i A) (rev l)). - rewrite distinct_spec; intro H5; symmetry; apply afold_left_andb_true; intros i Hi; destruct (H2 _ Hi) as [H9 [a [H10 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H10; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H11: a < length t_atom). - case_eq (a < length t_atom); auto; intro H11; rewrite (get_outofbound _ _ _ H11) in H6; rewrite default_t_atom in H6; inversion H6. - generalize (wt_t_atom _ H11); rewrite H6; simpl; rewrite !andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A)); rewrite !Typ.eqb_spec; intros [[_ H13] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H13; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H5; auto; rewrite H4; [exists h2; exists h1|exists h1; exists h2]; auto. - rewrite distinct_false_spec; intros [v2 [v1 [H5 H6]]]; rewrite H4 in H5; destruct H5 as [a [b [H5 [H7 H8]]]]; clear H4; change (Typ.i_eqb t_i A v2 v1 = true) with (is_true (Typ.i_eqb t_i A v2 v1)) in H6; rewrite Typ.i_eqb_spec in H6; subst v2; clear H2; destruct (H3 _ _ H5) as [i [H2 [H4 [hb [H6 [H9 H10]]]]]]; clear H3; symmetry; apply (afold_left_andb_false _ i); auto; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H6; simpl; rewrite Atom.t_interp_wf; auto; destruct H10 as [H10|H10]; rewrite H10; simpl; rewrite H7, H8; simpl; rewrite Typ.cast_refl; simpl; replace (Typ.i_eqb t_i A v1 v1) with true; auto; symmetry; change (is_true (Typ.i_eqb t_i A v1 v1)); rewrite Typ.i_eqb_spec; auto. + rewrite distinct_spec; intro H5; symmetry; apply afold_left_andb_true; intros i Hi; destruct (H2 _ Hi) as [H9 [a [H10 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto with smtcoq_spl_op smtcoq_core); unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_spl_op smtcoq_core; rewrite H10; simpl; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H11: a < length t_atom). + case_eq (a < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro H11; rewrite (get_outofbound _ _ _ H11) in H6; rewrite default_t_atom in H6; inversion H6. + generalize (wt_t_atom _ H11); rewrite H6; simpl; rewrite !andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A)); rewrite !Typ.eqb_spec; intros [[_ H13] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H13; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H5; auto with smtcoq_spl_op smtcoq_core; rewrite H4; [exists h2; exists h1|exists h1; exists h2]; auto with smtcoq_spl_op smtcoq_core. + rewrite distinct_false_spec; intros [v2 [v1 [H5 H6]]]; rewrite H4 in H5; destruct H5 as [a [b [H5 [H7 H8]]]]; clear H4; change (Typ.i_eqb t_i A v2 v1 = true) with (is_true (Typ.i_eqb t_i A v2 v1)) in H6; rewrite Typ.i_eqb_spec in H6; subst v2; clear H2; destruct (H3 _ _ H5) as [i [H2 [H4 [hb [H6 [H9 H10]]]]]]; clear H3; symmetry; apply (afold_left_andb_false _ i); auto with smtcoq_spl_op smtcoq_core; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto with smtcoq_spl_op smtcoq_core); unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_spl_op smtcoq_core; rewrite H6; simpl; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; destruct H10 as [H10|H10]; rewrite H10; simpl; rewrite H7, H8; simpl; rewrite Typ.cast_refl; simpl; replace (Typ.i_eqb t_i A v1 v1) with true; auto with smtcoq_spl_op smtcoq_core; symmetry; change (is_true (Typ.i_eqb t_i A v1 v1)); rewrite Typ.i_eqb_spec; auto with smtcoq_spl_op smtcoq_core. intros [a [H20 H21]]; assert (H4: ha < length t_atom). - case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate. - unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H20); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H21; simpl in H21; elim H21; apply Typ.eqb_spec; auto. + case_eq (ha < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H1; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_atom; discriminate. + unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H20); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H21; simpl in H21; elim H21; apply Typ.eqb_spec; auto with smtcoq_spl_op smtcoq_core. Qed. Lemma interp_check_distinct_two_args : forall f1 f2, check_distinct_two_args f1 f2 = true -> rho f1 = negb (rho f2). Proof. - intros f1 f2; rewrite check_distinct_two_args_spec; intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; unfold Form.interp_state_var; assert (H5: f1 < length t_form) by (case_eq (f1 < length t_form); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); assert (H6: f2 < length t_form) by (case_eq (f2 < length t_form); auto; intro Heq; generalize H2; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); rewrite !Form.t_interp_wf; auto; rewrite H1, H2; simpl; unfold Atom.interp_form_hatom, Atom.interp_hatom; rewrite !Atom.t_interp_wf; auto; rewrite H3, H4; simpl; unfold Atom.wt,is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H7: hb < length t_atom) by (case_eq (hb < length t_atom); auto; intro Heq; generalize H4; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate); generalize (wt_t_atom _ H7); rewrite H4; simpl; case (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) hb); try discriminate; simpl; rewrite andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A)); rewrite !Typ.eqb_spec; intros [H8 H9]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom x), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom y); rewrite H8, H9; intros [v1 HH1] [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; auto; rewrite Typ.i_eqb_sym; auto. + intros f1 f2; rewrite check_distinct_two_args_spec; intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; unfold Form.interp_state_var; assert (H5: f1 < length t_form) by (case_eq (f1 < length t_form); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H1; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_form; discriminate); assert (H6: f2 < length t_form) by (case_eq (f2 < length t_form); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H2; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_form; discriminate); rewrite !Form.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H1, H2; simpl; unfold Atom.interp_form_hatom, Atom.interp_hatom; rewrite !Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H3, H4; simpl; unfold Atom.wt,is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H7: hb < length t_atom) by (case_eq (hb < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H4; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_atom; discriminate); generalize (wt_t_atom _ H7); rewrite H4; simpl; case (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) hb); try discriminate; simpl; rewrite andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A)); rewrite !Typ.eqb_spec; intros [H8 H9]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom x), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom y); rewrite H8, H9; intros [v1 HH1] [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; auto with smtcoq_spl_op smtcoq_core; rewrite Typ.i_eqb_sym; auto with smtcoq_spl_op smtcoq_core. Qed. @@ -308,13 +308,13 @@ intros. destruct H0; now contradict H0. (* check_distinct ha diseq -> *) (* interp_form_hatom ha -> afold_left bool int true andb (Lit.interp rho) diseq. *) (* Proof. *) - (* intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H]]]; rewrite check_diseqs_spec in H; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. *) - (* intros l H2; unfold is_true; rewrite distinct_spec; intro H3; apply afold_left_andb_true; intros i Hi; destruct (H _ Hi) as [H4 [a [H5 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H5; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H10: a < length t_atom). *) - (* case_eq (a < length t_atom); auto; intro H10; rewrite (get_outofbound _ _ _ H10) in H6; rewrite default_t_atom in H6; inversion H6. *) - (* generalize (wt_t_atom _ H10); rewrite H6; simpl; rewrite !andb_true_iff. change (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A)); change (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A)); rewrite !Typ.eqb_spec; intros [[_ H11] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H11; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H3; auto; rewrite H2; [exists h2; exists h1|exists h1; exists h2]; auto. *) + (* intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H]]]; rewrite check_diseqs_spec in H; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. *) + (* intros l H2; unfold is_true; rewrite distinct_spec; intro H3; apply afold_left_andb_true; intros i Hi; destruct (H _ Hi) as [H4 [a [H5 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto with smtcoq_spl_op smtcoq_core); unfold Var.interp; rewrite Form.wf_interp_form; auto with smtcoq_spl_op smtcoq_core; rewrite H5; simpl; rewrite Atom.t_interp_wf; auto with smtcoq_spl_op smtcoq_core; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H10: a < length t_atom). *) + (* case_eq (a < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro H10; rewrite (get_outofbound _ _ _ H10) in H6; rewrite default_t_atom in H6; inversion H6. *) + (* generalize (wt_t_atom _ H10); rewrite H6; simpl; rewrite !andb_true_iff. change (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A)); change (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A)); rewrite !Typ.eqb_spec; intros [[_ H11] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H11; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H3; auto with smtcoq_spl_op smtcoq_core; rewrite H2; [exists h2; exists h1|exists h1; exists h2]; auto with smtcoq_spl_op smtcoq_core. *) (* intros [a [H2 H3]] _; assert (H4: ha < length t_atom). *) - (* case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate. *) - (* unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H2); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H3; simpl in H3; elim H3; apply Typ.eqb_spec; auto. *) + (* case_eq (ha < length t_atom); auto with smtcoq_spl_op smtcoq_core; intro Heq; generalize H1; rewrite get_outofbound; auto with smtcoq_spl_op smtcoq_core; rewrite default_t_atom; discriminate. *) + (* unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H2); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H3; simpl in H3; elim H3; apply Typ.eqb_spec; auto with smtcoq_spl_op smtcoq_core. *) (* Qed. *) End Valid1. @@ -382,18 +382,18 @@ intros. destruct H0; now contradict H0. check_lit l1 l2 -> Lit.interp rho l1 = Lit.interp rho l2. Proof. unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[H1 H2]]|[H1 H2]]. - rewrite eqb_spec in H1; rewrite H1; auto. - rewrite Bool.eqb_true_iff in H1; unfold Lit.interp; rewrite H1, (interp_check_var _ _ H2); auto. - generalize H1; unfold Lit.interp; case (Lit.is_pos l1); case (Lit.is_pos l2); try discriminate; intros _; unfold Var.interp; rewrite (interp_check_distinct_two_args _ t_func ch_atom ch_form wt_t_atom _ _ H2); auto; case (rho (Lit.blit l2)); auto. + rewrite eqb_spec in H1; rewrite H1; auto with smtcoq_core. + rewrite Bool.eqb_true_iff in H1; unfold Lit.interp; rewrite H1, (interp_check_var _ _ H2); auto with smtcoq_core. + generalize H1; unfold Lit.interp; case (Lit.is_pos l1); case (Lit.is_pos l2); try discriminate; intros _; unfold Var.interp; rewrite (interp_check_distinct_two_args _ t_func ch_atom ch_form wt_t_atom _ _ H2); auto with smtcoq_core; case (rho (Lit.blit l2)); auto with smtcoq_core. Qed. (* Lemma interp_check_lit : forall l1 l2, *) (* check_lit l1 l2 -> Lit.interp rho l1 -> Lit.interp rho l2 = true. *) (* Proof. *) (* unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[[H1 H2] H3]]|[[H1 H2] H3]]. *) - (* rewrite Int63Properties.eqb_spec in H1; subst l1; auto. *) - (* unfold Lit.interp; rewrite H1, H2; apply interp_check_var; auto. *) - (* unfold Lit.interp; case_eq (Lit.is_pos l1); intro Heq; rewrite Heq in H1; try discriminate; clear Heq H1; case_eq (Lit.is_pos l2); intro Heq; rewrite Heq in H2; try discriminate; clear Heq H2; case_eq (Var.interp rho (Lit.blit l1)); try discriminate; intros H4 _; case_eq (Var.interp rho (Lit.blit l2)); auto; intro H5; rewrite (interp_check_var _ _ H3 H5) in H4; discriminate. *) + (* rewrite Int63Properties.eqb_spec in H1; subst l1; auto with smtcoq_core. *) + (* unfold Lit.interp; rewrite H1, H2; apply interp_check_var; auto with smtcoq_core. *) + (* unfold Lit.interp; case_eq (Lit.is_pos l1); intro Heq; rewrite Heq in H1; try discriminate; clear Heq H1; case_eq (Lit.is_pos l2); intro Heq; rewrite Heq in H2; try discriminate; clear Heq H2; case_eq (Var.interp rho (Lit.blit l1)); try discriminate; intros H4 _; case_eq (Var.interp rho (Lit.blit l2)); auto with smtcoq_core; intro H5; rewrite (interp_check_var _ _ H3 H5) in H4; discriminate. *) (* Qed. *) (* Local Hint Resolve interp_check_lit. *) @@ -402,72 +402,72 @@ intros. destruct H0; now contradict H0. check_form_aux a b -> Form.interp interp_form_hatom interp_form_hatom_bv t_form a = Form.interp interp_form_hatom interp_form_hatom_bv t_form b. Proof. - intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3|a l1] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3|b m1]; simpl; try discriminate;auto. + intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3|a l1] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3|b m1]; simpl; try discriminate;auto with smtcoq_core. (* Atom *) - unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto. + unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto with smtcoq_core. (* Interesting case *) - apply interp_check_distinct; auto. + apply interp_check_distinct; auto with smtcoq_core. (* Double negation *) - unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1. rewrite (interp_check_lit _ _ H2). auto. + unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1. rewrite (interp_check_lit _ _ H2). auto with smtcoq_core. (* Conjunction *) - unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto. + unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto with smtcoq_core; intros i Hi; apply interp_check_lit; auto with smtcoq_core. (* Disjunction *) - unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto. + unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto with smtcoq_core; intros i Hi; apply interp_check_lit; auto with smtcoq_core. (* Implication *) - unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_right_eq; auto; intros i Hi; apply interp_check_lit; auto. + unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_right_eq; auto with smtcoq_core; intros i Hi; apply interp_check_lit; auto with smtcoq_core. (* Xor *) - unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto. + unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto with smtcoq_core. (* Iff *) - unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto. + unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto with smtcoq_core. (* Ite *) - unfold is_true; rewrite !andb_true_iff; intros [[H1 H2] H3]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2), (interp_check_lit _ _ H3); auto. + unfold is_true; rewrite !andb_true_iff; intros [[H1 H2] H3]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2), (interp_check_lit _ _ H3); auto with smtcoq_core. Qed. (* Lemma interp_check_lit_equiv : forall l1 l2, *) (* check_lit l1 l2 -> check_lit l2 l1 -> *) (* Lit.interp rho l1 = Lit.interp rho l2. *) (* Proof. *) - (* intros l1 l2 H1 H2; generalize (interp_check_lit _ _ H1) (interp_check_lit _ _ H2); case (Lit.interp rho l1); case (Lit.interp rho l2); auto; symmetry; auto. *) + (* intros l1 l2 H1 H2; generalize (interp_check_lit _ _ H1) (interp_check_lit _ _ H2); case (Lit.interp rho l1); case (Lit.interp rho l2); auto with smtcoq_core; symmetry; auto with smtcoq_core. *) (* Qed. *) (* Lemma interp_check_form_aux : forall a b, *) (* check_form_aux a b -> *) (* Form.interp interp_form_hatom t_form a -> Form.interp interp_form_hatom t_form b. *) (* Proof. *) - (* intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto. *) + (* intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto with smtcoq_core. *) (* (* Atom *) *) - (* unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto. *) + (* unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto with smtcoq_core. *) (* (* Interesting case *) *) - (* apply interp_check_distinct; auto. *) + (* apply interp_check_distinct; auto with smtcoq_core. *) (* (* Double negation *) *) (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1; apply (fold_ind2 _ _ (fun x y => x = true -> y = true)). *) - (* apply interp_check_lit; auto. *) - (* intros a b; case a; try discriminate; intros H _; rewrite H; auto. *) + (* apply interp_check_lit; auto with smtcoq_core. *) + (* intros a b; case a; try discriminate; intros H _; rewrite H; auto with smtcoq_core. *) (* (* Conjunction *) *) - (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_andb_true_inv _ _ _ H3); clear H3; apply afold_left_andb_true; rewrite <- H1; intros i Hi; eapply interp_check_lit; eauto. *) + (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_andb_true_inv _ _ _ H3); clear H3; apply afold_left_andb_true; rewrite <- H1; intros i Hi; eapply interp_check_lit; eauto with smtcoq_core. *) (* (* Disjunction *) *) (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_orb_true_inv _ _ _ H3); clear H3; destruct H4 as [i [H3 H4]]; eapply afold_left_orb_true. *) - (* rewrite <- H1; eauto. *) - (* eapply interp_check_lit; eauto. *) + (* rewrite <- H1; eauto with smtcoq_core. *) + (* eapply interp_check_lit; eauto with smtcoq_core. *) (* (* Implication *) *) (* unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; apply afold_right_implb_true; case_eq (length a1 == 0); intro Heq. *) - (* left; rewrite eqb_spec in Heq; rewrite <- H1; auto. *) + (* left; rewrite eqb_spec in Heq; rewrite <- H1; auto with smtcoq_core. *) (* destruct (afold_right_implb_true_inv _ _ _ H3) as [H4|[[i [H4 H5]]|H4]]. *) (* rewrite H4 in Heq; discriminate. *) - (* right; left; exists i; rewrite <- H1; split; auto; case_eq (Lit.interp rho (a2 .[ i])); auto; intro H6; assert (H7: i < length a1 = true). *) - (* rewrite ltb_spec in *; rewrite eqb_false_spec in Heq; rewrite to_Z_sub_1_diff in H4; auto; omega. *) - (* generalize (H2 _ H7); rewrite H4; intro H8; rewrite (interp_check_lit _ _ H8 H6) in H5; auto. *) + (* right; left; exists i; rewrite <- H1; split; auto with smtcoq_core; case_eq (Lit.interp rho (a2 .[ i])); auto with smtcoq_core; intro H6; assert (H7: i < length a1 = true). *) + (* rewrite ltb_spec in *; rewrite eqb_false_spec in Heq; rewrite to_Z_sub_1_diff in H4; auto with smtcoq_core; omega. *) + (* generalize (H2 _ H7); rewrite H4; intro H8; rewrite (interp_check_lit _ _ H8 H6) in H5; auto with smtcoq_core. *) (* right; case_eq (existsbi (fun i l => (i < length a2 - 1) && (negb (Lit.interp rho l))) a2). *) - (* rewrite existsbi_spec; intros [i [_ H5]]; rewrite andb_true_iff in H5; destruct H5 as [H5 H6]; left; exists i; split; auto; generalize H6; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *) + (* rewrite existsbi_spec; intros [i [_ H5]]; rewrite andb_true_iff in H5; destruct H5 as [H5 H6]; left; exists i; split; auto with smtcoq_core; generalize H6; case (Lit.interp rho (a2 .[ i])); auto with smtcoq_core; discriminate. *) (* rewrite existsbi_false_spec; intro H; right; intros i Hi; assert (Hi' := Hi); rewrite <- H1 in Hi'; generalize (H2 _ Hi') (H _ Hi); rewrite <- H1; case (i < length a1 - 1); simpl. *) - (* intros _; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *) - (* intros H5 _; apply (interp_check_lit _ _ H5); apply H4; auto. *) + (* intros _; case (Lit.interp rho (a2 .[ i])); auto with smtcoq_core; discriminate. *) + (* intros H5 _; apply (interp_check_lit _ _ H5); apply H4; auto with smtcoq_core. *) (* (* Xor *) *) - (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *) + (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto with smtcoq_core. *) (* (* Iff *) *) - (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *) + (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto with smtcoq_core. *) (* (* Ite *) *) - (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2); case (Lit.interp rho j1); apply interp_check_lit; auto. *) + (* unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2); case (Lit.interp rho j1); apply interp_check_lit; auto with smtcoq_core. *) (* Qed. *) End AUX. @@ -505,50 +505,46 @@ intros. destruct H0; now contradict H0. Let wf_rho : Valuation.wf rho. - Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto. Qed. + Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form); auto with smtcoq_core. Qed. Let default_t_form : default t_form = Ftrue. - Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[H _] _]; auto. Qed. + Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[H _] _]; auto with smtcoq_core. Qed. Let wf_t_form : wf t_form. - Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto. Qed. - - Local Hint Immediate wf_rho default_t_form wf_t_form. + Proof. destruct (Form.check_form_correct interp_form_hatom interp_form_hatom_bv _ ch_form) as [[_ H] _]; auto with smtcoq_core. Qed. Lemma interp_check_hform : forall h1 h2, check_hform h1 h2 -> Var.interp rho h1 = Var.interp rho h2. Proof. unfold check_hform; apply foldi_down_cont_ind; try discriminate. intros i cont _ _ Hrec h1 h2. unfold is_true; rewrite orb_true_iff; intros [H|H]. - rewrite Int63Properties.eqb_spec in H; rewrite H; auto. - unfold Var.interp; rewrite !wf_interp_form; auto; eapply interp_check_form_aux; eauto. + rewrite Int63Properties.eqb_spec in H; rewrite H; auto with smtcoq_core. + unfold Var.interp; rewrite !wf_interp_form; auto with smtcoq_core; eapply interp_check_form_aux; eauto with smtcoq_core. Qed. - Local Hint Resolve interp_check_hform. - Lemma interp_check_form : forall a b, check_form a b -> Form.interp interp_form_hatom interp_form_hatom_bv t_form a = Form.interp interp_form_hatom interp_form_hatom_bv t_form b. - Proof. apply interp_check_form_aux, interp_check_hform; auto. Qed. + Proof. apply interp_check_form_aux, interp_check_hform; auto with smtcoq_core. Qed. Lemma interp_check_lit' : forall l res, check_lit' l res -> Lit.interp rho l = Lit.interp rho res. - Proof. apply interp_check_lit, interp_check_hform; auto. Qed. + Proof. apply interp_check_lit, interp_check_hform; auto with smtcoq_core. Qed. Lemma valid_check_distinct_elim : forall input, C.valid rho input -> forall res, C.valid rho (check_distinct_elim input res). Proof. - induction input as [ |l c IHc]; auto; simpl; unfold C.valid; simpl; rewrite orb_true_iff; intros [H|H] res. + induction input as [ |l c IHc]; auto with smtcoq_core; simpl; unfold C.valid; simpl; rewrite orb_true_iff; intros [H|H] res. case_eq (check_lit' l res); intro Heq; simpl. - rewrite <- (interp_check_lit' _ _ Heq), H; auto. - rewrite H; auto. + rewrite <- (interp_check_lit' _ _ Heq), H; auto with smtcoq_core. + rewrite H; auto with smtcoq_core. case (check_lit' l res). - simpl; rewrite H, orb_true_r; auto. - simpl; rewrite (IHc H), orb_true_r; auto. + simpl; rewrite H, orb_true_r; auto with smtcoq_core. + simpl; rewrite (IHc H), orb_true_r; auto with smtcoq_core. Qed. End Valid. diff --git a/src/trace/coqTerms.ml b/src/trace/coqTerms.ml index ad5ec1d..a1b6765 100644 --- a/src/trace/coqTerms.ml +++ b/src/trace/coqTerms.ml @@ -10,7 +10,6 @@ (**************************************************************************) -open Coqlib open SmtMisc @@ -25,9 +24,9 @@ let ceq63 = gen_constant Structures.int63_modules "eqb" let carray = gen_constant Structures.parray_modules "array" (* nat *) -let cnat = gen_constant init_modules "nat" -let cO = gen_constant init_modules "O" -let cS = gen_constant init_modules "S" +let cnat = gen_constant Structures.init_modules "nat" +let cO = gen_constant Structures.init_modules "O" +let cS = gen_constant Structures.init_modules "S" (* Positive *) let positive_modules = [["Coq";"Numbers";"BinNums"]; @@ -72,49 +71,49 @@ let ceqbZ = gen_constant z_modules "eqb" (* Booleans *) let bool_modules = [["Coq";"Bool";"Bool"]] -let cbool = gen_constant init_modules "bool" -let ctrue = gen_constant init_modules "true" -let cfalse = gen_constant init_modules "false" -let candb = gen_constant init_modules "andb" -let corb = gen_constant init_modules "orb" -let cxorb = gen_constant init_modules "xorb" -let cnegb = gen_constant init_modules "negb" -let cimplb = gen_constant init_modules "implb" +let cbool = gen_constant Structures.init_modules "bool" +let ctrue = gen_constant Structures.init_modules "true" +let cfalse = gen_constant Structures.init_modules "false" +let candb = gen_constant Structures.init_modules "andb" +let corb = gen_constant Structures.init_modules "orb" +let cxorb = gen_constant Structures.init_modules "xorb" +let cnegb = gen_constant Structures.init_modules "negb" +let cimplb = gen_constant Structures.init_modules "implb" let ceqb = gen_constant bool_modules "eqb" let cifb = gen_constant bool_modules "ifb" -let ciff = gen_constant init_modules "iff" +let ciff = gen_constant Structures.init_modules "iff" let creflect = gen_constant bool_modules "reflect" (* Lists *) -let clist = gen_constant init_modules "list" -let cnil = gen_constant init_modules "nil" -let ccons = gen_constant init_modules "cons" -let clength = gen_constant init_modules "length" +let clist = gen_constant Structures.init_modules "list" +let cnil = gen_constant Structures.init_modules "nil" +let ccons = gen_constant Structures.init_modules "cons" +let clength = gen_constant Structures.init_modules "length" (* Option *) -let coption = gen_constant init_modules "option" -let cSome = gen_constant init_modules "Some" -let cNone = gen_constant init_modules "None" +let coption = gen_constant Structures.init_modules "option" +let cSome = gen_constant Structures.init_modules "Some" +let cNone = gen_constant Structures.init_modules "None" (* Pairs *) -let cpair = gen_constant init_modules "pair" -let cprod = gen_constant init_modules "prod" +let cpair = gen_constant Structures.init_modules "pair" +let cprod = gen_constant Structures.init_modules "prod" (* Dependent pairs *) -let csigT = gen_constant init_modules "sigT" -(* let cprojT1 = gen_constant init_modules "projT1" *) -(* let cprojT2 = gen_constant init_modules "projT2" *) -(* let cprojT3 = gen_constant init_modules "projT3" *) +let csigT = gen_constant Structures.init_modules "sigT" +(* let cprojT1 = gen_constant Structures.init_modules "projT1" *) +(* let cprojT2 = gen_constant Structures.init_modules "projT2" *) +(* let cprojT3 = gen_constant Structures.init_modules "projT3" *) -(* let csigT2 = gen_constant init_modules "sigT2" *) -(* let csigT_of_sigT2 = gen_constant init_modules "sigT_of_sigT2" *) +(* let csigT2 = gen_constant Structures.init_modules "sigT2" *) +(* let csigT_of_sigT2 = gen_constant Structures.init_modules "sigT_of_sigT2" *) (* Logical Operators *) -let cnot = gen_constant init_modules "not" -let ceq = gen_constant init_modules "eq" -let crefl_equal = gen_constant init_modules "eq_refl" -let cconj = gen_constant init_modules "conj" -let cand = gen_constant init_modules "and" +let cnot = gen_constant Structures.init_modules "not" +let ceq = gen_constant Structures.init_modules "eq" +let crefl_equal = gen_constant Structures.init_modules "eq_refl" +let cconj = gen_constant Structures.init_modules "conj" +let cand = gen_constant Structures.init_modules "and" (* Bit vectors *) let bv_modules = [["SMTCoq";"bva";"BVList";"BITVECTOR_LIST"]] diff --git a/src/trace/smtCommands.ml b/src/trace/smtCommands.ml index e64a131..b1f2666 100644 --- a/src/trace/smtCommands.ml +++ b/src/trace/smtCommands.ml @@ -115,7 +115,7 @@ let interp_conseq_uf t_i (prem, concl) = let tf = Hashtbl.create 17 in let rec interp = function | [] -> mklApp cis_true [|interp_uf t_i ta tf concl|] - | c::prem -> Term.mkArrow (mklApp cis_true [|interp_uf t_i ta tf c|]) (interp prem) in + | c::prem -> Structures.mkArrow (mklApp cis_true [|interp_uf t_i ta tf c|]) (interp prem) in interp prem diff --git a/src/trace/smtForm.ml b/src/trace/smtForm.ml index 12aef5a..044ff4c 100644 --- a/src/trace/smtForm.ml +++ b/src/trace/smtForm.ml @@ -80,11 +80,11 @@ module type FORM = val clear : reify -> unit val get : ?declare:bool -> reify -> pform -> t - (** Give a coq term, build the corresponding formula *) + (** Given a coq term, build the corresponding formula *) val of_coq : (Structures.constr -> hatom) -> reify -> Structures.constr -> t val hash_hform : (hatom -> hatom) -> reify -> t -> t - (** Flattening of [Fand] and [For], removing of [Fnot2] *) + (* Flattening of [Fand] and [For], removing of [Fnot2] *) val flatten : reify -> t -> t (** Turn n-ary [Fand] and [For] into their right-associative @@ -100,10 +100,10 @@ module type FORM = val to_array : reify -> 'a -> (pform -> 'a) -> int * 'a array val interp_tbl : reify -> Structures.constr * Structures.constr val nvars : reify -> int - (** Producing a Coq term corresponding to the interpretation - of a formula *) - (** [interp_atom] map [hatom] to coq term, it is better if it produce - shared terms. *) + (* Producing a Coq term corresponding to the interpretation + of a formula *) + (* [interp_atom] map [hatom] to coq term, it is better if it produce + shared terms. *) val interp_to_coq : (hatom -> Structures.constr) -> (int, Structures.constr) Hashtbl.t -> t -> Structures.constr @@ -589,9 +589,9 @@ module Make (Atom:ATOM) = (mkInt i, Structures.mkArray (Lazy.force cform, t)) let nvars reify = reify.count - (** Producing a Coq term corresponding to the interpretation of a formula *) - (** [interp_atom] map [Atom.t] to coq term, it is better if it produce - shared terms. *) + (* Producing a Coq term corresponding to the interpretation of a formula *) + (* [interp_atom] map [Atom.t] to coq term, it is better if it produce + shared terms. *) let interp_to_coq interp_atom form_tbl f = let rec interp_form f = let l = to_lit f in diff --git a/src/trace/smtForm.mli b/src/trace/smtForm.mli index ad7d2ca..fead657 100644 --- a/src/trace/smtForm.mli +++ b/src/trace/smtForm.mli @@ -97,10 +97,10 @@ module type FORM = val to_array : reify -> 'a -> (pform -> 'a) -> int * 'a array val interp_tbl : reify -> Structures.constr * Structures.constr val nvars : reify -> int - (** Producing a Coq term corresponding to the interpretation - of a formula *) - (** [interp_atom] map [hatom] to coq term, it is better if it produce - shared terms. *) + (* Producing a Coq term corresponding to the interpretation + of a formula *) + (* [interp_atom] map [hatom] to coq term, it is better if it produce + shared terms. *) val interp_to_coq : (hatom -> Structures.constr) -> (int, Structures.constr) Hashtbl.t -> t -> Structures.constr diff --git a/src/trace/smtMisc.ml b/src/trace/smtMisc.ml index 92f0f09..607ebe7 100644 --- a/src/trace/smtMisc.ml +++ b/src/trace/smtMisc.ml @@ -46,7 +46,7 @@ type logic_item = module SL = Set.Make (struct type t = logic_item - let compare = Pervasives.compare + let compare = Stdlib.compare end) type logic = SL.t diff --git a/src/trace/smtTrace.ml b/src/trace/smtTrace.ml index f397826..ef017a7 100644 --- a/src/trace/smtTrace.ml +++ b/src/trace/smtTrace.ml @@ -159,7 +159,7 @@ let order_roots init_index first = r := n | _ -> failwith "root value has unexpected form" end done; - let _, lr = List.sort (fun (i1, _) (i2, _) -> Pervasives.compare i1 i2) !acc + let _, lr = List.sort (fun (i1, _) (i2, _) -> Stdlib.compare i1 i2) !acc |> List.split in let link_to c1 c2 = let curr_id = c2.id -1 in @@ -476,7 +476,7 @@ let to_coq to_lit interp (cstep, let concl' = out_cl [concl] in let app_name = Structures.mkId ("app" ^ (string_of_int (Hashtbl.hash concl))) in let app_var = Structures.mkVar app_name in - let app_ty = Term.mkArrow clemma (interp ([], [concl])) in + let app_ty = Structures.mkArrow clemma (interp ([], [concl])) in cuts := (app_name, app_ty)::!cuts; mklApp cForallInst [|out_c c; clemma; cplemma; concl'; app_var|] end diff --git a/src/verit/veritSyntax.ml b/src/verit/veritSyntax.ml index b1a6304..862a628 100644 --- a/src/verit/veritSyntax.ml +++ b/src/verit/veritSyntax.ml @@ -150,7 +150,7 @@ let mkCongrPred p = (* Linear arithmetic *) let mkMicromega cl = - let _tbl, _f, cert = Lia.build_lia_certif cl in + let cert = Lia.build_lia_certif cl in let c = match cert with | None -> failwith "VeritSyntax.mkMicromega: micromega can't solve this" @@ -168,7 +168,7 @@ let mkSplArith orig cl = match orig.value with | Some [orig'] -> orig' | _ -> failwith "VeritSyntax.mkSplArith: wrong number of literals in the premise clause" in - let _tbl, _f, cert = Lia.build_lia_certif [Form.neg orig';res] in + let cert = Lia.build_lia_certif [Form.neg orig';res] in let c = match cert with | None -> failwith "VeritSyntax.mkSplArith: micromega can't solve this" diff --git a/src/versions/standard/Array/PArray_standard.v b/src/versions/standard/Array/PArray_standard.v index 83bc943..99a7e65 100644 --- a/src/versions/standard/Array/PArray_standard.v +++ b/src/versions/standard/Array/PArray_standard.v @@ -14,6 +14,8 @@ trees *) +Declare Scope array_scope. + Require Import Int31. Require Export Int63. Require FMapAVL. diff --git a/src/versions/standard/Int63/Int63Native_standard.v b/src/versions/standard/Int63/Int63Native_standard.v index a5a931b..abb91ee 100644 --- a/src/versions/standard/Int63/Int63Native_standard.v +++ b/src/versions/standard/Int63/Int63Native_standard.v @@ -20,6 +20,7 @@ Definition size := size. Notation int := int31. +Declare Scope int63_scope. Delimit Scope int63_scope with int. Bind Scope int63_scope with int. diff --git a/src/versions/standard/Makefile.local b/src/versions/standard/Makefile.local index 8abc72c..c57842a 100644 --- a/src/versions/standard/Makefile.local +++ b/src/versions/standard/Makefile.local @@ -25,6 +25,10 @@ clean:: CAMLLEX = $(CAMLBIN)ocamllex CAMLYACC = $(CAMLBIN)ocamlyacc +CAMLPKGS += -package num + +merlin-hook:: + $(HIDE)echo 'PKG num' >> .merlin %.ml : %.mll $(CAMLLEX) $< diff --git a/src/versions/standard/_CoqProject b/src/versions/standard/_CoqProject index e067da8..d7cffca 100644 --- a/src/versions/standard/_CoqProject +++ b/src/versions/standard/_CoqProject @@ -38,9 +38,6 @@ versions/standard/Int63/Int63Axioms.v versions/standard/Int63/Int63Properties.v versions/standard/Array/PArray.v -versions/standard/mutils_full.ml -versions/standard/mutils_full.mli -versions/standard/coq_micromega_full.ml versions/standard/Structures.v versions/standard/structures.ml versions/standard/structures.mli @@ -156,5 +153,5 @@ SMT_terms.v State.v Trace.v -g_smtcoq.ml4 +g_smtcoq.mlg smtcoq_plugin.mlpack diff --git a/src/versions/standard/coq_micromega_full.ml b/src/versions/standard/coq_micromega_full.ml deleted file mode 100644 index d957110..0000000 --- a/src/versions/standard/coq_micromega_full.ml +++ /dev/null @@ -1,2215 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to expose more functions than - coq_micromega.mli does. - See https://github.com/coq/coq/issues/9749 . ***) - - -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* ** Toplevel definition of tactics ** *) -(* *) -(* - Modules ISet, M, Mc, Env, Cache, CacheZ *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-20011 *) -(* *) -(************************************************************************) - -open Pp -open Names -open Goptions -open Mutils_full -open Constr -open Tactypes - -module Micromega = Micromega_plugin.Micromega -module Certificate = Micromega_plugin.Certificate -module Sos_types = Micromega_plugin.Sos_types -module Mfourier = Micromega_plugin.Mfourier - -(** - * Debug flag - *) - -let debug = false - -(* Limit the proof search *) - -let max_depth = max_int - -(* Search limit for provers over Q R *) -let lra_proof_depth = ref max_depth - - -(* Search limit for provers over Z *) -let lia_enum = ref true -let lia_proof_depth = ref max_depth - -let get_lia_option () = - (!lia_enum,!lia_proof_depth) - -let get_lra_option () = - !lra_proof_depth - - - -let _ = - - let int_opt l vref = - { - optdepr = false; - optname = List.fold_right (^) l ""; - optkey = l ; - optread = (fun () -> Some !vref); - optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v)) - } in - - let lia_enum_opt = - { - optdepr = false; - optname = "Lia Enum"; - optkey = ["Lia2";"Enum"]; - optread = (fun () -> !lia_enum); - optwrite = (fun x -> lia_enum := x) - } in - let _ = declare_int_option (int_opt ["Lra2"; "Depth"] lra_proof_depth) in - let _ = declare_int_option (int_opt ["Lia2"; "Depth"] lia_proof_depth) in - let _ = declare_bool_option lia_enum_opt in - () - -(** - * Initialize a tag type to the Tag module declaration (see Mutils). - *) - -type tag = Tag.t - -(** - * An atom is of the form: - * pExpr1 \{<,>,=,<>,<=,>=\} pExpr2 - * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are - * parametrized by 'cst, which is used as the type of constants. - *) - -type 'cst atom = 'cst Micromega.formula - -(** - * Micromega's encoding of formulas. - * By order of appearance: boolean constants, variables, atoms, conjunctions, - * disjunctions, negation, implication. -*) - -type 'cst formula = - | TT - | FF - | X of EConstr.constr - | A of 'cst atom * tag * EConstr.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.Id.t option * 'cst formula - -(** - * Formula pretty-printer. - *) - -let rec pp_formula o f = - match f with - | TT -> output_string o "tt" - | FF -> output_string o "ff" - | X c -> output_string o "X " - | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t - | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 - | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.Id.to_string id - | None -> "") pp_formula f2 - | N(f) -> Printf.fprintf o "N(%a)" pp_formula f - - -let rec map_atoms fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X x - | A (at,tg,cstr) -> A(fct at,tg,cstr) - | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) - | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) - | N f -> N(map_atoms fct f) - | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) - -let rec map_prop fct f = - match f with - | TT -> TT - | FF -> FF - | X x -> X (fct x) - | A (at,tg,cstr) -> A(at,tg,cstr) - | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) - | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) - | N f -> N(map_prop fct f) - | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) - -(** - * Collect the identifiers of a (string of) implications. Implication labels - * are inherited from Coq/CoC's higher order dependent type constructor (Pi). - *) - -let rec ids_of_formula f = - match f with - | I(f1,Some id,f2) -> id::(ids_of_formula f2) - | _ -> [] - -(** - * A clause is a list of (tagged) nFormulas. - * nFormulas are normalized formulas, i.e., of the form: - * cPol \{=,<>,>,>=\} 0 - * with cPol compact polynomials (see the Pol inductive type in EnvRing.v). - *) - -type 'cst clause = ('cst Micromega.nFormula * tag) list - -(** - * A CNF is a list of clauses. - *) - -type 'cst cnf = ('cst clause) list - -(** - * True and False are empty cnfs and clauses. - *) - -let tt : 'cst cnf = [] - -let ff : 'cst cnf = [ [] ] - -(** - * A refinement of cnf with tags left out. This is an intermediary form - * between the cnf tagged list representation ('cst cnf) used to solve psatz, - * and the freeform formulas ('cst formula) that is retrieved from Coq. - *) - -module Mc = Micromega - -type 'cst mc_cnf = ('cst Mc.nFormula) list list - -(** - * From a freeform formula, build a cnf. - * The parametric functions negate and normalize are theory-dependent, and - * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v - * and RingMicromega.v). - *) - -type 'a tagged_option = T of tag list | S of 'a - -let cnf - (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) - (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = - - let negate a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in - - let normalise a t = - List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in - - let and_cnf x y = x @ y in - -let rec add_term t0 = function - | [] -> - (match deduce (fst t0) (fst t0) with - | Some u -> if unsat u then T [snd t0] else S (t0::[]) - | None -> S (t0::[])) - | t'::cl0 -> - (match deduce (fst t0) (fst t') with - | Some u -> - if unsat u - then T [snd t0 ; snd t'] - else (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l) - | None -> - (match add_term t0 cl0 with - | S cl' -> S (t'::cl') - | T l -> T l)) in - - - let rec or_clause cl1 cl2 = - match cl1 with - | [] -> S cl2 - | t0::cl -> - (match add_term t0 cl2 with - | S cl' -> or_clause cl cl' - | T l -> T l) in - - - - let or_clause_cnf t f = - List.fold_right (fun e (acc,tg) -> - match or_clause t e with - | S cl -> (cl :: acc,tg) - | T l -> (acc,tg@l)) f ([],[]) in - - - let rec or_cnf f f' = - match f with - | [] -> tt,[] - | e :: rst -> - let (rst_f',t) = or_cnf rst f' in - let (e_f', t') = or_clause_cnf e f' in - (rst_f' @ e_f', t @ t') in - - - let rec xcnf (polarity : bool) f = - match f with - | TT -> if polarity then (tt,[]) else (ff,[]) - | FF -> if polarity then (ff,[]) else (tt,[]) - | X p -> if polarity then (ff,[]) else (ff,[]) - | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) - | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then and_cnf e1 e2, t1 @ t2 - else let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - | D(e1,e2) -> - let e1,t1 = xcnf polarity e1 in - let e2,t2 = xcnf polarity e2 in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 - | I(e1,_,e2) -> - let e1 , t1 = (xcnf (not polarity) e1) in - let e2 , t2 = (xcnf polarity e2) in - if polarity - then let f',t' = or_cnf e1 e2 in - (f', t1 @ t2 @ t') - else and_cnf e1 e2, t1 @ t2 in - - xcnf true f - -(** - * MODULE: Ordered set of integers. - *) - -module ISet = Set.Make(Int) - -(** - * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of - * elements of m that are at position i0,...,iN. - *) - -let selecti s m = - let rec xselecti i m = - match m with - | [] -> [] - | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in - xselecti 0 m - -(** - * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted - * code. This includes initializing Caml variables based on Coq terms, parsing - * various Coq expressions into Caml, and dumping Caml expressions into Coq. - * - * Opened here and in csdpcert.ml. - *) - -module M = -struct - - (** - * Location of the Coq libraries. - *) - - let logic_dir = ["Coq";"Logic";"Decidable"] - - let mic_modules = - [ - ["Coq";"Lists";"List"]; - ["ZMicromega"]; - ["Tauto"]; - ["RingMicromega"]; - ["EnvRing"]; - ["Coq"; "micromega"; "ZMicromega"]; - ["Coq"; "micromega"; "RMicromega"]; - ["Coq" ; "micromega" ; "Tauto"]; - ["Coq" ; "micromega" ; "RingMicromega"]; - ["Coq" ; "micromega" ; "EnvRing"]; - ["Coq";"QArith"; "QArith_base"]; - ["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"]; - ["LRing_normalise"]] - - let coq_modules = - Coqlib.(init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) - - let bin_module = [["Coq";"Numbers";"BinNums"]] - - let r_modules = - [["Coq";"Reals" ; "Rdefinitions"]; - ["Coq";"Reals" ; "Rpow_def"] ; - ["Coq";"Reals" ; "Raxioms"] ; - ["Coq";"QArith"; "Qreals"] ; - ] - - let z_modules = [["Coq";"ZArith";"BinInt"]] - - (** - * Initialization : a large amount of Caml symbols are derived from - * ZMicromega.v - *) - - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) - let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules - let constant = gen_constant_in_modules "ZMicromega" coq_modules - let bin_constant = gen_constant_in_modules "ZMicromega" bin_module - let r_constant = gen_constant_in_modules "ZMicromega" r_modules - let z_constant = gen_constant_in_modules "ZMicromega" z_modules - let m_constant = gen_constant_in_modules "ZMicromega" mic_modules - - let coq_and = lazy (init_constant "and") - let coq_or = lazy (init_constant "or") - let coq_not = lazy (init_constant "not") - - let coq_iff = lazy (init_constant "iff") - let coq_True = lazy (init_constant "True") - let coq_False = lazy (init_constant "False") - - let coq_cons = lazy (constant "cons") - let coq_nil = lazy (constant "nil") - let coq_list = lazy (constant "list") - - let coq_O = lazy (init_constant "O") - let coq_S = lazy (init_constant "S") - - let coq_N0 = lazy (bin_constant "N0") - let coq_Npos = lazy (bin_constant "Npos") - - let coq_xH = lazy (bin_constant "xH") - let coq_xO = lazy (bin_constant "xO") - let coq_xI = lazy (bin_constant "xI") - - let coq_Z = lazy (bin_constant "Z") - let coq_ZERO = lazy (bin_constant "Z0") - let coq_POS = lazy (bin_constant "Zpos") - let coq_NEG = lazy (bin_constant "Zneg") - - let coq_Q = lazy (constant "Q") - let coq_R = lazy (constant "R") - - let coq_Qmake = lazy (constant "Qmake") - - let coq_Rcst = lazy (constant "Rcst") - - let coq_C0 = lazy (m_constant "C0") - let coq_C1 = lazy (m_constant "C1") - let coq_CQ = lazy (m_constant "CQ") - let coq_CZ = lazy (m_constant "CZ") - let coq_CPlus = lazy (m_constant "CPlus") - let coq_CMinus = lazy (m_constant "CMinus") - let coq_CMult = lazy (m_constant "CMult") - let coq_CInv = lazy (m_constant "CInv") - let coq_COpp = lazy (m_constant "COpp") - - - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - - let coq_proofTerm = lazy (constant "ZArithProof") - let coq_doneProof = lazy (constant "DoneProof") - let coq_ratProof = lazy (constant "RatProof") - let coq_cutProof = lazy (constant "CutProof") - let coq_enumProof = lazy (constant "EnumProof") - - let coq_Zgt = lazy (z_constant "Z.gt") - let coq_Zge = lazy (z_constant "Z.ge") - let coq_Zle = lazy (z_constant "Z.le") - let coq_Zlt = lazy (z_constant "Z.lt") - let coq_Eq = lazy (init_constant "eq") - - let coq_Zplus = lazy (z_constant "Z.add") - let coq_Zminus = lazy (z_constant "Z.sub") - let coq_Zopp = lazy (z_constant "Z.opp") - let coq_Zmult = lazy (z_constant "Z.mul") - let coq_Zpower = lazy (z_constant "Z.pow") - - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - - let coq_Rgt = lazy (r_constant "Rgt") - let coq_Rge = lazy (r_constant "Rge") - let coq_Rle = lazy (r_constant "Rle") - let coq_Rlt = lazy (r_constant "Rlt") - - let coq_Rplus = lazy (r_constant "Rplus") - let coq_Rminus = lazy (r_constant "Rminus") - let coq_Ropp = lazy (r_constant "Ropp") - let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rinv = lazy (r_constant "Rinv") - let coq_Rpower = lazy (r_constant "pow") - let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (r_constant "Q2R") - - - let coq_PEX = lazy (constant "PEX" ) - let coq_PEc = lazy (constant"PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - - let coq_PX = lazy (constant "PX" ) - let coq_Pc = lazy (constant"Pc") - let coq_Pinj = lazy (constant "Pinj") - - let coq_OpEq = lazy (constant "OpEq") - let coq_OpNEq = lazy (constant "OpNEq") - let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") - let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - - let coq_PsatzIn = lazy (constant "PsatzIn") - let coq_PsatzSquare = lazy (constant "PsatzSquare") - let coq_PsatzMulE = lazy (constant "PsatzMulE") - let coq_PsatzMultC = lazy (constant "PsatzMulC") - let coq_PsatzAdd = lazy (constant "PsatzAdd") - let coq_PsatzC = lazy (constant "PsatzC") - let coq_PsatzZ = lazy (constant "PsatzZ") - - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" - [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") - - (** - * Initialization : a few Caml symbols are derived from other libraries; - * QMicromega, ZArithRing, RingMicromega. - *) - - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] "QWitness") - - let coq_Build = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] - "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") - - (** - * Parsing and dumping : transformation functions between Caml and Coq - * data-structures. - * - * dump_* functions go from Micromega to Coq terms - * parse_* functions go from Coq to Micromega terms - * pp_* functions pretty-print Coq terms. - *) - - exception ParseError - - (* A simple but useful getter function *) - - let get_left_construct sigma term = - match EConstr.kind sigma term with - | Construct((_,i),_) -> (i,[| |]) - | App(l,rst) -> - (match EConstr.kind sigma l with - | Construct((_,i),_) -> (i,rst) - | _ -> raise ParseError - ) - | _ -> raise ParseError - - (* Access the Micromega module *) - - (* parse/dump/print from numbers up to expressions and formulas *) - - let rec parse_nat sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.O - | 2 -> Mc.S (parse_nat sigma (c.(0))) - | i -> raise ParseError - - let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) - - let rec dump_nat x = - match x with - | Mc.O -> Lazy.force coq_O - | Mc.S p -> EConstr.mkApp(Lazy.force coq_S,[| dump_nat p |]) - - let rec parse_positive sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.XI (parse_positive sigma c.(0)) - | 2 -> Mc.XO (parse_positive sigma c.(0)) - | 3 -> Mc.XH - | i -> raise ParseError - - let rec dump_positive x = - match x with - | Mc.XH -> Lazy.force coq_xH - | Mc.XO p -> EConstr.mkApp(Lazy.force coq_xO,[| dump_positive p |]) - | Mc.XI p -> EConstr.mkApp(Lazy.force coq_xI,[| dump_positive p |]) - - let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - - let dump_n x = - match x with - | Mc.N0 -> Lazy.force coq_N0 - | Mc.Npos p -> EConstr.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - - let parse_z sigma term = - let (i,c) = get_left_construct sigma term in - match i with - | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive sigma c.(0)) - | 3 -> Mc.Zneg (parse_positive sigma c.(0)) - | i -> raise ParseError - - let dump_z x = - match x with - | Mc.Z0 ->Lazy.force coq_ZERO - | Mc.Zpos p -> EConstr.mkApp(Lazy.force coq_POS,[| dump_positive p|]) - | Mc.Zneg p -> EConstr.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) - - let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) - - let dump_q q = - EConstr.mkApp(Lazy.force coq_Qmake, - [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) - - let parse_q sigma term = - match EConstr.kind sigma term with - | App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then - {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } - else raise ParseError - | _ -> raise ParseError - - - let rec pp_Rcst o cst = - match cst with - | Mc.C0 -> output_string o "C0" - | Mc.C1 -> output_string o "C1" - | Mc.CQ q -> output_string o "CQ _" - | Mc.CZ z -> pp_z o z - | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y - | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y - | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y - | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t - | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t - - - let rec dump_Rcst cst = - match cst with - | Mc.C0 -> Lazy.force coq_C0 - | Mc.C1 -> Lazy.force coq_C1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_CQ, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_CZ, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - - let rec dump_list typ dump_elt l = - match l with - | [] -> EConstr.mkApp(Lazy.force coq_nil,[| typ |]) - | e :: l -> EConstr.mkApp(Lazy.force coq_cons, - [| typ; dump_elt e;dump_list typ dump_elt l|]) - - let pp_list op cl elt o l = - let rec _pp o l = - match l with - | [] -> () - | [e] -> Printf.fprintf o "%a" elt e - | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in - Printf.fprintf o "%s%a%s" op _pp l cl - - let dump_var = dump_positive - - let dump_expr typ dump_z e = - let rec dump_expr e = - match e with - | Mc.PEX n -> EConstr.mkApp(Lazy.force coq_PEX,[| typ; dump_var n |]) - | Mc.PEc z -> EConstr.mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |]) - | Mc.PEadd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEadd, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEsub, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(Lazy.force coq_PEopp, - [| typ; dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(Lazy.force coq_PEmul, - [| typ; dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(Lazy.force coq_PEpow, - [| typ; dump_expr e; dump_n n|]) - in - dump_expr e - - let dump_pol typ dump_c e = - let rec dump_pol e = - match e with - | Mc.Pc n -> EConstr.mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) - | Mc.Pinj(p,pol) -> EConstr.mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) - | Mc.PX(pol1,p,pol2) -> EConstr.mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in - dump_pol e - - let pp_pol pp_c o e = - let rec pp_pol o e = - match e with - | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n - | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol - | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in - pp_pol o e - - let pp_cnf pp_c o f = - let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in - List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f - - let dump_psatz typ dump_z e = - let z = Lazy.force typ in - let rec dump_cone e = - match e with - | Mc.PsatzIn n -> EConstr.mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) - | Mc.PsatzMulC(e,c) -> EConstr.mkApp(Lazy.force coq_PsatzMultC, - [| z; dump_pol z dump_z e ; dump_cone c |]) - | Mc.PsatzSquare e -> EConstr.mkApp(Lazy.force coq_PsatzSquare, - [| z;dump_pol z dump_z e|]) - | Mc.PsatzAdd(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzAdd, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzMulE(e1,e2) -> EConstr.mkApp(Lazy.force coq_PsatzMulE, - [| z; dump_cone e1; dump_cone e2|]) - | Mc.PsatzC p -> EConstr.mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) - | Mc.PsatzZ -> EConstr.mkApp(Lazy.force coq_PsatzZ,[| z|]) in - dump_cone e - - let pp_psatz pp_z o e = - let rec pp_cone o e = - match e with - | Mc.PsatzIn n -> - Printf.fprintf o "(In %a)%%nat" pp_nat n - | Mc.PsatzMulC(e,c) -> - Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c - | Mc.PsatzSquare e -> - Printf.fprintf o "(%a^2)" (pp_pol pp_z) e - | Mc.PsatzAdd(e1,e2) -> - Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzMulE(e1,e2) -> - Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzC p -> - Printf.fprintf o "(%a)%%positive" pp_z p - | Mc.PsatzZ -> - Printf.fprintf o "0" in - pp_cone o e - - let dump_op = function - | Mc.OpEq-> Lazy.force coq_OpEq - | Mc.OpNEq-> Lazy.force coq_OpNEq - | Mc.OpLe -> Lazy.force coq_OpLe - | Mc.OpGe -> Lazy.force coq_OpGe - | Mc.OpGt-> Lazy.force coq_OpGt - | Mc.OpLt-> Lazy.force coq_OpLt - - let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = - EConstr.mkApp(Lazy.force coq_Build, - [| typ; dump_expr typ dump_constant e1 ; - dump_op o ; - dump_expr typ dump_constant e2|]) - - let assoc_const sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> raise ParseError - - let zop_table = [ - coq_Zgt, Mc.OpGt ; - coq_Zge, Mc.OpGe ; - coq_Zlt, Mc.OpLt ; - coq_Zle, Mc.OpLe ] - - let rop_table = [ - coq_Rgt, Mc.OpGt ; - coq_Rge, Mc.OpGe ; - coq_Rlt, Mc.OpLt ; - coq_Rle, Mc.OpLe ] - - let qop_table = [ - coq_Qlt, Mc.OpLt ; - coq_Qle, Mc.OpLe ; - coq_Qeq, Mc.OpEq - ] - - type gl = { env : Environ.env; sigma : Evd.evar_map } - - let is_convertible gl t1 t2 = - Reductionops.is_conv gl.env gl.sigma t1 t2 - - let parse_zop gl (op,args) = - let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_rop gl (op,args) = - let sigma = gl.sigma in - match EConstr.kind sigma op with - | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) - | Ind((n,0),_) -> - if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) - then (Mc.OpEq, args.(1), args.(2)) - else raise ParseError - | _ -> failwith "parse_zop" - - let parse_qop gl (op,args) = - (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - - type 'a op = - | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) - | Opp - | Power - | Ukn of string - - let assoc_ops sigma x l = - try - snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) - with - Not_found -> Ukn "Oups" - - (** - * MODULE: Env is for environment. - *) - - module Env = - struct - let compute_rank_add env sigma v = - let rec _add env n v = - match env with - | [] -> ([v],n) - | e::l -> - if EConstr.eq_constr sigma e v - then (env,n) - else - let (env,n) = _add l ( n+1) v in - (e::env,n) in - let (env, n) = _add env 1 v in - (env, CamlToCoq.positive n) - - let get_rank env sigma v = - - let rec _get_rank env n = - match env with - | [] -> raise (Invalid_argument "get_rank") - | e::l -> - if EConstr.eq_constr sigma e v - then n - else _get_rank l (n+1) in - _get_rank env 1 - - - let empty = [] - - let elements env = env - - end (* MODULE END: Env *) - - (** - * This is the big generic function for expression parsers. - *) - - let parse_expr sigma parse_constant parse_exp ops_spec env term = - if debug - then ( - let _, env = Pfedit.get_current_context () in - Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr_env env sigma term)); - -(* - let constant_or_variable env term = - try - ( Mc.PEc (parse_constant term) , env) - with ParseError -> - let (env,n) = Env.compute_rank_add env term in - (Mc.PEX n , env) in -*) - let parse_variable env term = - let (env,n) = Env.compute_rank_add env sigma term in - (Mc.PEX n , env) in - - let rec parse_expr env term = - let combine env op (t1,t2) = - let (expr1,env) = parse_expr env t1 in - let (expr2,env) = parse_expr env t2 in - (op expr1 expr2,env) in - - try (Mc.PEc (parse_constant term) , env) - with ParseError -> - match EConstr.kind sigma term with - | App(t,args) -> - ( - match EConstr.kind sigma t with - | Const c -> - ( match assoc_ops sigma t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin - try - let (expr,env) = parse_expr env args.(0) in - let power = (parse_exp expr args.(1)) in - (power , env) - with e when CErrors.noncritical e -> - (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) - ) - | _ -> parse_variable env term - ) - | _ -> parse_variable env term in - parse_expr env term - - let zop_spec = - [ - coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; - coq_Zpower , Power] - - let qop_spec = - [ - coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; - coq_Qpower , Power] - - let rop_spec = - [ - coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; - coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; - coq_Rpower , Power] - - let zconstant = parse_z - let qconstant = parse_q - - - let rconst_assoc = - [ - coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; - coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; - coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; - (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) - ] - - let rec rconstant sigma term = - match EConstr.kind sigma term with - | Const x -> - if EConstr.eq_constr sigma term (Lazy.force coq_R0) - then Mc.C0 - else if EConstr.eq_constr sigma term (Lazy.force coq_R1) - then Mc.C1 - else raise ParseError - | App(op,args) -> - begin - try - (* the evaluation order is important in the following *) - let f = assoc_const sigma op rconst_assoc in - let a = rconstant sigma args.(0) in - let b = rconstant sigma args.(1) in - f a b - with - ParseError -> - match op with - | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> - let arg = rconstant sigma args.(0) in - if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} - then raise ParseError (* This is a division by zero -- no semantics *) - else Mc.CInv(arg) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) - | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) - | _ -> raise ParseError - end - - | _ -> raise ParseError - - - let rconstant sigma term = - let _, env = Pfedit.get_current_context () in - if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr_env env sigma term ++ fnl ()); - let res = rconstant sigma term in - if debug then - (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; - res - - - let parse_zexpr sigma = parse_expr sigma - (zconstant sigma) - (fun expr x -> - let exp = (parse_z sigma x) in - match exp with - | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) - zop_spec - - let parse_qexpr sigma = parse_expr sigma - (qconstant sigma) - (fun expr x -> - let exp = parse_z sigma x in - match exp with - | Mc.Zneg _ -> - begin - match expr with - | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) - | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError - end - | _ -> let exp = Mc.Z.to_N exp in - Mc.PEpow(expr,exp)) - qop_spec - - let parse_rexpr sigma = parse_expr sigma - (rconstant sigma) - (fun expr x -> - let exp = Mc.N.of_nat (parse_nat sigma x) in - Mc.PEpow(expr,exp)) - rop_spec - - let parse_arith parse_op parse_expr env cstr gl = - let sigma = gl.sigma in - if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr_env gl.env sigma cstr ++ fnl ()); - match EConstr.kind sigma cstr with - | App(op,args) -> - let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr sigma env lhs in - let (e2,env) = parse_expr sigma env rhs in - ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) - | _ -> failwith "error : parse_arith(2)" - - let parse_zarith = parse_arith parse_zop parse_zexpr - - let parse_qarith = parse_arith parse_qop parse_qexpr - - let parse_rarith = parse_arith parse_rop parse_rexpr - - (* generic parsing of arithmetic expressions *) - - let mkC f1 f2 = C(f1,f2) - let mkD f1 f2 = D(f1,f2) - let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1)) - let mkI f1 f2 = I(f1,None,f2) - - let mkformula_binary g term f1 f2 = - match f1 , f2 with - | X _ , X _ -> X(term) - | _ -> g f1 f2 - - (** - * This is the big generic function for formula parsers. - *) - - let parse_formula gl parse_atom env tg term = - let sigma = gl.sigma in - - let parse_atom env tg t = - try - let (at,env) = parse_atom env t gl in - (A(at,tg,t), env,Tag.next tg) - with e when CErrors.noncritical e -> (X(t),env,tg) in - - let is_prop term = - let sort = Retyping.get_sort_of gl.env gl.sigma term in - Sorts.is_prop sort in - - let rec xparse_formula env tg term = - match EConstr.kind sigma term with - | App(l,rst) -> - (match rst with - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_and) -> - let f,env,tg = xparse_formula env tg a in - let g,env, tg = xparse_formula env tg b in - mkformula_binary mkC term f g,env,tg - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_or) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkD term f g,env,tg - | [|a|] when EConstr.eq_constr sigma l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when EConstr.eq_constr sigma l (Lazy.force coq_iff) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkIff term f g,env,tg - | _ -> parse_atom env tg term) - | Prod(typ,a,b) when EConstr.Vars.noccurn sigma 1 b -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkI term f g,env,tg - | _ when EConstr.eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) - | _ when EConstr.eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) - | _ when is_prop term -> X(term),env,tg - | _ -> raise ParseError - in - xparse_formula env tg ((*Reductionops.whd_zeta*) term) - - let dump_formula typ dump_atom f = - let rec xdump f = - match f with - | TT -> EConstr.mkApp(Lazy.force coq_TT,[|typ|]) - | FF -> EConstr.mkApp(Lazy.force coq_FF,[|typ|]) - | C(x,y) -> EConstr.mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|]) - | I(x,_,y) -> EConstr.mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|]) - | N(x) -> EConstr.mkApp(Lazy.force coq_Neg,[|typ ; xdump x|]) - | A(x,_,_) -> EConstr.mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|]) - | X(t) -> EConstr.mkApp(Lazy.force coq_X,[|typ ; t|]) in - xdump f - - - let prop_env_of_formula sigma form = - let rec doit env = function - | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env sigma t) - | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> - doit (doit env f1) f2 - | N f -> doit env f in - - doit [] form - - let var_env_of_formula form = - - let rec vars_of_expr = function - | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) - | Mc.PEc z -> ISet.empty - | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> - ISet.union (vars_of_expr e1) (vars_of_expr e2) - | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e - in - - let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = - ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in - - let rec doit = function - | TT | FF | X _ -> ISet.empty - | A (a,t,c) -> vars_of_atom a - | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) - | N f -> doit f in - - doit form - - - - - type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) - { - interp_typ : EConstr.constr; - dump_cst : 'cst -> EConstr.constr; - dump_add : EConstr.constr; - dump_sub : EConstr.constr; - dump_opp : EConstr.constr; - dump_mul : EConstr.constr; - dump_pow : EConstr.constr; - dump_pow_arg : Mc.n -> EConstr.constr; - dump_op : (Mc.op2 * EConstr.constr) list - } - -let dump_zexpr = lazy - { - interp_typ = Lazy.force coq_Z; - dump_cst = dump_z; - dump_add = Lazy.force coq_Zplus; - dump_sub = Lazy.force coq_Zminus; - dump_opp = Lazy.force coq_Zopp; - dump_mul = Lazy.force coq_Zmult; - dump_pow = Lazy.force coq_Zpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table - } - -let dump_qexpr = lazy - { - interp_typ = Lazy.force coq_Q; - dump_cst = dump_q; - dump_add = Lazy.force coq_Qplus; - dump_sub = Lazy.force coq_Qminus; - dump_opp = Lazy.force coq_Qopp; - dump_mul = Lazy.force coq_Qmult; - dump_pow = Lazy.force coq_Qpower; - dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table - } - -let rec dump_Rcst_as_R cst = - match cst with - | Mc.C0 -> Lazy.force coq_R0 - | Mc.C1 -> Lazy.force coq_R1 - | Mc.CQ q -> EConstr.mkApp(Lazy.force coq_IQR, [| dump_q q |]) - | Mc.CZ z -> EConstr.mkApp(Lazy.force coq_IZR, [| dump_z z |]) - | Mc.CPlus(x,y) -> EConstr.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMinus(x,y) -> EConstr.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CMult(x,y) -> EConstr.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) - | Mc.CInv t -> EConstr.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) - | Mc.COpp t -> EConstr.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) - - -let dump_rexpr = lazy - { - interp_typ = Lazy.force coq_R; - dump_cst = dump_Rcst_as_R; - dump_add = Lazy.force coq_Rplus; - dump_sub = Lazy.force coq_Rminus; - dump_opp = Lazy.force coq_Ropp; - dump_mul = Lazy.force coq_Rmult; - dump_pow = Lazy.force coq_Rpower; - dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); - dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table - } - - - - -(** [make_goal_of_formula depxr vars props form] where - - vars is an environment for the arithmetic variables occuring in form - - props is an environment for the propositions occuring in form - @return a goal where all the variables and propositions of the formula are quantified - -*) - -let prodn n env b = - let rec prodrec = function - | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, EConstr.mkProd (v,t,b)) - | _ -> assert false - in - prodrec (n,env,b) - -let make_goal_of_formula sigma dexpr form = - - let vars_idx = - List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in - - (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - - let props = prop_env_of_formula sigma form in - - let vars_n = List.map (fun (_,i) -> (Names.Id.of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in - let props_n = List.mapi (fun i _ -> (Names.Id.of_string (Printf.sprintf "__p%i" (i+1))) , EConstr.mkProp) props in - - let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in - - let dump_expr i e = - let rec dump_expr = function - | Mc.PEX n -> EConstr.mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) - | Mc.PEc z -> dexpr.dump_cst z - | Mc.PEadd(e1,e2) -> EConstr.mkApp(dexpr.dump_add, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEsub(e1,e2) -> EConstr.mkApp(dexpr.dump_sub, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEopp e -> EConstr.mkApp(dexpr.dump_opp, - [| dump_expr e|]) - | Mc.PEmul(e1,e2) -> EConstr.mkApp(dexpr.dump_mul, - [| dump_expr e1;dump_expr e2|]) - | Mc.PEpow(e,n) -> EConstr.mkApp(dexpr.dump_pow, - [| dump_expr e; dexpr.dump_pow_arg n|]) - in dump_expr e in - - let mkop op e1 e2 = - try - EConstr.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) - with Not_found -> - EConstr.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in - - let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = - mkop fop (dump_expr i flhs) (dump_expr i frhs) in - - let rec xdump pi xi f = - match f with - | TT -> Lazy.force coq_True - | FF -> Lazy.force coq_False - | C(x,y) -> EConstr.mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) - | D(x,y) -> EConstr.mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) - | I(x,_,y) -> EConstr.mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) - | N(x) -> EConstr.mkArrow (xdump pi xi x) (Lazy.force coq_False) - | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props sigma t in - EConstr.mkRel (pi+idx) in - - let nb_vars = List.length vars_n in - let nb_props = List.length props_n in - - (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) - - let subst_prop p = - let idx = Env.get_rank props sigma p in - EConstr.mkVar (Names.Id.of_string (Printf.sprintf "__p%i" idx)) in - - let form' = map_prop subst_prop form in - - (prodn nb_props (List.map (fun (x,y) -> Name.Name x,y) props_n) - (prodn nb_vars (List.map (fun (x,y) -> Name.Name x,y) vars_n) - (xdump (List.length vars_n) 0 form)), - List.rev props_n, List.rev var_name_pos,form') - - (** - * Given a conclusion and a list of affectations, rebuild a term prefixed by - * the appropriate letins. - * TODO: reverse the list of bindings! - *) - - let set l concl = - let rec xset acc = function - | [] -> acc - | (e::l) -> - let (name,expr,typ) = e in - xset (EConstr.mkNamedLetIn - (Names.Id.of_string name) - expr typ acc) l in - xset concl l - -end (** - * MODULE END: M - *) - -open M - -let coq_Node = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") - -let coq_VarMap = - lazy (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") - - -let rec dump_varmap typ m = - match m with - | Mc.Empty -> EConstr.mkApp(Lazy.force coq_Empty,[| typ |]) - | Mc.Leaf v -> EConstr.mkApp(Lazy.force coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - EConstr.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) - - -let vm_of_list env = - match env with - | [] -> Mc.Empty - | (d,_)::_ -> - List.fold_left (fun vm (c,i) -> - Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env - -let rec dump_proof_term = function - | Micromega.DoneProof -> Lazy.force coq_doneProof - | Micromega.RatProof(cone,rst) -> - EConstr.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) - | Micromega.CutProof(cone,prf) -> - EConstr.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; - dump_proof_term prf|]) - | Micromega.EnumProof(c1,c2,prfs) -> - EConstr.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; - dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) - - -let rec size_of_psatz = function - | Micromega.PsatzIn _ -> 1 - | Micromega.PsatzSquare _ -> 1 - | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) - | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 - | Micromega.PsatzC _ -> 1 - | Micromega.PsatzZ -> 1 - -let rec size_of_pf = function - | Micromega.DoneProof -> 1 - | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) - | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) - -let dump_proof_term t = - if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; - dump_proof_term t - - - -let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden - - -let rec pp_proof_term o = function - | Micromega.DoneProof -> Printf.fprintf o "D" - | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.EnumProof(c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 - (pp_list "[" "]" pp_proof_term) rst - -let rec parse_hyps gl parse_arith env tg hyps = - match hyps with - | [] -> ([],env,tg) - | (i,t)::l -> - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in - try - let (c,env,tg) = parse_formula gl parse_arith env tg t in - ((i,c)::lhyps, env,tg) - with e when CErrors.noncritical e -> (lhyps,env,tg) - (*(if debug then Printf.printf "parse_arith : %s\n" x);*) - - -(*exception ParseError*) - -let parse_goal gl parse_arith env hyps term = - (* try*) - let (f,env,tg) = parse_formula gl parse_arith env (Tag.from 0) term in - let (lhyps,env,tg) = parse_hyps gl parse_arith env tg hyps in - (lhyps,f,env) - (* with Failure x -> raise ParseError*) - -(** - * The datastructures that aggregate theory-dependent proof values. - *) -type ('synt_c, 'prf) domain_spec = { - typ : EConstr.constr; (* is the type of the interpretation domain - Z, Q, R*) - coeff : EConstr.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) - dump_coeff : 'synt_c -> EConstr.constr ; - proof_typ : EConstr.constr ; - dump_proof : 'prf -> EConstr.constr -} - -let zz_domain_spec = lazy { - typ = Lazy.force coq_Z; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z ; - proof_typ = Lazy.force coq_proofTerm ; - dump_proof = dump_proof_term -} - -let qq_domain_spec = lazy { - typ = Lazy.force coq_Q; - coeff = Lazy.force coq_Q; - dump_coeff = dump_q ; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q -} - -(** Naive topological sort of constr according to the subterm-ordering *) - -(* An element is minimal x is minimal w.r.t y if - x <= y or (x and y are incomparable) *) - -(** - * Instanciate the current Coq goal with a Micromega formula, a varmap, and a - * witness. - *) - -let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = - (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in - let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in - let vm = dump_varmap (spec.typ) (vm_of_list env) in - (* todo : directly generate the proof term - or generalize before conversion? *) - Proofview.Goal.nf_enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl)) - ] - end - - -(** - * The datastructures that aggregate prover attributes. - *) - -type ('option,'a,'prf) prover = { - name : string ; (* name of the prover *) - get_option : unit ->'option ; (* find the options of the prover *) - prover : 'option * 'a list -> 'prf option ; (* the prover itself *) - hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *) - compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *) - pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *) - pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*) -} - - - -(** - * Given a list of provers and a disjunction of atoms, find a proof of any of - * the atoms. Returns an (optional) pair of a proof and a prover - * datastructure. - *) - -let find_witness provers polys1 = - let provers = List.map (fun p -> - (fun l -> - match p.prover (p.get_option (),l) with - | None -> None - | Some prf -> Some(prf,p)) , p.name) provers in - try_any provers (List.map fst polys1) - -(** - * Given a list of provers and a CNF, find a proof for each of the clauses. - * Return the proofs as a list. - *) - -let witness_list prover l = - let rec xwitness_list l = - match l with - | [] -> Some [] - | e :: l -> - match find_witness prover e with - | None -> None - | Some w -> - (match xwitness_list l with - | None -> None - | Some l -> Some (w :: l) - ) in - xwitness_list l - -let witness_list_tags = witness_list - -(** - * Prune the proof object, according to the 'diff' between two cnf formulas. - *) - -let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = - - let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let new_cl = List.mapi (fun i (f,_) -> (f,i)) new_cl in - let remap i = - let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in - List.assoc formula new_cl in -(* if debug then - begin - Printf.printf "\ncompact_proof : %a %a %a" - (pp_ml_list prover.pp_f) (List.map fst old_cl) - prover.pp_prf prf - (pp_ml_list prover.pp_f) (List.map fst new_cl) ; - flush stdout - end ; *) - let res = try prover.compact prf remap with x when CErrors.noncritical x -> - if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; - (* This should not happen -- this is the recovery plan... *) - match prover.prover (prover.get_option () ,List.map fst new_cl) with - | None -> failwith "proof compaction error" - | Some p -> p - in - if debug then - begin - Printf.printf " -> %a\n" - prover.pp_prf res ; - flush stdout - end ; - res in - - let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = - let hyps_idx = prover.hyps prf in - let hyps = selecti hyps_idx old_cl in - is_sublist Pervasives.(=) hyps new_cl in - - let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) - - List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' - - -(** - * "Hide out" tagged atoms of a formula by transforming them into generic - * variables. See the Tag module in mutils.ml for more. - *) - -let abstract_formula hyps f = - let rec xabs f = - match f with - | X c -> X c - | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_and, [|a1;a2|])) - | f1 , f2 -> C(f1,f2) ) - | D(f1,f2) -> - (match xabs f1 , xabs f2 with - | X a1 , X a2 -> X (EConstr.mkApp(Lazy.force coq_or, [|a1;a2|])) - | f1 , f2 -> D(f1,f2) ) - | N(f) -> - (match xabs f with - | X a -> X (EConstr.mkApp(Lazy.force coq_not, [|a|])) - | f -> N f) - | I(f1,hyp,f2) -> - (match xabs f1 , hyp, xabs f2 with - | X a1 , Some _ , af2 -> af2 - | X a1 , None , X a2 -> X (EConstr.mkArrow a1 a2) - | af1 , _ , af2 -> I(af1,hyp,af2) - ) - | FF -> FF - | TT -> TT - in xabs f - - -(* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) -let rec abstract_wrt_formula f1 f2 = - match f1 , f2 with - | X c , _ -> X c - | A _ , A _ -> f2 - | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') - | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') - | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') - | FF , FF -> FF - | TT , TT -> TT - | N x , N y -> N(abstract_wrt_formula x y) - | _ -> failwith "abstract_wrt_formula" - -(** - * This exception is raised by really_call_csdpcert if Coq's configure didn't - * find a CSDP executable. - *) - -exception CsdpNotFound - - -(** - * This is the core of Micromega: apply the prover, analyze the result and - * prune unused fomulas, and finally modify the proof state. - *) - -let formula_hyps_concl hyps concl = - List.fold_right - (fun (id,f) (cc,ids) -> - match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) - hyps (concl,[]) - - -let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = - - (* Express the goal as one big implication *) - let (ff,ids) = formula_hyps_concl polys1 polys2 in - - (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in - - if debug then - begin - Feedback.msg_notice (Pp.str "Formula....\n") ; - let formula_typ = (EConstr.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in - let ff = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff - end; - - match witness_list_tags prover cnf_ff with - | None -> None - | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> - let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in - if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; - (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in - - if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; - - let ff' = abstract_formula hyps ff in - let cnf_ff',_ = cnf negate normalise unsat deduce ff' in - - if debug then - begin - Feedback.msg_notice (Pp.str "\nAFormula\n") ; - let formula_typ = (EConstr.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ - (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.pr_leconstr_env gl.env gl.sigma ff'); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' - end; - - (* Even if it does not work, this does not mean it is not provable - -- the prover is REALLY incomplete *) - (* if debug then - begin - (* recompute the proofs *) - match witness_list_tags prover cnf_ff' with - | None -> failwith "abstraction is wrong" - | Some res -> () - end ; *) - let res' = compact_proofs cnf_ff res cnf_ff' in - - let (ff',res',ids) = (ff',res', ids_of_formula ff') in - - let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - Some (ids,ff',res') - - -(** - * Parse the proof environment, and call micromega_tauto - *) - -let fresh_id avoid id gl = - Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) - -let micromega_gen - parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec dumpexpr prover tac = - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - let dumpexpr = Lazy.force dumpexpr in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; - micromega_order_change spec res' - (EConstr.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - - let goal_props = List.rev (prop_env_of_formula sigma ff') in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] - with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - -let micromega_gen parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) - unsat deduce - spec prover = - (micromega_gen parse_arith negate normalise unsat deduce spec prover) - - - -let micromega_order_changer cert env ff = - (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) - let coeff = Lazy.force coq_Rcst in - let dump_coeff = dump_Rcst in - let typ = Lazy.force coq_R in - let cert_typ = (EConstr.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - - let formula_typ = (EConstr.mkApp (Lazy.force coq_Cstr,[| coeff|])) in - let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in - let vm = dump_varmap (typ) (vm_of_list env) in - Proofview.Goal.nf_enter begin fun gl -> - Tacticals.New.tclTHENLIST - [ - (Tactics.change_concl - (set - [ - ("__ff", ff, EConstr.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, EConstr.mkApp - (gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); - ("__wit", cert, cert_typ) - ] - (Tacmach.New.pf_concl gl))); - (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) - ] - end - -let micromega_genr prover tac = - let parse_arith = parse_rarith in - let negate = Mc.rnegate in - let normalise = Mc.rnormalise in - let unsat = Mc.runsat in - let deduce = Mc.rdeduce in - let spec = lazy { - typ = Lazy.force coq_R; - coeff = Lazy.force coq_Rcst; - dump_coeff = dump_q; - proof_typ = Lazy.force coq_QWitness ; - dump_proof = dump_psatz coq_Q dump_q - } in - Proofview.Goal.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_concl gl in - let hyps = Tacmach.New.pf_hyps_types gl in - - try - let gl0 = { env = Tacmach.New.pf_env gl; sigma } in - let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in - let env = Env.elements env in - let spec = Lazy.force spec in - - let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in - let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in - - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with - | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") - | Some (ids,ff',res') -> - let (ff,ids) = formula_hyps_concl - (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in - let ff' = abstract_wrt_formula ff' ff in - - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in - let intro (id,_) = Tactics.introduction id in - - let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in - let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in - let ipat_of_name id = Some (CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) in - let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in - let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in - - let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; - micromega_order_changer res' env' ff_arith ] in - - let goal_props = List.rev (prop_env_of_formula sigma ff') in - - let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in - - let arith_args = goal_props @ goal_vars in - - let kill_arith = - Tacticals.New.tclTHEN - (Tactics.keep []) - ((*Tactics.tclABSTRACT None*) - (Tacticals.New.tclTHEN tac_arith tac)) in - - Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) - [ - kill_arith; - (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.applist (EConstr.mkVar goal_name, arith_args)) - ] ) - ] - - with - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end - - - - -let micromega_genr prover = (micromega_genr prover) - - -let lift_ratproof prover l = - match prover l with - | None -> None - | Some c -> Some (Mc.RatProof( c,Mc.DoneProof)) - -type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list - -[@@@ocaml.warning "-37"] -type csdp_certificate = S of Sos_types.positivstellensatz option | F of string -(* Used to read the result of the execution of csdpcert *) - -type provername = string * int option - -(** - * The caching mechanism. - *) - -open Micromega_plugin.Persistent_cache - -module Cache = PHashtable(struct - type t = (provername * micromega_polys) - let equal = Pervasives.(=) - let hash = Hashtbl.hash -end) - -let csdp_cache = ".csdp.cache" - -(** - * Build the command to call csdpcert, and launch it. This in turn will call - * the sos driver to the csdp executable. - * Throw CsdpNotFound if Coq isn't aware of any csdp executable. - *) - -let require_csdp = - if System.is_in_system_path "csdp" - then lazy () - else lazy (raise CsdpNotFound) - -let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = - fun provername poly -> - - Lazy.force require_csdp; - - let cmdname = - List.fold_left Filename.concat (Envars.coqlib ()) - ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in - - match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> failwith str - | S res -> res - -(** - * Check the cache before calling the prover. - *) - -let xcall_csdpcert = - Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb) - -(** - * Prover callback functions. - *) - -let call_csdpcert prover pb = xcall_csdpcert (prover,pb) - -let rec z_to_q_pol e = - match e with - | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} - | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) - | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) - -let call_csdpcert_q provername poly = - match call_csdpcert provername poly with - | None -> None - | Some cert -> - let cert = Certificate.q_cert_of_pos cert in - if Mc.qWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate") ;None) - -let call_csdpcert_z provername poly = - let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in - match call_csdpcert provername l with - | None -> None - | Some cert -> - let cert = Certificate.z_cert_of_pos cert in - if Mc.zWeakChecker poly cert - then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) - -let xhyps_of_cone base acc prf = - let rec xtract e acc = - match e with - | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc - | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in - if n >= base - then ISet.add (n-base) acc - else acc - | Mc.PsatzMulC(_,c) -> xtract c acc - | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in - - xtract prf acc - -let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf - -let compact_cone prf f = - let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in - - let rec xinterp prf = - match prf with - | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf - | Mc.PsatzIn n -> Mc.PsatzIn (np n) - | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c) - | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2) - | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in - - xinterp prf - -let hyps_of_pt pt = - - let rec xhyps base pt acc = - match pt with - | Mc.DoneProof -> acc - | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.EnumProof(c1,c2,l) -> - let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in - List.fold_left (fun s x -> xhyps (base + 1) x s) s l in - - xhyps 0 pt ISet.empty - -let hyps_of_pt pt = - let res = hyps_of_pt pt in - if debug - then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); - res - -let compact_pt pt f = - let translate ofset x = - if x < ofset then x - else (f (x-ofset) + ofset) in - - let rec compact_pt ofset pt = - match pt with - | Mc.DoneProof -> Mc.DoneProof - | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) - | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)), - Mc.map (fun x -> compact_pt (ofset+1) x) l) in - compact_pt 0 pt - -(** - * Definition of provers. - * Instantiates the type ('a,'prf) prover defined above. - *) - -let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) - -module CacheZ = PHashtable(struct - type prover_option = bool * int - - type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) - -module CacheQ = PHashtable(struct - type t = int * ((Mc.q Mc.pol * Mc.op1) list) - let equal = (=) - let hash = Hashtbl.hash -end) - -let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) -let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) - - - -let linear_prover_Q = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - - -let linear_prover_R = { - name = "linear prover"; - get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let nlinear_prover_R = { - name = "nra"; - get_option = get_lra_option; - prover = memo_nra ; - hyps = hyps_of_cone ; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Q str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone ; - pp_prf = pp_psatz pp_q ; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_R str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> call_csdpcert_q o l); - hyps = hyps_of_cone; - compact = compact_cone; - pp_prf = pp_psatz pp_q; - pp_f = fun o x -> pp_pol pp_q o (fst x) -} - -let non_linear_prover_Z str o = { - name = "real nonlinear prover"; - get_option = (fun () -> (str,o)); - prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l); - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let linear_Z = { - name = "lia"; - get_option = get_lia_option; - prover = memo_zlinear_prover ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -let nlinear_Z = { - name = "nlia"; - get_option = get_lia_option; - prover = memo_nlia ; - hyps = hyps_of_pt; - compact = compact_pt; - pp_prf = pp_proof_term; - pp_f = fun o x -> pp_pol pp_z o (fst x) -} - -(** - * Functions instantiating micromega_gen with the appropriate theories and - * solvers - *) - -let lra_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ linear_prover_Q ] - -let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] - -let lra_R = - micromega_genr [ linear_prover_R ] - -let psatz_R i = - micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] - - -let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] - -let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ non_linear_prover_Z "pure_sos" None ] - -let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ non_linear_prover_Q "pure_sos" None ] - - -let sos_R = - micromega_genr [ non_linear_prover_R "pure_sos" None ] - - -let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ linear_Z ] - -let xnlia = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr - [ nlinear_Z ] - -let nra = - micromega_genr [ nlinear_prover_R ] - -let nqa = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr - [ nlinear_prover_R ] - - - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/src/versions/standard/g_smtcoq_standard.ml4 b/src/versions/standard/g_smtcoq_standard.mlg index 6c3b8cf..443d558 100644 --- a/src/versions/standard/g_smtcoq_standard.ml4 +++ b/src/versions/standard/g_smtcoq_standard.mlg @@ -12,74 +12,76 @@ DECLARE PLUGIN "smtcoq_plugin" -open Stdarg +{ -(* This is requires since Coq 8.7 because the Ltac machinery became a - plugin - see: https://lists.gforge.inria.fr/pipermail/coq-commits/2017-February/021276.html *) +open Stdarg open Ltac_plugin +} + VERNAC COMMAND EXTEND Vernac_zchaff CLASSIFIED AS QUERY | [ "Parse_certif_zchaff" ident(dimacs) ident(trace) string(fdimacs) string(fproof) ] -> - [ + { Zchaff.parse_certif dimacs trace fdimacs fproof - ] + } | [ "Zchaff_Checker" string(fdimacs) string(fproof) ] -> - [ + { Zchaff.checker fdimacs fproof - ] + } | [ "Zchaff_Theorem" ident(name) string(fdimacs) string(fproof) ] -> - [ + { Zchaff.theorem name fdimacs fproof - ] + } END VERNAC COMMAND EXTEND Vernac_verit CLASSIFIED AS QUERY | [ "Parse_certif_verit" ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ + { Verit.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] + } | [ "Verit_Checker" string(fsmt) string(fproof) ] -> - [ + { Verit.checker fsmt fproof - ] + } | [ "Verit_Checker_Debug" string(fsmt) string(fproof) ] -> - [ + { Verit.checker_debug fsmt fproof - ] + } | [ "Verit_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ + { Verit.theorem name fsmt fproof - ] + } END VERNAC COMMAND EXTEND Vernac_lfsc CLASSIFIED AS QUERY | [ "Parse_certif_lfsc" ident(t_i) ident(t_func) ident(t_atom) ident(t_form) ident(root) ident(used_roots) ident(trace) string(fsmt) string(fproof) ] -> - [ + { Lfsc.parse_certif t_i t_func t_atom t_form root used_roots trace fsmt fproof - ] + } | [ "Lfsc_Checker" string(fsmt) string(fproof) ] -> - [ + { Lfsc.checker fsmt fproof - ] + } | [ "Lfsc_Checker_Debug" string(fsmt) string(fproof) ] -> - [ + { Lfsc.checker_debug fsmt fproof - ] + } | [ "Lfsc_Theorem" ident(name) string(fsmt) string(fproof) ] -> - [ + { Lfsc.theorem name fsmt fproof - ] + } END TACTIC EXTEND Tactic_zchaff -| [ "zchaff_bool" ] -> [ Zchaff.tactic () ] -| [ "zchaff_bool_no_check" ] -> [ Zchaff.tactic_no_check () ] +| [ "zchaff_bool" ] -> { Zchaff.tactic () } +| [ "zchaff_bool_no_check" ] -> { Zchaff.tactic_no_check () } END +{ + let lemmas_list = Summary.ref ~name:"Selected lemmas" [] let cache_lemmas (_, lems) = @@ -102,18 +104,20 @@ let clear_lemmas () = let get_lemmas () = !lemmas_list +} + VERNAC COMMAND EXTEND Add_lemma CLASSIFIED AS SIDEFF -| [ "Add_lemmas" constr_list(lems) ] -> [ add_lemmas lems ] -| [ "Clear_lemmas" ] -> [ clear_lemmas () ] +| [ "Add_lemmas" constr_list(lems) ] -> { add_lemmas lems } +| [ "Clear_lemmas" ] -> { clear_lemmas () } END TACTIC EXTEND Tactic_verit -| [ "verit_bool_base" constr_list(lpl) ] -> [ Verit.tactic (List.map EConstr.Unsafe.to_constr lpl) (get_lemmas ()) ] -| [ "verit_bool_no_check_base" constr_list(lpl) ] -> [ Verit.tactic_no_check (List.map EConstr.Unsafe.to_constr lpl) (get_lemmas ()) ] +| [ "verit_bool_base" constr_list(lpl) ] -> { Verit.tactic (List.map EConstr.Unsafe.to_constr lpl) (get_lemmas ()) } +| [ "verit_bool_no_check_base" constr_list(lpl) ] -> { Verit.tactic_no_check (List.map EConstr.Unsafe.to_constr lpl) (get_lemmas ()) } END TACTIC EXTEND Tactic_cvc4 -| [ "cvc4_bool" ] -> [ Lfsc.tactic () ] -| [ "cvc4_bool_no_check" ] -> [ Lfsc.tactic_no_check () ] +| [ "cvc4_bool" ] -> { Lfsc.tactic () } +| [ "cvc4_bool_no_check" ] -> { Lfsc.tactic_no_check () } END diff --git a/src/versions/standard/mutils_full.ml b/src/versions/standard/mutils_full.ml deleted file mode 100644 index efa2e4d..0000000 --- a/src/versions/standard/mutils_full.ml +++ /dev/null @@ -1,358 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to solve a compilation issue due - to a wrong order in dependencies. - See https://github.com/coq/coq/issues/9768 . ***) - - -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(* *) -(* Micromega: A reflexive tactic using the Positivstellensatz *) -(* *) -(* ** Utility functions ** *) -(* *) -(* - Modules CoqToCaml, CamlToCoq *) -(* - Modules Cmp, Tag, TagSet *) -(* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) -(* *) -(************************************************************************) - -module Micromega = Micromega_plugin.Micromega - -let rec pp_list f o l = - match l with - | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l - - -let finally f rst = - try - let res = f () in - rst () ; res - with reraise -> - (try rst () - with any -> raise reraise - ); raise reraise - -let rec try_any l x = - match l with - | [] -> None - | (f,s)::l -> match f x with - | None -> try_any l x - | x -> x - -let all_sym_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::l -> xpairs (pair_with acc e l) l in - xpairs [] l - -let all_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::lx -> xpairs (pair_with acc e l) lx in - xpairs [] l - -let rec is_sublist f l1 l2 = - match l1 ,l2 with - | [] ,_ -> true - | e::l1', [] -> false - | e::l1' , e'::l2' -> - if f e e' then is_sublist f l1' l2' - else is_sublist f l1 l2' - -let extract pred l = - List.fold_left (fun (fd,sys) e -> - match fd with - | None -> - begin - match pred e with - | None -> fd, e::sys - | Some v -> Some(v,e) , sys - end - | _ -> (fd, e::sys) - ) (None,[]) l - -open Num -open Big_int - -let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in - mult_big_int g (mult_big_int x' y') - -let denominator = function - | Int _ | Big_int _ -> unit_big_int - | Ratio r -> Ratio.denominator_ratio r - -let numerator = function - | Ratio r -> Ratio.numerator_ratio r - | Int i -> Big_int.big_int_of_int i - | Big_int i -> i - -let rec ppcm_list c l = - match l with - | [] -> c - | e::l -> ppcm_list (ppcm c (denominator e)) l - -let rec rec_gcd_list c l = - match l with - | [] -> c - | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l - -let gcd_list l = - let res = rec_gcd_list zero_big_int l in - if Int.equal (compare_big_int res zero_big_int) 0 - then unit_big_int else res - -let rats_to_ints l = - let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) - (denominator x))) l - -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) -(** - * MODULE: Coq to Caml data-structure mappings - *) - -module CoqToCaml = -struct - open Micromega - - let rec nat = function - | O -> 0 - | S n -> (nat n) + 1 - - - let rec positive p = - match p with - | XH -> 1 - | XI p -> 1+ 2*(positive p) - | XO p -> 2*(positive p) - - let n nt = - match nt with - | N0 -> 0 - | Npos p -> positive p - - let rec index i = (* Swap left-right ? *) - match i with - | XH -> 1 - | XI i -> 1+(2*(index i)) - | XO i -> 2*(index i) - - open Big_int - - let rec positive_big_int p = - match p with - | XH -> unit_big_int - | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) - | XO p -> (mult_int_big_int 2 (positive_big_int p)) - - let z_big_int x = - match x with - | Z0 -> zero_big_int - | Zpos p -> (positive_big_int p) - | Zneg p -> minus_big_int (positive_big_int p) - - let q_to_num {qnum = x ; qden = y} = - Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) - -end - - -(** - * MODULE: Caml to Coq data-structure mappings - *) - -module CamlToCoq = -struct - open Micromega - - let rec nat = function - | 0 -> O - | n -> S (nat (n-1)) - - - let rec positive n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (positive (n lsr 1)) - else XO (positive (n lsr 1)) - - let n nt = - if nt < 0 - then assert false - else if Int.equal nt 0 then N0 - else Npos (positive nt) - - let rec index n = - if Int.equal n 1 then XH - else if Int.equal (n land 1) 1 then XI (index (n lsr 1)) - else XO (index (n lsr 1)) - - - let z x = - match compare x 0 with - | 0 -> Z0 - | 1 -> Zpos (positive x) - | _ -> (* this should be -1 *) - Zneg (positive (-x)) - - open Big_int - - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = - if eq_big_int n unit_big_int then XH - else - let (q,m) = quomod_big_int n two in - if eq_big_int unit_big_int m - then XI (_pos q) - else XO (_pos q) in - _pos n - - let bigint x = - match sign_big_int x with - | 0 -> Z0 - | 1 -> Zpos (positive_big_int x) - | _ -> Zneg (positive_big_int (minus_big_int x)) - - let q n = - {Micromega.qnum = bigint (numerator n) ; - Micromega.qden = positive_big_int (denominator n)} - -end - -(** - * MODULE: Comparisons on lists: by evaluating the elements in a single list, - * between two lists given an ordering, and using a hash computation - *) - -module Cmp = -struct - - let rec compare_lexical l = - match l with - | [] -> 0 (* Equal *) - | f::l -> - let cmp = f () in - if Int.equal cmp 0 then compare_lexical l else cmp - - let rec compare_list cmp l1 l2 = - match l1 , l2 with - | [] , [] -> 0 - | [] , _ -> -1 - | _ , [] -> 1 - | e1::l1 , e2::l2 -> - let c = cmp e1 e2 in - if Int.equal c 0 then compare_list cmp l1 l2 else c - -end - -(** - * MODULE: Labels for atoms in propositional formulas. - * Tags are used to identify unused atoms in CNFs, and propagate them back to - * the original formula. The translation back to Coq then ignores these - * superfluous items, which speeds the translation up a bit. - *) - -module type Tag = -sig - - type t - - val from : int -> t - val next : t -> t - val pp : out_channel -> t -> unit - val compare : t -> t -> int - -end - -module Tag : Tag = -struct - - type t = int - - let from i = i - let next i = i + 1 - let pp o i = output_string o (string_of_int i) - let compare : int -> int -> int = Int.compare - -end - -(** - * MODULE: Ordered sets of tags. - *) - -module TagSet = Set.Make(Tag) - -(** As for Unix.close_process, our Unix.waipid will ignore all EINTR *) - -let rec waitpid_non_intr pid = - try snd (Unix.waitpid [] pid) - with Unix.Unix_error (Unix.EINTR, _, _) -> waitpid_non_intr pid - -(** - * Forking routine, plumbing the appropriate pipes where needed. - *) - -let command exe_path args vl = - (* creating pipes for stdin, stdout, stderr *) - let (stdin_read,stdin_write) = Unix.pipe () - and (stdout_read,stdout_write) = Unix.pipe () - and (stderr_read,stderr_write) = Unix.pipe () in - - (* Create the process *) - let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in - - (* Write the data on the stdin of the created process *) - let outch = Unix.out_channel_of_descr stdin_write in - output_value outch vl ; - flush outch ; - - (* Wait for its completion *) - let status = waitpid_non_intr pid in - - finally - (* Recover the result *) - (fun () -> - match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin - try Marshal.from_channel inch - with any -> - failwith - (Printf.sprintf "command \"%s\" exited %s" exe_path - (Printexc.to_string any)) - end - | Unix.WEXITED i -> - failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) - | Unix.WSIGNALED i -> - failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) - | Unix.WSTOPPED i -> - failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) - (* Cleanup *) - (fun () -> - List.iter (fun x -> try Unix.close x with any -> ()) - [stdin_read; stdin_write; - stdout_read; stdout_write; - stderr_read; stderr_write]) - -(* Local Variables: *) -(* coding: utf-8 *) -(* End: *) diff --git a/src/versions/standard/mutils_full.mli b/src/versions/standard/mutils_full.mli deleted file mode 100644 index d506485..0000000 --- a/src/versions/standard/mutils_full.mli +++ /dev/null @@ -1,77 +0,0 @@ -(*** This file is taken from Coq-8.9.0 to solve a compilation issue due - to a wrong order in dependencies. - See https://github.com/coq/coq/issues/9768 . ***) - - -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -module Micromega = Micromega_plugin.Micromega - -val numerator : Num.num -> Big_int.big_int -val denominator : Num.num -> Big_int.big_int - -module Cmp : sig - - val compare_list : ('a -> 'b -> int) -> 'a list -> 'b list -> int - val compare_lexical : (unit -> int) list -> int - -end - -module Tag : sig - - type t - - val pp : out_channel -> t -> unit - val next : t -> t - val from : int -> t - -end - -module TagSet : CSig.SetS with type elt = Tag.t - -val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit - -module CamlToCoq : sig - - val positive : int -> Micromega.positive - val bigint : Big_int.big_int -> Micromega.z - val n : int -> Micromega.n - val nat : int -> Micromega.nat - val q : Num.num -> Micromega.q - val index : int -> Micromega.positive - val z : int -> Micromega.z - val positive_big_int : Big_int.big_int -> Micromega.positive - -end - -module CoqToCaml : sig - - val z_big_int : Micromega.z -> Big_int.big_int - val q_to_num : Micromega.q -> Num.num - val positive : Micromega.positive -> int - val n : Micromega.n -> int - val nat : Micromega.nat -> int - val index : Micromega.positive -> int - -end - -val rats_to_ints : Num.num list -> Big_int.big_int list - -val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val all_sym_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option -val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - -val gcd_list : Num.num list -> Big_int.big_int - -val extract : ('a -> 'b option) -> 'a list -> ('b * 'a) option * 'a list - -val command : string -> string array -> 'a -> 'b diff --git a/src/versions/standard/smtcoq_plugin_standard.mlpack b/src/versions/standard/smtcoq_plugin_standard.mlpack index 81ac24b..f210db1 100644 --- a/src/versions/standard/smtcoq_plugin_standard.mlpack +++ b/src/versions/standard/smtcoq_plugin_standard.mlpack @@ -1,5 +1,3 @@ -Mutils_full -Coq_micromega_full Structures SmtMisc diff --git a/src/versions/standard/structures.ml b/src/versions/standard/structures.ml index d7e7f96..d069dde 100644 --- a/src/versions/standard/structures.ml +++ b/src/versions/standard/structures.ml @@ -10,9 +10,6 @@ (**************************************************************************) -open Entries - - (* Constr generation and manipulation *) type id = Names.variable let mkId = Names.Id.of_string @@ -41,55 +38,48 @@ let destRel = Constr.destRel let lift = Vars.lift let mkApp = Constr.mkApp let decompose_app = Constr.decompose_app -let mkLambda = Constr.mkLambda -let mkProd = Constr.mkProd -let mkLetIn = Constr.mkLetIn +let mkLambda (n, t, c) = Constr.mkLambda (Context.make_annot n Sorts.Relevant, t, c) +let mkProd (n, t, c) = Constr.mkProd (Context.make_annot n Sorts.Relevant, t, c) +let mkLetIn (n, c1, t, c2) = Constr.mkLetIn (Context.make_annot n Sorts.Relevant, c1, t, c2) +let mkArrow a b = Term.mkArrow a Sorts.Relevant b let pr_constr_env env = Printer.pr_constr_env env Evd.empty let pr_constr = pr_constr_env Environ.empty_env -let mkUConst : Constr.t -> Safe_typing.private_constants Entries.definition_entry = fun c -> +let mkUConst : Constr.t -> Evd.side_effects Declare.proof_entry = fun c -> let env = Global.env () in let evd = Evd.from_env env in let evd, ty = Typing.type_of env evd (EConstr.of_constr c) in - { Entries.const_entry_body = Future.from_val ((c, Univ.ContextSet.empty), - Safe_typing.empty_private_constants); - const_entry_secctx = None; - const_entry_feedback = None; - const_entry_type = Some (EConstr.Unsafe.to_constr ty); (* Cannot contain evars since it comes from a Constr.t *) - const_entry_universes = Evd.const_univ_entry ~poly:false evd; - const_entry_opaque = false; - const_entry_inline_code = false } + Declare.definition_entry + ~opaque:false + ~inline:false + ~types:(EConstr.Unsafe.to_constr ty) (* Cannot contain evars since it comes from a Constr.t *) + ~univs:(Evd.univ_entry ~poly:false evd) + c let mkTConst c noc ty = let env = Global.env () in let evd = Evd.from_env env in let evd, _ = Typing.type_of env evd (EConstr.of_constr noc) in - { const_entry_body = Future.from_val ((c, Univ.ContextSet.empty), - Safe_typing.empty_private_constants); - const_entry_secctx = None; - const_entry_feedback = None; - const_entry_type = Some ty; - const_entry_universes = Evd.const_univ_entry ~poly:false evd; - const_entry_opaque = false; - const_entry_inline_code = false } + Declare.definition_entry + ~opaque:false + ~inline:false + ~types:ty + ~univs:(Evd.univ_entry ~poly:false evd) + c (* TODO : Set -> Type *) let declare_new_type t = - let _ = ComAssumption.declare_assumption false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (Constr.mkSet, Entries.Monomorphic_const_entry Univ.ContextSet.empty) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make t) in + let _ = ComAssumption.declare_variable false ~kind:Decls.Definitional Constr.mkSet [] Glob_term.Explicit (CAst.make t) in Constr.mkVar t let declare_new_variable v constr_t = - let env = Global.env () in - let evd = Evd.from_env env in - let evd, _ = Typing.type_of env evd (EConstr.of_constr constr_t) in - let _ = ComAssumption.declare_assumption false (Decl_kinds.Discharge, false, Decl_kinds.Definitional) (constr_t, Evd.const_univ_entry ~poly:false evd) UnivNames.empty_binders [] false Declaremods.NoInline (CAst.make v) in + let _ = ComAssumption.declare_variable false ~kind:Decls.Definitional constr_t [] Glob_term.Explicit (CAst.make v) in Constr.mkVar v let declare_constant n c = - Declare.declare_constant n (DefinitionEntry c, Decl_kinds.IsDefinition Decl_kinds.Definition) - + Declare.declare_constant ~name:n ~kind:(Decls.IsDefinition Decls.Definition) (Declare.DefinitionEntry c) type cast_kind = Constr.cast_kind @@ -103,8 +93,11 @@ let econstr_of_constr = EConstr.of_constr (* Modules *) -let gen_constant_in_modules s m n = UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n +let gen_constant_in_modules s m n = + (* UnivGen.constr_of_monomorphic_global will crash on universe polymorphic constants *) + UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n let gen_constant modules constant = lazy (gen_constant_in_modules "SMT" modules constant) +let init_modules = Coqlib.init_modules (* Int63 *) @@ -166,13 +159,14 @@ let mkTrace step_to_coq next _ clist cnil ccons cpair size step def_step r = (* Micromega *) module Micromega_plugin_Micromega = Micromega_plugin.Micromega -module Micromega_plugin_Mutils = Mutils_full +module Micromega_plugin_Mutils = Micromega_plugin.Mutils module Micromega_plugin_Certificate = Micromega_plugin.Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega_full +module Micromega_plugin_Coq_micromega = Micromega_plugin.Coq_micromega +module Micromega_plugin_Persistent_cache = Micromega_plugin.Persistent_cache let micromega_coq_proofTerm = (* Cannot contain evars *) - lazy (EConstr.Unsafe.to_constr (Lazy.force (Micromega_plugin_Coq_micromega.M.coq_proofTerm))) + lazy (gen_constant_in_modules "ZMicromega" [["Coq"; "micromega";"ZMicromega"]] "ZArithProof") let micromega_dump_proof_term p = (* Cannot contain evars *) @@ -188,7 +182,7 @@ let assert_before n c = Tactics.assert_before n (EConstr.of_constr c) let vm_cast_no_check c = Tactics.vm_cast_no_check (EConstr.of_constr c) let mk_tactic tac = - Proofview.Goal.nf_enter (fun gl -> + Proofview.Goal.enter (fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in @@ -222,7 +216,8 @@ let constrextern_extern_constr c = Constrextern.extern_constr false env (Evd.from_env env) (EConstr.of_constr c) let get_rel_dec_name = function - | Context.Rel.Declaration.LocalAssum (n, _) | Context.Rel.Declaration.LocalDef (n, _, _) -> n + | Context.Rel.Declaration.LocalAssum (n, _) | Context.Rel.Declaration.LocalDef (n, _, _) -> + Context.binder_name n let retyping_get_type_of env sigma c = (* Cannot contain evars since it comes from a Constr.t *) diff --git a/src/versions/standard/structures.mli b/src/versions/standard/structures.mli index cde4f4f..78c948c 100644 --- a/src/versions/standard/structures.mli +++ b/src/versions/standard/structures.mli @@ -38,15 +38,16 @@ val decompose_app : constr -> constr * constr list val mkLambda : name * types * constr -> constr val mkProd : name * types * types -> types val mkLetIn : name * constr * types * constr -> constr +val mkArrow : types -> types -> constr val pr_constr_env : Environ.env -> constr -> Pp.t val pr_constr : constr -> Pp.t -val mkUConst : constr -> Safe_typing.private_constants Entries.definition_entry -val mkTConst : constr -> constr -> types -> Safe_typing.private_constants Entries.definition_entry +val mkUConst : constr -> Evd.side_effects Declare.proof_entry +val mkTConst : constr -> constr -> types -> Evd.side_effects Declare.proof_entry val declare_new_type : id -> types val declare_new_variable : id -> types -> constr -val declare_constant : id -> Safe_typing.private_constants Entries.definition_entry -> Names.Constant.t +val declare_constant : id -> Evd.side_effects Declare.proof_entry -> Names.Constant.t type cast_kind val vmcast : cast_kind @@ -60,6 +61,7 @@ val econstr_of_constr : constr -> econstr (* Modules *) val gen_constant : string list list -> string -> constr lazy_t +val init_modules : string list list (* Int63 *) @@ -88,9 +90,10 @@ val mkTrace : (* Micromega *) module Micromega_plugin_Micromega = Micromega_plugin.Micromega -module Micromega_plugin_Mutils = Mutils_full +module Micromega_plugin_Mutils = Micromega_plugin.Mutils module Micromega_plugin_Certificate = Micromega_plugin.Certificate -module Micromega_plugin_Coq_micromega = Coq_micromega_full +module Micromega_plugin_Coq_micromega = Micromega_plugin.Coq_micromega +module Micromega_plugin_Persistent_cache = Micromega_plugin.Persistent_cache val micromega_coq_proofTerm : constr lazy_t val micromega_dump_proof_term : Micromega_plugin_Micromega.zArithProof -> constr diff --git a/src/zchaff/zchaff.ml b/src/zchaff/zchaff.ml index 71b28a8..225a90b 100644 --- a/src/zchaff/zchaff.ml +++ b/src/zchaff/zchaff.ml @@ -222,7 +222,7 @@ let theorems interp name fdimacs ftrace = mklApp cCertif [|mkInt (max_id + 1);tres;mkInt (get_pos confl)|] in let theorem_concl = mklApp cnot [|mklApp cis_true [|interp d first last|] |] in - let vtype = Term.mkArrow (Lazy.force cint) (Lazy.force cbool) in + let vtype = Structures.mkArrow (Lazy.force cint) (Lazy.force cbool) in let theorem_type = Structures.mkProd (Structures.mkName "v", vtype, theorem_concl) in let theorem_proof_cast = |