From 348882636804297e1190e3e1549fa089e4fa8c23 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 3 May 2017 12:29:10 +0200 Subject: ReflOmegaCore: revised proofs (mostly bullets instead of ;[|||]) --- plugins/romega/ReflOmegaCore.v | 1079 ++++++++++++++++++---------------------- 1 file changed, 477 insertions(+), 602 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 187601fc6..5fa40f46f 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -413,66 +413,51 @@ Module IntProperties (I:Int). Definition beq i j := match compare i j with Eq => true | _ => false end. - Lemma beq_iff : forall i j, beq i j = true <-> i=j. + Lemma beq_iff i j : beq i j = true <-> i=j. Proof. - intros; unfold beq; generalize (compare_Eq i j). - destruct compare; intuition discriminate. + unfold beq. rewrite <- (compare_Eq i j). now destruct compare. Qed. - Lemma beq_true : forall i j, beq i j = true -> i=j. + Lemma beq_reflect i j : reflect (i=j) (beq i j). Proof. - intros. - rewrite <- beq_iff; auto. - Qed. - - Lemma beq_false : forall i j, beq i j = false -> i<>j. - Proof. - intros. - intro H'. - rewrite <- beq_iff in H'; rewrite H' in H; discriminate. + apply iff_reflect. symmetry. apply beq_iff. Qed. Lemma eq_dec : forall n m:int, { n=m } + { n<>m }. Proof. - intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition. + intros n m; generalize (beq_iff n m); destruct beq; [left|right]; intuition. Qed. Definition bgt i j := match compare i j with Gt => true | _ => false end. - Lemma bgt_iff : forall i j, bgt i j = true <-> i>j. + Lemma bgt_iff i j : bgt i j = true <-> i>j. Proof. - intros; unfold bgt; generalize (compare_Gt i j). - destruct compare; intuition discriminate. + unfold bgt. rewrite <- (compare_Gt i j). now destruct compare. Qed. - Lemma bgt_true : forall i j, bgt i j = true -> i>j. - Proof. intros; now rewrite <- bgt_iff. Qed. - - Lemma bgt_false : forall i j, bgt i j = false -> i<=j. + Lemma bgt_reflect i j : reflect (i>j) (bgt i j). Proof. - intros. - rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. + apply iff_reflect. symmetry. apply bgt_iff. Qed. Lemma le_is_lt_or_eq : forall n m, n<=m -> { n n<>m -> n m<=p -> n<=p. Proof. - intros n m p; do 3 rewrite le_lt_iff; intros A B C. + intros n m p; rewrite 3 le_lt_iff; intros A B C. destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. generalize (lt_trans _ _ _ H C); intuition. Qed. @@ -482,12 +467,12 @@ Module IntProperties (I:Int). Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. Proof. intros. - pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- (mult_0_l (-(1))) at 2. rewrite <- opp_eq_mult_neg_1. split; intros. - apply opp_le_compat; auto. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_le_compat; auto. + - apply opp_le_compat; auto. + - rewrite <-(opp_involutive 0), <-(opp_involutive n). + apply opp_le_compat; auto. Qed. Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. @@ -537,12 +522,12 @@ Module IntProperties (I:Int). Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. Proof. intros. - pattern 0 at 2; rewrite <- (mult_0_l (-(1))). + rewrite <- (mult_0_l (-(1))) at 2. rewrite <- opp_eq_mult_neg_1. split; intros. - apply opp_lt_compat; auto. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_lt_compat; auto. + - apply opp_lt_compat; auto. + - rewrite <-(opp_involutive 0), <-(opp_involutive n). + apply opp_lt_compat; auto. Qed. Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. @@ -557,67 +542,50 @@ Module IntProperties (I:Int). apply mult_lt_compat_l; auto. Qed. - Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. + Lemma mult_integral_r n m : 0 < n -> n * m = 0 -> m = 0. Proof. - intros. - destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; - destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso. - - rewrite lt_0_neg' in Hn. - rewrite lt_0_neg' in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive. - rewrite mult_comm, H. - exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hn. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite mult_comm, <- opp_mult_distr_r, mult_comm. - rewrite H. - rewrite opp_eq_mult_neg_1, mult_0_l. - exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hm. - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite <- opp_mult_distr_r. - rewrite H. - rewrite opp_eq_mult_neg_1, mult_0_l. - exact (lt_irrefl 0). - - generalize (mult_lt_0_compat _ _ Hn Hm). - rewrite H. - exact (lt_irrefl 0). - Qed. - - Lemma mult_le_compat : - forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. - Proof. - intros. - destruct (le_is_lt_or_eq _ _ H1). + intros Hn H. + destruct (lt_eq_lt_dec 0 m) as [[Hm| <- ]|Hm]; auto; exfalso. + - generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite H. + exact (lt_irrefl 0). + - rewrite lt_0_neg' in Hm. + generalize (mult_lt_0_compat _ _ Hn Hm). + rewrite <- opp_mult_distr_r, opp_eq_mult_neg_1, H, mult_0_l. + exact (lt_irrefl 0). + Qed. - apply le_trans with (i*l). - destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl]. - apply lt_le_weak. - apply mult_lt_compat_l; auto. + Lemma mult_integral n m : n * m = 0 -> n = 0 \/ m = 0. + Proof. + intros H. + destruct (lt_eq_lt_dec 0 n) as [[Hn|Hn]|Hn]. + - right; apply (mult_integral_r n m); trivial. + - now left. + - right; apply (mult_integral_r (-n) m). + + now apply lt_0_neg'. + + rewrite mult_comm, <- opp_mult_distr_r, mult_comm, H. + now rewrite opp_eq_mult_neg_1, mult_0_l. + Qed. - generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - rewrite (mult_comm i), (mult_comm j). - destruct (le_is_lt_or_eq _ _ H0); - [ | subst; do 2 rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H); - [ | subst; apply le_refl]. - apply lt_le_weak. - apply mult_lt_compat_l; auto. + Lemma mult_le_compat_l i j k : + 0<=k -> i<=j -> k*i <= k*j. + Proof. + intros Hk Hij. + apply le_is_lt_or_eq in Hk. apply le_is_lt_or_eq in Hij. + destruct Hk as [Hk | <-], Hij as [Hij | <-]; + rewrite ? mult_0_l; try apply le_refl. + now apply lt_le_weak, mult_lt_compat_l. + Qed. - subst i. - rewrite mult_0_l. - generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - destruct (le_is_lt_or_eq _ _ H); - [ | subst; rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H0); - [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. - apply lt_le_weak. - apply mult_lt_0_compat; auto. + Lemma mult_le_compat i j k l : + i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. + Proof. + intros Hij Hkl Hi Hk. + apply le_trans with (i*l). + - now apply mult_le_compat_l. + - rewrite (mult_comm i), (mult_comm j). + apply mult_le_compat_l; trivial. + now apply le_trans with k. Qed. Lemma sum5 : @@ -724,26 +692,26 @@ Module IntProperties (I:Int). rewrite gt_lt_iff in H,H0. destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. - rewrite lt_0_neg' in G. - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). - rewrite H'. - pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r. - intros. - rewrite le_lt_int in G. - rewrite <- opp_plus_distr in G. - assert (0 < y) by (apply lt_trans with x; auto). - generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). - rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. - intuition. + - rewrite lt_0_neg' in G. + generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). + rewrite H'. + rewrite <-(mult_1_l y) at 2. rewrite <-mult_plus_distr_r. + intros. + rewrite le_lt_int in G. + rewrite <- opp_plus_distr in G. + assert (0 < y) by (apply lt_trans with x; auto). + generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). + rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. + intuition. - subst; rewrite mult_0_l, plus_0_l in H'; subst. - apply (lt_not_eq _ _ H); auto. + - subst; rewrite mult_0_l, plus_0_l in H'; subst. + apply (lt_not_eq _ _ H); auto. - apply (lt_not_eq 0 (z*y+x)); auto. - rewrite <- (plus_0_l 0). - apply plus_lt_compat; auto. - apply mult_lt_0_compat; auto. - apply lt_trans with x; auto. + - apply (lt_not_eq 0 (z*y+x)); auto. + rewrite <- (plus_0_l 0). + apply plus_lt_compat; auto. + apply mult_lt_0_compat; auto. + apply lt_trans with x; auto. Qed. Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). @@ -759,32 +727,28 @@ Module IntProperties (I:Int). apply opp_lt_compat; auto. Qed. - Lemma mult_le_approx : - forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. + Lemma pos_ge_1 n : 0 < n -> 1 <= n. + Proof. + intros. apply plus_le_reg_r with (-(1)). rewrite opp_def. + now apply le_lt_int. + Qed. + + Lemma mult_le_approx n m p : + n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. - intros n m p. do 2 rewrite gt_lt_iff. - do 2 rewrite le_lt_iff; intros. - contradict H1. - rewrite lt_0_neg' in H1. + do 2 rewrite le_lt_iff; intros Hn Hpn H Hm. destruct H. + apply lt_0_neg', pos_ge_1 in Hm. rewrite lt_0_neg'. - rewrite opp_plus_distr. - rewrite mult_comm, opp_mult_distr_r. + rewrite opp_plus_distr, mult_comm, opp_mult_distr_r. rewrite le_lt_int. rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. apply lt_left. rewrite le_lt_int. - rewrite le_lt_int in H0. - apply le_trans with (n+-(1)); auto. + apply le_trans with (n+-(1)); [ now apply le_lt_int | ]. apply plus_le_compat; [ | apply le_refl ]. - rewrite le_lt_int in H1. - generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)). - rewrite mult_0_l. - rewrite mult_plus_distr_l. - rewrite <- opp_eq_mult_neg_1. - intros. - generalize (plus_le_compat _ _ _ _ (le_refl n) H2). - now rewrite plus_permute, opp_def, plus_0_r, plus_0_r. + rewrite <- (mult_1_l n) at 1. rewrite mult_comm. + apply mult_le_compat_l; auto using lt_le_weak. Qed. (* Some decidabilities *) @@ -1013,11 +977,9 @@ Inductive e_step : Set := (* \subsection{Efficient decidable equality} *) (* For each reified data-type, we define an efficient equality test. It is not the one produced by [Decide Equality]. - - Then we prove two theorem allowing elimination of such equalities : + Then we prove the correctness of this test : \begin{verbatim} - (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. - (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. + forall t1 t2 : term; eq_term t1 t2 = true <-> t1 = t2. \end{verbatim} *) (* \subsubsection{Reified terms} *) @@ -1037,61 +999,19 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := Close Scope romega_scope. -Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. -Proof. - induction t1; destruct t2; simpl in *; try discriminate; - (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; - auto using beq_true, beq_nat_true. -Qed. - -Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. +Theorem eq_term_iff (t t' : term) : + eq_term t t' = true <-> t = t'. Proof. - induction t0; simpl in *; try (apply andb_true_iff; split); trivial. - - now apply beq_iff. - - now apply beq_nat_true_iff. + revert t'. induction t; destruct t'; simpl in *; + rewrite ?andb_true_iff, ?beq_iff, ?Nat.eqb_eq, ?IHt, ?IHt1, ?IHt2; + intuition congruence. Qed. -Ltac trivial_case := unfold not; intros; discriminate. - -Theorem eq_term_false : - forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. +Theorem eq_term_reflect (t t' : term) : reflect (t=t') (eq_term t t'). Proof. - intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. + apply iff_reflect. symmetry. apply eq_term_iff. Qed. -(* \subsubsection{Tactiques pour éliminer ces tests} - - Si on se contente de faire un [Case (eq_typ t1 t2)] on perd - totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. - - Initialement, les développements avaient été réalisés avec les - tests rendus par [Decide Equality], c'est à dire un test rendant - des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un - tel test préserve bien l'information voulue mais calculatoirement de - telles fonctions sont trop lentes. *) - -(* Les tactiques définies si après se comportent exactement comme si on - avait utilisé le test précédent et fait une elimination dessus. *) - -Ltac elim_eq_term t1 t2 := - let Aux := fresh "Aux" in - pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux; - [ generalize (eq_term_true t1 t2 Aux); clear Aux - | generalize (eq_term_false t1 t2 Aux); clear Aux ]. - -Ltac elim_beq t1 t2 := - let Aux := fresh "Aux" in - pattern (beq t1 t2); apply bool_eq_ind; intro Aux; - [ generalize (beq_true t1 t2 Aux); clear Aux - | generalize (beq_false t1 t2 Aux); clear Aux ]. - -Ltac elim_bgt t1 t2 := - let Aux := fresh "Aux" in - pattern (bgt t1 t2); apply bool_eq_ind; intro Aux; - [ generalize (bgt_true t1 t2 Aux); clear Aux - | generalize (bgt_false t1 t2 Aux); clear Aux ]. - - (* \subsection{Interprétations} \subsubsection{Interprétation des termes dans Z} *) @@ -1162,16 +1082,18 @@ Theorem goal_to_hyps : forall (envp : list Prop) (env : list int) (l : hyps), (interp_hyps envp env l -> False) -> interp_goal envp env l. Proof. - simple induction l; - [ simpl; auto - | simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. + simple induction l. + - simpl; auto. + - simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto. Qed. Theorem hyps_to_goal : forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. Proof. - simple induction l; simpl; [ auto | intros; apply H; elim H1; auto ]. + simple induction l; simpl. + - auto. + - intros; apply H; elim H1; auto. Qed. (* \subsection{Manipulations sur les hypothèses} *) @@ -1236,21 +1158,22 @@ Theorem list_goal_to_hyps : forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. Proof. - simple induction l; simpl; - [ auto - | intros h1 l1 H H1; split; - [ apply goal_to_hyps; intro H2; apply H1; auto - | apply H; intro H2; apply H1; auto ] ]. + simple induction l; simpl. + - auto. + - intros h1 l1 H H1; split. + + apply goal_to_hyps; intro H2; apply H1; auto. + + apply H; intro H2; apply H1; auto. Qed. Theorem list_hyps_to_goal : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. Proof. - simple induction l; simpl; - [ auto - | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; - [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. + simple induction l; simpl. + - auto. + - intros h1 l1 H (H1, H2) H3; elim H3; intro H4. + + apply hyps_to_goal with (1 := H1); assumption. + + auto. Qed. Definition valid_list_hyps (f : hyps -> lhyps) := @@ -1274,29 +1197,25 @@ Theorem append_valid : interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> interp_list_hyps ep e (l1 ++ l2). Proof. - intros ep e; simple induction l1; - [ simpl; intros l2 [H| H]; [ contradiction | trivial ] - | simpl; intros h1 t1 HR l2 [[H| H]| H]; - [ auto - | right; apply (HR l2); left; trivial - | right; apply (HR l2); right; trivial ] ]. - + induction l1; simpl in *. + - now intros l2 [H| H]. + - intros l2 [[H| H]| H]. + + auto. + + right; apply IHl1; now left. + + right; apply IHl1; now right. Qed. (* \subsubsection{Opérateurs valides sur les hypothèses} *) (* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. -Unset Printing Notations. + Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). Proof. - unfold nth_hyps; simple induction i; - [ simple induction l; simpl; [ auto | intros; elim H0; auto ] - | intros n H; simple induction l; - [ simpl; trivial - | intros; simpl; apply H; elim H1; auto ] ]. + unfold nth_hyps. induction i; destruct l; simpl in *; try easy. + intros (H1,H2). now apply IHi. Qed. (* Appliquer une opération (valide) sur deux hypothèses extraites de @@ -1310,7 +1229,9 @@ Theorem apply_oper_2_valid : valid2 f -> valid_hyps (apply_oper_2 i j f). Proof. intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; - intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. + intros lp Hlp; split. + - apply Hf; apply nth_valid; assumption. + - assumption. Qed. (* Modifier une hypothèse par application d'une opération valide *) @@ -1330,15 +1251,17 @@ Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). Proof. - unfold valid_hyps; intros i f Hf ep e; elim i; - [ intro lp; case lp; - [ simpl; trivial - | simpl; intros p l' (H1, H2); split; - [ apply Hf with (1 := H1) | assumption ] ] - | intros n Hrec lp; case lp; - [ simpl; auto - | simpl; intros p l' (H1, H2); split; - [ assumption | apply Hrec; assumption ] ] ]. + unfold valid_hyps; intros i f Hf ep e; elim i. + - intro lp; case lp. + + simpl; trivial. + + simpl; intros p l' (H1, H2); split. + * apply Hf with (1 := H1). + * assumption. + - intros n Hrec lp; case lp. + + simpl; auto. + + simpl; intros p l' (H1, H2); split. + * assumption. + * apply Hrec; assumption. Qed. (* \subsubsection{Manipulations de termes} *) @@ -1443,49 +1366,26 @@ Ltac loop t := (* Propositions *) | (EqTerm ?X1 ?X2) => loop X1 || loop X2 | (LeqTerm ?X1 ?X2) => loop X1 || loop X2 - (* Termes *) + (* Terms *) | (?X1 + ?X2)%term => loop X1 || loop X2 | (?X1 - ?X2)%term => loop X1 || loop X2 | (?X1 * ?X2)%term => loop X1 || loop X2 | (- ?X1)%term => loop X1 | (Tint ?X1) => loop X1 (* Eliminations *) - | match ?X1 with - | EqTerm _ _ => _ - | LeqTerm _ _ => _ - | TrueTerm => _ - | FalseTerm => _ - | Tnot _ => _ - | GeqTerm _ _ => _ - | GtTerm _ _ => _ - | LtTerm _ _ => _ - | NeqTerm _ _ => _ - | Tor _ _ => _ - | Tand _ _ => _ - | Timp _ _ => _ - | Tprop _ => _ - end => destruct X1; auto; Simplify - | match ?X1 with - | Tint _ => _ - | (_ + _)%term => _ - | (_ * _)%term => _ - | (_ - _)%term => _ - | (- _)%term => _ - | [_]%term => _ - end => destruct X1; auto; Simplify | (if beq ?X1 ?X2 then _ else _) => let H := fresh "H" in - elim_beq X1 X2; intro H; try (rewrite H in *; clear H); - simpl; auto; Simplify + case (beq_reflect X1 X2); intro H; + try (rewrite H in *; clear H); simpl; auto; Simplify | (if bgt ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_bgt X1 X2; intro H; simpl; auto; Simplify + case (bgt_reflect X1 X2); intro; simpl; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => let H := fresh "H" in - elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); - simpl; auto; Simplify + case (eq_term_reflect X1 X2); intro H; + try (rewrite H in *; clear H); simpl; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify + | match ?X1 with _ => _ end => destruct X1; auto; Simplify | _ => fail end @@ -1829,52 +1729,43 @@ Fixpoint reduce (t : term) : term := match t with | (x + y)%term => match reduce x with - | Tint x' => + | Tint xi as xr => match reduce y with - | Tint y' => Tint (x' + y') - | y' => (Tint x' + y')%term + | Tint yi => Tint (xi + yi) + | yr => (xr + yr)%term end - | x' => (x' + reduce y)%term + | xr => (xr + reduce y)%term end | (x * y)%term => match reduce x with - | Tint x' => + | Tint xi as xr => match reduce y with - | Tint y' => Tint (x' * y') - | y' => (Tint x' * y')%term + | Tint yi => Tint (xi * yi) + | yr => (xr * yr)%term end - | x' => (x' * reduce y)%term + | xr => (xr * reduce y)%term end | (x - y)%term => match reduce x with - | Tint x' => + | Tint xi as xr => match reduce y with - | Tint y' => Tint (x' - y') - | y' => (Tint x' - y')%term + | Tint yi => Tint (xi - yi) + | yr => (xr - yr)%term end - | x' => (x' - reduce y)%term + | xr => (xr - reduce y)%term end | (- x)%term => match reduce x with - | Tint x' => Tint (- x') - | x' => (- x')%term + | Tint xi => Tint (- xi) + | xr => (- xr)%term end | _ => t end. Theorem reduce_stable : term_stable reduce. Proof. - unfold term_stable; intros e t; elim t; auto; - try - (intros t0 H0 t1 H1; simpl; rewrite H0; rewrite H1; - (case (reduce t0); - [ intro z0; case (reduce t1); intros; auto - | intros; auto - | intros; auto - | intros; auto - | intros; auto - | intros; auto ])); intros t0 H0; simpl; - rewrite H0; case (reduce t0); intros; auto. + red. intros e t; induction t; simpl; auto; + do 2 destruct reduce; simpl; f_equal; auto. Qed. (* \subsubsection{Fusions} @@ -1898,17 +1789,20 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). Proof. - simple induction trace; simpl; - [ exact reduce_stable - | intros stp l H; case stp; - [ apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] - | unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; - rewrite Tred_factor5_stable; apply H - | apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] - | apply compose_term_stable; - [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. + simple induction trace; simpl. + - exact reduce_stable. + - intros stp l H; case stp. + + apply compose_term_stable. + * apply apply_right_stable; assumption. + * exact T_OMEGA10_stable. + + unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; + rewrite Tred_factor5_stable; apply H. + + apply compose_term_stable. + * apply apply_right_stable; assumption. + * exact T_OMEGA11_stable. + + apply compose_term_stable. + * apply apply_right_stable; assumption. + * exact T_OMEGA12_stable. Qed. (* \paragraph{Fusion de deux équations dont une sans coefficient} *) @@ -1936,9 +1830,9 @@ Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). Proof. - unfold term_stable, fusion_cancel; intros trace e; elim trace; - [ exact (reduce_stable e) - | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. + unfold term_stable, fusion_cancel; intros trace e; elim trace. + - exact (reduce_stable e). + - intros n H t; elim H; exact (T_OMEGA13_stable e t). Qed. (* \subsubsection{Opérations affines sur une équation} *) @@ -1953,10 +1847,11 @@ Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := Theorem scalar_norm_add_stable : forall t : nat, term_stable (scalar_norm_add t). Proof. - unfold term_stable, scalar_norm_add; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (T_OMEGA11_stable e t) | exact H ] ]. + unfold term_stable, scalar_norm_add; intros trace; elim trace. + - exact reduce_stable. + - intros n H e t; elim apply_right_stable. + + exact (T_OMEGA11_stable e t). + + exact H. Qed. (* \paragraph{Multiplication scalaire} *) @@ -1968,10 +1863,11 @@ Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). Proof. - unfold term_stable, scalar_norm; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (T_OMEGA16_stable e t) | exact H ] ]. + unfold term_stable, scalar_norm; intros trace; elim trace. + - exact reduce_stable. + - intros n H e t; elim apply_right_stable. + + exact (T_OMEGA16_stable e t). + + exact H. Qed. (* \paragraph{Somme d'une constante} *) @@ -1983,10 +1879,11 @@ Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). Proof. - unfold term_stable, add_norm; intros trace; elim trace; - [ exact reduce_stable - | intros n H e t; elim apply_right_stable; - [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. + unfold term_stable, add_norm; intros trace; elim trace. + - exact reduce_stable. + - intros n H e t; elim apply_right_stable. + + exact (Tplus_assoc_r_stable e t). + + exact H. Qed. (* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) @@ -2025,34 +1922,34 @@ Fixpoint t_rewrite (s : step) : term -> term := Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s). Proof. - simple induction s; simpl; - [ intros; apply apply_both_stable; auto - | intros; apply apply_left_stable; auto - | intros; apply apply_right_stable; auto - | unfold term_stable; intros; elim H0; apply H - | unfold term_stable; auto - | exact Topp_plus_stable - | exact Topp_opp_stable - | exact Topp_mult_r_stable - | exact Topp_one_stable - | exact reduce_stable - | exact Tmult_plus_distr_stable - | exact Tmult_opp_left_stable - | exact Tmult_assoc_r_stable - | exact Tplus_assoc_r_stable - | exact Tplus_assoc_l_stable - | exact Tplus_permute_stable - | exact Tplus_comm_stable - | exact Tred_factor0_stable - | exact Tred_factor1_stable - | exact Tred_factor2_stable - | exact Tred_factor3_stable - | exact Tred_factor4_stable - | exact Tred_factor5_stable - | exact Tred_factor6_stable - | exact Tmult_assoc_reduced_stable - | exact Tminus_def_stable - | exact Tmult_comm_stable ]. + simple induction s; simpl. + - intros; apply apply_both_stable; auto. + - intros; apply apply_left_stable; auto. + - intros; apply apply_right_stable; auto. + - unfold term_stable; intros; elim H0; apply H. + - unfold term_stable; auto. + - exact Topp_plus_stable. + - exact Topp_opp_stable. + - exact Topp_mult_r_stable. + - exact Topp_one_stable. + - exact reduce_stable. + - exact Tmult_plus_distr_stable. + - exact Tmult_opp_left_stable. + - exact Tmult_assoc_r_stable. + - exact Tplus_assoc_r_stable. + - exact Tplus_assoc_l_stable. + - exact Tplus_permute_stable. + - exact Tplus_comm_stable. + - exact Tred_factor0_stable. + - exact Tred_factor1_stable. + - exact Tred_factor2_stable. + - exact Tred_factor3_stable. + - exact Tred_factor4_stable. + - exact Tred_factor5_stable. + - exact Tred_factor6_stable. + - exact Tmult_assoc_reduced_stable. + - exact Tminus_def_stable. + - exact Tmult_comm_stable. Qed. (* \subsection{tactiques de résolution d'un but omega normalisé} @@ -2085,9 +1982,9 @@ Definition constant_neg (i : nat) (h : hyps) := Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). Proof. - unfold valid_hyps, constant_neg; intros; - generalize (nth_valid ep e i lp); Simplify; simpl. - rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. + unfold valid_hyps, constant_neg. intros. + generalize (nth_valid ep e i lp). Simplify; simpl. + rewrite gt_lt_iff in *; rewrite le_lt_iff; intuition. Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) @@ -2112,8 +2009,9 @@ Proof. generalize (nth_valid ep e i lp); Simplify. rewrite (scalar_norm_add_stable t0 e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. - absurd (interp_term e body * k1 + k2 = 0); - [ now apply OMEGA4 | symmetry; auto ]. + absurd (interp_term e body * k1 + k2 = 0). + - now apply OMEGA4. + - symmetry; auto. Qed. (* \paragraph{[O_CONTRADICTION]} *) @@ -2137,19 +2035,19 @@ Definition contradiction (t i j : nat) (l : hyps) := Theorem contradiction_valid : forall t i j : nat, valid_hyps (contradiction t i j). Proof. - unfold valid_hyps, contradiction; intros t i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; - simpl; intros z z' H1 H2; - generalize (eq_refl (interp_term e (fusion_cancel t (t2 + t4)%term))); - pattern (fusion_cancel t (t2 + t4)%term) at 2 3; - case (fusion_cancel t (t2 + t4)%term); simpl; - auto; intro k; elim (fusion_cancel_stable t); simpl. - Simplify; intro H3. - generalize (OMEGA2 _ _ H2 H1); rewrite H3. - rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. + unfold valid_hyps, contradiction; intros t i j ep e l H. + generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H). + case (nth_hyps i l); trivial. intros t1 t2. + case t1; trivial. clear t1; intros x1. + case (nth_hyps j l); trivial. intros t3 t4. + case t3; trivial. clear t3; intros x3. + destruct fusion_cancel as [ t0 | | | | | ] eqn:E; trivial. + change t0 with (interp_term e (Tint t0)). + rewrite <- E, <- fusion_cancel_stable. + Simplify. + intros H1 H2. + generalize (OMEGA2 _ _ H1 H2). + rewrite gt_lt_iff in *; rewrite le_lt_iff. intuition. Qed. (* \paragraph{[O_NEGATE_CONTRADICT]} *) @@ -2202,31 +2100,28 @@ Theorem negate_contradict_valid : forall i j : nat, valid_hyps (negate_contradict i j). Proof. unfold valid_hyps, negate_contradict; intros i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros H1 H2; Simplify. + auto; simpl; intros; Simplify. Qed. Theorem negate_contradict_inv_valid : forall t i j : nat, valid_hyps (negate_contradict_inv t i j). Proof. unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H; - generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros H1 H2; Simplify; - [ - rewrite <- scalar_norm_stable in H2; simpl in *; - elim (mult_integral (interp_term e t4) (-(1))); intuition; - elim minus_one_neq_zero; auto - | - elim H2; clear H2; - rewrite <- scalar_norm_stable; simpl in *; - now rewrite <- H1, mult_0_l - ]. + auto; simpl; intros H1 H2; Simplify. + - rewrite <- scalar_norm_stable in H1; simpl in *; + elim (mult_integral (interp_term e t4) (-(1))); intuition; + elim minus_one_neq_zero; auto. + - elim H1; clear H1; + rewrite <- scalar_norm_stable; simpl in *; + now rewrite <- H2, mult_0_l. Qed. (* \subsubsection{Tactiques générant une nouvelle équation} *) @@ -2286,12 +2181,12 @@ Theorem sum_valid : Proof. unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; Simplify; simpl; auto; try elim (fusion_stable t); - simpl; intros; - [ apply sum1; assumption - | apply sum2; try assumption; apply sum4; assumption - | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption - | apply sum3; try assumption; apply sum4; assumption - | apply sum5; auto ]. + simpl; intros. + - apply sum1; assumption. + - apply sum2; try assumption; apply sum4; assumption. + - rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption. + - apply sum3; try assumption; apply sum4; assumption. + - apply sum5; auto. Qed. (* \paragraph{[O_EXACT_DIVIDE]} @@ -2320,10 +2215,9 @@ Theorem exact_divide_valid : Proof. unfold valid1, exact_divide; intros k1 k2 t ep e p1; Simplify; simpl; auto; subst; - rewrite <- scalar_norm_stable; simpl; intros; - [ destruct (mult_integral _ _ (eq_sym H0)); intuition - | contradict H0; rewrite <- H0, mult_0_l; auto - ]. + rewrite <- scalar_norm_stable; simpl; intros. + - destruct (mult_integral _ _ (eq_sym H0)); intuition. + - contradict H0; rewrite <- H0, mult_0_l; auto. Qed. @@ -2348,9 +2242,9 @@ Theorem divide_and_approx_valid : forall (k1 k2 : int) (body : term) (t : nat), valid1 (divide_and_approx k1 k2 body t). Proof. - unfold valid1, divide_and_approx; intros k1 k2 body t ep e p1; - Simplify; simpl; auto; subst; - elim (scalar_norm_add_stable t e); simpl. + unfold valid1, divide_and_approx. + intros k1 k2 body t ep e p1. Simplify. subst. + elim (scalar_norm_add_stable t e). simpl. intro H2; apply mult_le_approx with (3 := H2); assumption. Qed. @@ -2374,8 +2268,9 @@ Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). Proof. unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl; auto; elim (scalar_norm_stable n e); simpl; - intros; symmetry ; apply OMEGA8 with (2 := H0); - [ assumption | elim opp_eq_mult_neg_1; trivial ]. + intros; symmetry ; apply OMEGA8 with (2 := H0). + - assumption. + - elim opp_eq_mult_neg_1; trivial. Qed. @@ -2392,8 +2287,7 @@ Definition constant_nul (i : nat) (h : hyps) := Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). Proof. unfold valid_hyps, constant_nul; intros; - generalize (nth_valid ep e i lp); Simplify; simpl; - intro H1; absurd (0 = 0); intuition. + generalize (nth_valid ep e i lp); Simplify; simpl; intuition. Qed. (* \paragraph{[O_STATE]} *) @@ -2446,13 +2340,13 @@ Proof. simpl; auto; intros t1 t2; case t1; simpl; auto; intros z; simpl; auto; intro H3. Simplify. - apply append_valid; elim (OMEGA19 (interp_term e t2)); - [ intro H4; left; apply H1; simpl; elim (add_norm_stable t); - simpl; auto - | intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); - simpl; auto - | generalize H3; unfold not; intros E1 E2; apply E1; - symmetry ; trivial ]. + apply append_valid; elim (OMEGA19 (interp_term e t2)). + - intro H4; left; apply H1; simpl; elim (add_norm_stable t); + simpl; auto. + - intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); + simpl; auto. + - generalize H3; unfold not; intros E1 E2; apply E1; + symmetry ; trivial. Qed. @@ -2485,49 +2379,49 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. - simple induction tr; simpl; - [ unfold valid_list_hyps; simpl; intros; left; - apply (constant_not_nul_valid n ep e lp H) - | unfold valid_list_hyps; simpl; intros; left; - apply (constant_neg_valid n ep e lp H) - | unfold valid_list_hyps, valid_hyps; + simple induction tr; simpl. + - unfold valid_list_hyps; simpl; intros; left; + apply (constant_not_nul_valid n ep e lp H). + - unfold valid_list_hyps; simpl; intros; left; + apply (constant_neg_valid n ep e lp H). + - unfold valid_list_hyps, valid_hyps; intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (divide_and_approx k1 k2 body n) - (divide_and_approx_valid k1 k2 body n) ep e lp H) - | unfold valid_list_hyps; simpl; intros; left; - apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) - | unfold valid_list_hyps, valid_hyps; + (divide_and_approx_valid k1 k2 body n) ep e lp H). + - unfold valid_list_hyps; simpl; intros; left; + apply (not_exact_divide_valid _ _ _ _ _ ep e lp H). + - unfold valid_list_hyps, valid_hyps; intros k body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body n) - (exact_divide_valid k body n) ep e lp H) - | unfold valid_list_hyps, valid_hyps; + (exact_divide_valid k body n) ep e lp H). + - unfold valid_list_hyps, valid_hyps; intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e - lp H) - | unfold valid_list_hyps; simpl; intros; left; - apply (contradiction_valid n n0 n1 ep e lp H) - | unfold valid_list_hyps, valid_hyps; + lp H). + - unfold valid_list_hyps; simpl; intros; left; + apply (contradiction_valid n n0 n1 ep e lp H). + - unfold valid_list_hyps, valid_hyps; intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e - lp H) - | intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; + lp H). + - intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; intros ep e lp H; apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e - lp H) - | unfold valid_list_hyps; simpl; intros i ep e lp H; left; - apply (constant_nul_valid i ep e lp H) - | unfold valid_list_hyps; simpl; intros i j ep e lp H; left; - apply (negate_contradict_valid i j ep e lp H) - | unfold valid_list_hyps; simpl; intros n i j ep e lp H; - left; apply (negate_contradict_inv_valid n i j ep e lp H) - | unfold valid_list_hyps, valid_hyps; + lp H). + - unfold valid_list_hyps; simpl; intros i ep e lp H; left; + apply (constant_nul_valid i ep e lp H). + - unfold valid_list_hyps; simpl; intros i j ep e lp H; left; + apply (negate_contradict_valid i j ep e lp H). + - unfold valid_list_hyps; simpl; intros n i j ep e lp H; + left; apply (negate_contradict_inv_valid n i j ep e lp H). + - unfold valid_list_hyps, valid_hyps; intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; - apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. + apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H). Qed. @@ -2548,13 +2442,13 @@ Definition move_right (s : step) (p : proposition) := Theorem move_right_valid : forall s : step, valid1 (move_right s). Proof. unfold valid1, move_right; intros s ep e p; Simplify; simpl; - elim (t_rewrite_stable s e); simpl; - [ symmetry ; apply egal_left; assumption - | intro; apply le_left; assumption - | intro; apply le_left; rewrite <- ge_le_iff; assumption - | intro; apply lt_left; rewrite <- gt_lt_iff; assumption - | intro; apply lt_left; assumption - | intro; apply ne_left_2; assumption ]. + elim (t_rewrite_stable s e); simpl. + - symmetry ; apply egal_left; assumption. + - intro; apply le_left; assumption. + - intro; apply le_left; rewrite <- ge_le_iff; assumption. + - intro; apply lt_left; rewrite <- gt_lt_iff; assumption. + - intro; apply lt_left; assumption. + - intro; apply ne_left_2; assumption. Qed. Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). @@ -2576,10 +2470,10 @@ Fixpoint do_normalize_list (l : list step) (i : nat) Theorem do_normalize_list_valid : forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). Proof. - simple induction l; simpl; unfold valid_hyps; - [ auto - | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; - apply (do_normalize_valid i a ep e lp); assumption ]. + simple induction l; simpl; unfold valid_hyps. + - auto. + - intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; + apply (do_normalize_valid i a ep e lp); assumption. Qed. Theorem normalize_goal : @@ -2604,9 +2498,9 @@ Theorem append_goal : interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> interp_list_goal ep e (l1 ++ l2). Proof. - intros ep e; simple induction l1; - [ simpl; intros l2 (H1, H2); assumption - | simpl; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. + intros ep e; induction l1; simpl. + - intros l2 (H1, H2); assumption. + - intros l2 ((H1, H2), H3); split; auto. Qed. (* A simple decidability checker : if the proposition belongs to the @@ -2635,20 +2529,20 @@ Theorem decidable_correct : forall (ep : list Prop) (e : list int) (p : proposition), decidability p = true -> decidable (interp_proposition ep e p). Proof. - simple induction p; simpl; intros; - [ apply dec_eq - | apply dec_le - | left; auto - | right; unfold not; auto - | apply dec_not; auto - | apply dec_ge - | apply dec_gt - | apply dec_lt - | apply dec_ne - | apply dec_or; elim andb_prop with (1 := H1); auto - | apply dec_and; elim andb_prop with (1 := H1); auto - | apply dec_imp; elim andb_prop with (1 := H1); auto - | discriminate H ]. + simple induction p; simpl; intros. + - apply dec_eq. + - apply dec_le. + - left; auto. + - right; unfold not; auto. + - apply dec_not; auto. + - apply dec_ge. + - apply dec_gt. + - apply dec_lt. + - apply dec_ne. + - apply dec_or; elim andb_prop with (1 := H1); auto. + - apply dec_and; elim andb_prop with (1 := H1); auto. + - apply dec_imp; elim andb_prop with (1 := H1); auto. + - discriminate H. Qed. (* An interpretation function for a complete goal with an explicit @@ -2675,8 +2569,9 @@ Theorem interp_full_false : forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). Proof. - simple induction l; unfold interp_full; simpl; - [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. + simple induction l; unfold interp_full; simpl. + - auto. + - intros a l1 H1 c H2 H3; apply H1; auto. Qed. (* Push the conclusion in the list of hypothesis using a double negation @@ -2695,15 +2590,13 @@ Theorem to_contradict_valid : forall (ep : list Prop) (e : list int) (lc : hyps * proposition), interp_goal ep e (to_contradict lc) -> interp_full ep e lc. Proof. - intros ep e lc; case lc; intros l c; simpl; - pattern (decidability c); apply bool_eq_ind; - [ simpl; intros H H1; apply interp_full_false; intros H2; - apply not_not; - [ apply decidable_correct; assumption - | unfold not at 1; intro H3; apply hyps_to_goal with (2 := H2); - auto ] - | intros H1 H2; apply interp_full_false; intro H3; - elim hyps_to_goal with (1 := H2); assumption ]. + intros ep e (l,c); simpl. + destruct decidability eqn:H; simpl; + intros H1; apply interp_full_false; intros H2. + - apply not_not. + + now apply decidable_correct. + + intro; apply hyps_to_goal with (2 := H2); auto. + - now elim hyps_to_goal with (1 := H1). Qed. (* [map_cons x l] adds [x] at the head of each list in [l] (which is a list @@ -2764,7 +2657,7 @@ Theorem map_cons_val : interp_proposition ep e p -> interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). Proof. - simple induction l; simpl; [ auto | intros; elim H1; intro H2; auto ]. + induction l; simpl; intuition. Qed. Hint Resolve map_cons_val append_valid decidable_correct. @@ -2772,46 +2665,38 @@ Hint Resolve map_cons_val append_valid decidable_correct. Theorem destructure_hyps_valid : forall n : nat, valid_list_hyps (destructure_hyps n). Proof. - simple induction n; - [ unfold valid_list_hyps; simpl; auto - | unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp; - [ simpl; auto - | intros p l; case p; + simple induction n. + - unfold valid_list_hyps; simpl; auto. + - unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp. + + simpl; auto. + + intros p l; case p; try (simpl; intros; apply map_cons_val; simpl; elim H0; - auto); - [ intro p'; case p'; + auto). + * intro p'; case p'; simpl; try (simpl; intros; apply map_cons_val; simpl; elim H0; - auto); - [ simpl; intros p1 (H1, H2); - pattern (decidability p1); apply bool_eq_ind; - intro H3; - [ apply H; simpl; split; - [ apply not_not; auto | assumption ] - | auto ] - | simpl; intros p1 p2 (H1, H2); apply H; simpl; - elim not_or with (1 := H1); auto - | simpl; intros p1 p2 (H1, H2); - pattern (decidability p1); apply bool_eq_ind; - intro H3; - [ apply append_valid; elim not_and with (2 := H1); - [ intro; left; apply H; simpl; auto - | intro; right; apply H; simpl; auto - | auto ] - | auto ] ] - | simpl; intros p1 p2 (H1, H2); apply append_valid; + auto). + { simpl; intros p1 (H1, H2). + destruct decidability eqn:H3; auto. + apply H; simpl; split; auto. + apply not_not; auto. } + { simpl; intros p1 p2 (H1, H2); apply H; simpl; + elim not_or with (1 := H1); auto. } + { simpl; intros p1 p2 (H1, H2). + destruct decidability eqn:H3; auto. + apply append_valid; elim not_and with (2 := H1); auto. + - intro; left; apply H; simpl; auto. + - intro; right; apply H; simpl; auto. } + * simpl; intros p1 p2 (H1, H2); apply append_valid; (elim H1; intro H3; simpl; [ left | right ]); - apply H; simpl; auto - | simpl; intros; apply H; simpl; tauto - | simpl; intros p1 p2 (H1, H2); - pattern (decidability p1); apply bool_eq_ind; - intro H3; - [ apply append_valid; elim imp_simp with (2 := H1); - [ intro H4; left; simpl; apply H; simpl; auto - | intro H4; right; simpl; apply H; simpl; auto - | auto ] - | auto ] ] ] ]. + apply H; simpl; auto. + * simpl; intros; apply H; simpl; tauto. + * simpl; intros p1 p2 (H1, H2). + destruct decidability eqn:H3; auto. + apply append_valid; elim imp_simp with (2 := H1); auto. + { intro; left; simpl; apply H; simpl; auto. } + { intro; right; simpl; apply H; simpl; auto. } Qed. Definition prop_stable (f : proposition -> proposition) := @@ -2850,12 +2735,12 @@ Theorem p_apply_right_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_right f). Proof. - unfold prop_stable; intros f H ep e p; split; - (case p; simpl; auto; - [ intros p1; elim (H ep e p1); tauto - | intros p1 p2; elim (H ep e p2); tauto - | intros p1 p2; elim (H ep e p2); tauto - | intros p1 p2; elim (H ep e p2); tauto ]). + unfold prop_stable; intros f H ep e p. + case p; simpl; try tauto. + - intros p1; rewrite (H ep e p1); tauto. + - intros p1 p2; elim (H ep e p2); tauto. + - intros p1 p2; elim (H ep e p2); tauto. + - intros p1 p2; elim (H ep e p2); tauto. Qed. Definition p_invert (f : proposition -> proposition) @@ -2874,54 +2759,44 @@ Theorem p_invert_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_invert f). Proof. - unfold prop_stable; intros f H ep e p; split; - (case p; simpl; auto; - [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl; - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable; tauto - | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl; - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl; - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto - | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl; - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable; repeat rewrite le_lt_iff; - repeat rewrite gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl; - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable; repeat rewrite ge_le_iff; - repeat rewrite le_lt_iff; tauto - | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl; - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable; tauto ]). + unfold prop_stable; intros f H ep e p. + case p; simpl; try tauto; intros t1 t2; rewrite <- (H ep e); simpl. + - generalize (dec_eq (interp_term e t1) (interp_term e t2)); + unfold decidable; try tauto. + - generalize (dec_gt (interp_term e t1) (interp_term e t2)); + unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto. + - generalize (dec_lt (interp_term e t1) (interp_term e t2)); + unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto. + - generalize (dec_gt (interp_term e t1) (interp_term e t2)); + unfold decidable; rewrite ?le_lt_iff, ?gt_lt_iff; tauto. + - generalize (dec_lt (interp_term e t1) (interp_term e t2)); + unfold decidable; rewrite ?ge_le_iff, ?le_lt_iff; tauto. + - reflexivity. Qed. Theorem move_right_stable : forall s : step, prop_stable (move_right s). Proof. - unfold move_right, prop_stable; intros s ep e p; split; - [ Simplify; simpl; elim (t_rewrite_stable s e); simpl; - [ symmetry ; apply egal_left; assumption - | intro; apply le_left; assumption - | intro; apply le_left; rewrite <- ge_le_iff; assumption - | intro; apply lt_left; rewrite <- gt_lt_iff; assumption - | intro; apply lt_left; assumption - | intro; apply ne_left_2; assumption ] - | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); - simpl; intro H1; - [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; - rewrite plus_permute; rewrite plus_opp_r; - rewrite plus_0_r; trivial - | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); - rewrite plus_opp_r; assumption - | rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); - rewrite plus_opp_r; assumption - | rewrite gt_lt_iff; apply lt_left_inv; assumption - | apply lt_left_inv; assumption - | unfold not; intro H2; apply H1; - rewrite H2; rewrite plus_opp_r; trivial ] ]. + unfold move_right, prop_stable; intros s ep e p; split. + - Simplify; simpl; elim (t_rewrite_stable s e); simpl. + + symmetry ; apply egal_left; assumption. + + intro; apply le_left; assumption. + + intro; apply le_left; rewrite <- ge_le_iff; assumption. + + intro; apply lt_left; rewrite <- gt_lt_iff; assumption. + + intro; apply lt_left; assumption. + + intro; apply ne_left_2; assumption. + - case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); + simpl; intro H1. + + rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; + now rewrite plus_permute, plus_opp_r, plus_0_r. + + apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); + rewrite plus_opp_r; assumption. + + rewrite ge_le_iff; + apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); + rewrite plus_opp_r; assumption. + + rewrite gt_lt_iff; apply lt_left_inv; assumption. + + apply lt_left_inv; assumption. + + unfold not; intro H2; apply H1; + rewrite H2, plus_opp_r; trivial. Qed. @@ -2936,12 +2811,12 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition := Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). Proof. - simple induction s; simpl; - [ intros; apply p_apply_left_stable; trivial - | intros; apply p_apply_right_stable; trivial - | intros; apply p_invert_stable; apply move_right_stable - | apply move_right_stable - | unfold prop_stable; simpl; intros; split; auto ]. + simple induction s; simpl. + - intros; apply p_apply_left_stable; trivial. + - intros; apply p_apply_right_stable; trivial. + - intros; apply p_invert_stable; apply move_right_stable. + - apply move_right_stable. + - unfold prop_stable; simpl; intros; split; auto. Qed. Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := @@ -2953,13 +2828,13 @@ Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := Theorem normalize_hyps_valid : forall l : list h_step, valid_hyps (normalize_hyps l). Proof. - simple induction l; unfold valid_hyps; simpl; - [ auto - | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; - apply apply_oper_1_valid; - [ unfold valid1; intros ep1 e1 p1 H2; - elim (p_rewrite_stable s ep1 e1 p1); auto - | assumption ] ]. + simple induction l; unfold valid_hyps; simpl. + - auto. + - intros n_s r; case n_s; intros n s H ep e lp H1; apply H; + apply apply_oper_1_valid. + + unfold valid1; intros ep1 e1 p1 H2; + elim (p_rewrite_stable s ep1 e1 p1); auto. + + assumption. Qed. Theorem normalize_hyps_goal : @@ -3024,23 +2899,22 @@ Theorem extract_valid : forall s : list direction, valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). Proof. - unfold valid1, co_valid1; simple induction s; - [ split; - [ simpl; auto - | intros ep e p1; case p1; simpl; auto; intro p; - pattern (decidability p); apply bool_eq_ind; - [ intro H; generalize (decidable_correct ep e p H); - unfold decidable; tauto - | simpl; auto ] ] - | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; - case p; auto; simpl; intros; + unfold valid1, co_valid1; simple induction s. + - split. + + simpl; auto. + + intros ep e p1; case p1; simpl; auto; intro p. + destruct decidability eqn:H. + * generalize (decidable_correct ep e p H); + unfold decidable; tauto. + * simpl; auto. + - intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; + case p; auto; simpl; intros; (apply H1; tauto) || (apply H2; tauto) || - (pattern (decidability p0); apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e p0 H3); - unfold decidable; intro H4; apply H1; - tauto - | intro; tauto ]) ]. + (destruct decidability eqn:H3; try tauto; + generalize (decidable_correct ep e p0 H3); + unfold decidable; intro H4; apply H1; + tauto). Qed. Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := @@ -3069,31 +2943,32 @@ Theorem decompose_solve_valid : forall s : e_step, valid_list_goal (decompose_solve s). Proof. intro s; apply goal_valid; unfold valid_list_hyps; elim s; - simpl; intros; - [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); - [ case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto; - [ intro p; case p; simpl; auto; intros p1 p2 H2; - pattern (decidability p1); apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl; tauto - | left; apply H; simpl; tauto ] - | simpl; auto ] - | intros p1 p2 H2; apply append_valid; simpl; elim H2; - [ intros H3; left; apply H; simpl; auto - | intros H3; right; apply H0; simpl; auto ] - | intros p1 p2 H2; - pattern (decidability p1); apply bool_eq_ind; - [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl; tauto - | left; apply H; simpl; tauto ] - | simpl; auto ] ] - | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] - | intros; apply H; simpl; split; - [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto - | auto ] - | apply omega_valid with (1 := H) ]. + simpl; intros. + - cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))). + + case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto. + * intro p; case p; simpl; auto; intros p1 p2 H2. + destruct decidability eqn:H3. + { generalize (decidable_correct ep e1 p1 H3); intro H4; + apply append_valid; elim H4; intro H5. + - right; apply H0; simpl; tauto. + - left; apply H; simpl; tauto. } + { simpl; auto. } + * intros p1 p2 H2; apply append_valid; simpl; elim H2. + { intros H3; left; apply H; simpl; auto. } + { intros H3; right; apply H0; simpl; auto. } + * intros p1 p2 H2; + destruct decidability eqn:H3. + { generalize (decidable_correct ep e1 p1 H3); intro H4; + apply append_valid; elim H4; intro H5. + - right; apply H0; simpl; tauto. + - left; apply H; simpl; tauto. } + { simpl; auto. } + + elim (extract_valid l); intros H2 H3. + apply H2, nth_valid; auto. + - intros; apply H; simpl; split; auto. + elim (extract_valid l); intros H2 H3. + apply H2; apply nth_valid; auto. + - apply omega_valid with (1 := H). Qed. (* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) @@ -3111,11 +2986,11 @@ Fixpoint reduce_lhyps (lp : lhyps) : lhyps := Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. Proof. - unfold valid_lhyps; intros ep e lp; elim lp; - [ simpl; auto - | intros a l HR; elim a; - [ simpl; tauto - | intros a1 l1; case l1; case a1; simpl; try tauto ] ]. + unfold valid_lhyps; intros ep e lp; elim lp. + - simpl; auto. + - intros a l HR; elim a. + + simpl; tauto. + + intros a1 l1; case l1; case a1; simpl; tauto. Qed. Theorem do_reduce_lhyps : @@ -3135,13 +3010,13 @@ Definition do_concl_to_hyp : interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. Proof. - simpl; intros envp env c l; induction l as [| a l Hrecl]; - [ simpl; unfold concl_to_hyp; - pattern (decidability c); apply bool_eq_ind; - [ intro H; generalize (decidable_correct envp env c H); - unfold decidable; simpl; tauto - | simpl; intros H1 H2; elim H2; trivial ] - | simpl; tauto ]. + simpl; intros envp env c l; induction l as [| a l Hrecl]. + - simpl; unfold concl_to_hyp; + destruct decidability eqn:H. + + generalize (decidable_correct envp env c H); + unfold decidable; simpl; tauto. + + simpl; intros H2; elim H2; trivial. + - simpl; tauto. Qed. Definition omega_tactic (t1 : e_step) (t2 : list h_step) -- cgit v1.2.3 From 102494641b9b6c31495bd02ae8c565249fb128b3 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 9 May 2017 13:53:08 +0200 Subject: ReflOmegaCore: discard useless cosntructor P_NOP --- plugins/romega/ReflOmegaCore.v | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 5fa40f46f..60c0018c5 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -941,8 +941,7 @@ Inductive p_step : Set := | P_LEFT : p_step -> p_step | P_RIGHT : p_step -> p_step | P_INVERT : step -> p_step - | P_STEP : step -> p_step - | P_NOP : p_step. + | P_STEP : step -> p_step. (* List of normalizations to perform : if the type [p_step] had a constructor that indicated visiting both left and right branches, we would be able to @@ -2806,7 +2805,6 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition := | P_RIGHT s => p_apply_right (p_rewrite s) | P_STEP s => move_right s | P_INVERT s => p_invert (move_right s) - | P_NOP => fun p : proposition => p end. Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). @@ -2816,7 +2814,6 @@ Proof. - intros; apply p_apply_right_stable; trivial. - intros; apply p_invert_stable; apply move_right_stable. - apply move_right_stable. - - unfold prop_stable; simpl; intros; split; auto. Qed. Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := -- cgit v1.2.3 From e25e1af79838103634ee445fdb38d53c19587365 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 22 May 2017 13:33:36 +0200 Subject: refl_omega: refactoring (e.g. useless args in destructurate_pos_hyp) --- plugins/romega/refl_omega.ml | 151 +++++++++++++++++++------------------------ 1 file changed, 67 insertions(+), 84 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index a20589fb4..b3135a164 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -13,6 +13,8 @@ open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver +module Id = Names.Id + (* \section{Useful functions and flags} *) (* Especially useful debugging functions *) let debug = ref false @@ -44,7 +46,7 @@ let occ_step_eq s1 s2 = match s1, s2 with (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) -type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} +type occurrence = {o_hyp : Id.t; o_path : occ_path} (* \subsection{reifiable formulas} *) type oformula = @@ -66,7 +68,7 @@ type comparaison = Eq | Leq | Geq | Gt | Lt | Neq (* Type des prédicats réifiés (fragment de calcul propositionnel. Les * quantifications sont externes au langage) *) type oproposition = - Pequa of Term.constr * oequation + Pequa of Term.constr * oequation (* constr = copy of the Coq formula *) | Ptrue | Pfalse | Pnot of oproposition @@ -84,7 +86,7 @@ and oequation = { e_origin: occurrence; (* l'hypothèse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont + e_depends: direction list; (* liste des points de disjonction dont dépend l'accès à l'équation avec la direction (branche) pour y accéder *) e_omega: afine (* la fonction normalisée *) @@ -141,7 +143,7 @@ type context_content = (* \section{Specific utility functions to handle base types} *) (* Nom arbitraire de l'hypothèse codant la négation du but final *) -let id_concl = Names.Id.of_string "__goal__" +let id_concl = Id.of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { @@ -265,13 +267,13 @@ let rec oprint ch = function | Oatom n -> Printf.fprintf ch "V%02d" n | Oufo x -> Printf.fprintf ch "?" +let print_comp = function + | Eq -> "=" | Leq -> "<=" | Geq -> ">=" + | Gt -> ">" | Lt -> "<" | Neq -> "!=" + let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - let connector = - match comp with - Eq -> "=" | Leq -> "<=" | Geq -> ">=" - | Gt -> ">" | Lt -> "<" | Neq -> "!=" in - Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 + Printf.fprintf ch "%a %s %a" oprint t1 (print_comp comp) oprint t2 | Ptrue -> Printf.fprintf ch "TT" | Pfalse -> Printf.fprintf ch "FF" | Pnot t -> Printf.fprintf ch "not(%a)" pprint t @@ -738,88 +740,69 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = (* Destructuration des hypothèses et de la conclusion *) +let display_gl env t_concl t_lhyps = + Printf.printf "REIFED PROBLEM\n\n"; + Printf.printf " CONCL: %a\n" pprint t_concl; + List.iter + (fun (i,t) -> Printf.printf " %s: %a\n" (Id.to_string i) pprint t) + t_lhyps; + print_env_reification env + let reify_gl env gl = let concl = Tacmach.New.pf_concl gl in let concl = EConstr.Unsafe.to_constr concl in + let hyps = Tacmach.New.pf_hyps_types gl in + let hyps = List.map (fun (i,t) -> (i,EConstr.Unsafe.to_constr t)) hyps in let t_concl = Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in - if !debug then begin - Printf.printf "REIFED PROBLEM\n\n"; - Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n" - end; - let rec loop = function - (i,t) :: lhyps -> - let t = EConstr.Unsafe.to_constr t in - let t' = oproposition_of_constr env (false,[],i,[]) gl t in - if !debug then begin - Printf.printf " %s: " (Names.Id.to_string i); - pprint stdout t'; - Printf.printf "\n" - end; - (i,t') :: loop lhyps - | [] -> - if !debug then print_env_reification env; - [] in - let t_lhyps = loop (Tacmach.New.pf_hyps_types gl) in + let t_lhyps = + List.map + (fun (i,t) -> i,oproposition_of_constr env (false,[],i,[]) gl t) + hyps + in + let () = if !debug then display_gl env t_concl t_lhyps in (id_concl,t_concl) :: t_lhyps -let rec destructurate_pos_hyp orig list_equations list_depends = function - | Pequa (_,e) -> [e :: list_equations] - | Ptrue | Pfalse | Pprop _ -> [list_equations] - | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t - | Por (i,t1,t2) -> - let s1 = - destructurate_pos_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_pos_hyp orig list_equations (i::list_depends) t2 in +let rec destruct_pos_hyp eqns = function + | Pequa (_,e) -> [e :: eqns] + | Ptrue | Pfalse | Pprop _ -> [eqns] + | Pnot t -> destruct_neg_hyp eqns t + | Por (_,t1,t2) -> + let s1 = destruct_pos_hyp eqns t1 in + let s2 = destruct_pos_hyp eqns t2 in s1 @ s2 - | Pand(i,t1,t2) -> - let list_s1 = - destructurate_pos_hyp orig list_equations (list_depends) t1 in - let rec loop = function - le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - | Pimp(i,t1,t2) -> - let s1 = - destructurate_neg_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + | Pand(_,t1,t2) -> + List.map_append + (fun le1 -> destruct_pos_hyp le1 t2) + (destruct_pos_hyp eqns t1) + | Pimp(_,t1,t2) -> + let s1 = destruct_neg_hyp eqns t1 in + let s2 = destruct_pos_hyp eqns t2 in s1 @ s2 -and destructurate_neg_hyp orig list_equations list_depends = function - | Pequa (_,e) -> [e :: list_equations] - | Ptrue | Pfalse | Pprop _ -> [list_equations] - | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t - | Pand (i,t1,t2) -> - let s1 = - destructurate_neg_hyp orig list_equations (i::list_depends) t1 in - let s2 = - destructurate_neg_hyp orig list_equations (i::list_depends) t2 in +and destruct_neg_hyp eqns = function + | Pequa (_,e) -> [e :: eqns] + | Ptrue | Pfalse | Pprop _ -> [eqns] + | Pnot t -> destruct_pos_hyp eqns t + | Pand (_,t1,t2) -> + let s1 = destruct_neg_hyp eqns t1 in + let s2 = destruct_neg_hyp eqns t2 in s1 @ s2 | Por(_,t1,t2) -> - let list_s1 = - destructurate_neg_hyp orig list_equations list_depends t1 in - let rec loop = function - le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 + List.map_append + (fun le1 -> destruct_neg_hyp le1 t2) + (destruct_neg_hyp eqns t1) | Pimp(_,t1,t2) -> - let list_s1 = - destructurate_pos_hyp orig list_equations list_depends t1 in - let rec loop = function - le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll - | [] -> [] in - loop list_s1 - -let destructurate_hyps syst = - let rec loop = function - (i,t) :: l -> - let l_syst1 = destructurate_pos_hyp i [] [] t in - let l_syst2 = loop l in - List.cartesian (@) l_syst1 l_syst2 - | [] -> [[]] in - loop syst + List.map_append + (fun le1 -> destruct_neg_hyp le1 t2) + (destruct_pos_hyp eqns t1) + +let rec destructurate_hyps = function + | [] -> [[]] + | (i,t) :: l -> + let l_syst1 = destruct_pos_hyp [] t in + let l_syst2 = destructurate_hyps l in + List.cartesian (@) l_syst1 l_syst2 (* \subsection{Affichage d'un système d'équation} *) @@ -846,7 +829,7 @@ let display_systems syst_list = (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); Printf.printf "\n Origin: %s (negated : %s)\n\n" - (Names.Id.to_string oformula_eq.e_origin.o_hyp) + (Id.to_string oformula_eq.e_origin.o_hyp) (if oformula_eq.e_negated then "yes" else "no") in let display_system syst = @@ -1023,7 +1006,7 @@ let find_path {o_hyp=id;o_path=p} env = | (x1::l1,x2::l2) when occ_step_eq x1 x2 -> loop_path (l1,l2) | _ -> None in let rec loop_id i = function - CCHyp{o_hyp=id';o_path=p'} :: l when Names.Id.equal id id' -> + CCHyp{o_hyp=id';o_path=p'} :: l when Id.equal id id' -> begin match loop_path (p',p) with Some r -> i,r | None -> loop_id (succ i) l @@ -1209,15 +1192,15 @@ let resolution env full_reified_goal systems_list = (* recupere explicitement ces equations *) let equations = List.map (get_equation env) useful_equa_id in let l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in - let l_hyps = id_concl :: List.remove Names.Id.equal id_concl l_hyps' in + let l_hyps = id_concl :: List.remove Id.equal id_concl l_hyps' in let useful_hyps = List.map - (fun id -> List.assoc_f Names.Id.equal id full_reified_goal) l_hyps + (fun id -> List.assoc_f Id.equal id full_reified_goal) l_hyps in let useful_vars = let really_useful_vars = vars_of_equations equations in let concl_vars = - vars_of_prop (List.assoc_f Names.Id.equal id_concl full_reified_goal) + vars_of_prop (List.assoc_f Id.equal id_concl full_reified_goal) in really_useful_vars @@ concl_vars in @@ -1268,7 +1251,7 @@ let resolution env full_reified_goal systems_list = | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = - let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in + let i = List.index0 Id.equal e.e_origin.o_hyp l_hyps in (* PL: it seems that additionally introduced hyps are in the way during normalization, hence this index shifting... *) if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) -- cgit v1.2.3 From 0fe4d837191de481184cc995558ca3774253be0c Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 9 May 2017 18:13:57 +0200 Subject: refl_omega: more refactoring (e.g. IntSets instead of sorted lists) --- plugins/romega/refl_omega.ml | 259 +++++++++++++++++++++++-------------------- 1 file changed, 136 insertions(+), 123 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index b3135a164..bb4ab37ff 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -14,6 +14,8 @@ module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver module Id = Names.Id +module IntSet = Int.Set +module IntHtbl = Hashtbl.Make(Int) (* \section{Useful functions and flags} *) (* Especially useful debugging functions *) @@ -40,10 +42,6 @@ type direction = Left of int | Right of int type occ_step = O_left | O_right | O_mono type occ_path = occ_step list -let occ_step_eq s1 s2 = match s1, s2 with -| O_left, O_left | O_right, O_right | O_mono, O_mono -> true -| _ -> false - (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) type occurrence = {o_hyp : Id.t; o_path : occ_path} @@ -110,19 +108,19 @@ type environment = { mutable om_vars : (oformula * int) list; (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) - real_indices : (int,int) Hashtbl.t; + real_indices : int IntHtbl.t; mutable cnt_connectors : int; - equations : (int,oequation) Hashtbl.t; - constructors : (int, occurrence) Hashtbl.t + equations : oequation IntHtbl.t; + constructors : occurrence IntHtbl.t } (* \subsection{Solution tree} Définition d'une solution trouvée par Omega sous la forme d'un identifiant, d'un ensemble d'équation dont dépend la solution et d'une trace *) -(* La liste des dépendances est triée et sans redondance *) + type solution = { s_index : int; - s_equa_deps : int list; + s_equa_deps : IntSet.t; s_trace : action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) @@ -141,6 +139,26 @@ type context_content = CCHyp of occurrence | CCEqua of int +(** Some dedicated equality tests *) + +let occ_step_eq s1 s2 = match s1, s2 with +| O_left, O_left | O_right, O_right | O_mono, O_mono -> true +| _ -> false + +let rec oform_eq f f' = match f,f' with + | Oint i, Oint i' -> Bigint.equal i i' + | Oplus (f1,f2), Oplus (f1',f2') + | Omult (f1,f2), Omult (f1',f2') + | Ominus (f1,f2), Ominus (f1',f2') -> oform_eq f1 f1' && oform_eq f2 f2' + | Oopp f, Oopp f' -> oform_eq f f' + | Oatom a, Oatom a' -> Int.equal a a' + | Oufo f, Oufo f' -> oform_eq f f' + | _ -> false + +let dir_eq d d' = match d, d' with + | Left i, Left i' | Right i, Right i' -> Int.equal i i' + | _ -> false + (* \section{Specific utility functions to handle base types} *) (* Nom arbitraire de l'hypothèse codant la négation du but final *) let id_concl = Id.of_string "__goal__" @@ -148,9 +166,9 @@ let id_concl = Id.of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { terms = []; props = []; om_vars = []; cnt_connectors = 0; - real_indices = Hashtbl.create 7; - equations = Hashtbl.create 7; - constructors = Hashtbl.create 7; + real_indices = IntHtbl.create 7; + equations = IntHtbl.create 7; + constructors = IntHtbl.create 7; } (* Génération d'un nom d'équation *) @@ -200,11 +218,10 @@ let display_omega_var i = Printf.sprintf "OV%d" i le terme d'un monome (le plus souvent un atome) *) let intern_omega env t = - begin try List.assoc_f Pervasives.(=) t env.om_vars (* FIXME *) + try List.assoc_f oform_eq t env.om_vars with Not_found -> let v = new_omega_var () in env.om_vars <- (t,v) :: env.om_vars; v - end (* Ajout forcé d'un lien entre un terme et une variable Cas où la variable est créée par Omega et où il faut la lier après coup à un atome @@ -214,8 +231,8 @@ let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars (* Récupère le terme associé à une variable *) let unintern_omega env id = let rec loop = function - [] -> failwith "unintern" - | ((t,j)::l) -> if Int.equal id j then t else loop l in + | [] -> failwith "unintern" + | ((t,j)::l) -> if Int.equal id j then t else loop l in loop env.om_vars (* \subsection{Gestion des environnements de variable pour la réflexion} @@ -248,12 +265,11 @@ let get_prop v env = (* Ajout d'une equation dans l'environnement de reification *) let add_equation env e = let id = e.e_omega.id in - try let _ = Hashtbl.find env.equations id in () - with Not_found -> Hashtbl.add env.equations id e + if IntHtbl.mem env.equations id then () else IntHtbl.add env.equations id e (* accès a une equation *) let get_equation env id = - try Hashtbl.find env.equations id + try IntHtbl.find env.equations id with Not_found as e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e @@ -337,10 +353,10 @@ let coq_of_formula env t = (* \subsection{Oformula vers COQ reifié} *) let reified_of_atom env i = - try Hashtbl.find env.real_indices i + try IntHtbl.find env.real_indices i with Not_found -> Printf.printf "Atome %d non trouvé\n" i; - Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; + IntHtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; raise Not_found let rec reified_of_formula env = function @@ -417,19 +433,19 @@ pour faire des opérations de normalisation sur les équations. *) (* Extraction des variables d'une équation. *) (* Chaque fonction retourne une liste triée sans redondance *) -let (@@) = List.merge_uniq compare +let (@@) = IntSet.union let rec vars_of_formula = function - | Oint _ -> [] + | Oint _ -> IntSet.empty | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Oopp e -> vars_of_formula e - | Oatom i -> [i] - | Oufo _ -> [] + | Oatom i -> IntSet.singleton i + | Oufo _ -> IntSet.empty let rec vars_of_equations = function - | [] -> [] + | [] -> IntSet.empty | e::l -> (vars_of_formula e.e_left) @@ (vars_of_formula e.e_right) @@ @@ -441,7 +457,7 @@ let rec vars_of_prop = function | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) - | Pprop _ | Ptrue | Pfalse -> [] + | Pprop _ | Ptrue | Pfalse -> IntSet.empty (* \subsection{Multiplication par un scalaire} *) @@ -694,7 +710,7 @@ and binprop env (neg2,depends,origin,path) let depends1 = if add_to_depends then Left i::depends else depends in let depends2 = if add_to_depends then Right i::depends else depends in if add_to_depends then - Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; + IntHtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; let t1' = oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in let t2' = @@ -754,14 +770,14 @@ let reify_gl env gl = let hyps = Tacmach.New.pf_hyps_types gl in let hyps = List.map (fun (i,t) -> (i,EConstr.Unsafe.to_constr t)) hyps in let t_concl = - Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in + oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl in let t_lhyps = List.map (fun (i,t) -> i,oproposition_of_constr env (false,[],i,[]) gl t) hyps in let () = if !debug then display_gl env t_concl t_lhyps in - (id_concl,t_concl) :: t_lhyps + t_concl, t_lhyps let rec destruct_pos_hyp eqns = function | Pequa (_,e) -> [e :: eqns] @@ -841,38 +857,35 @@ let display_systems syst_list = calcul des hypothèses *) let rec hyps_used_in_trace = function + | [] -> IntSet.empty | act :: l -> - begin match act with - | HYP e -> [e.id] @@ (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - hyps_used_in_trace act1 @@ hyps_used_in_trace act2 - | _ -> hyps_used_in_trace l - end - | [] -> [] + match act with + | HYP e -> IntSet.add e.id (hyps_used_in_trace l) + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + hyps_used_in_trace act1 @@ hyps_used_in_trace act2 + | _ -> hyps_used_in_trace l (* Extraction des variables déclarées dans une équation. Permet ensuite de les déclarer dans l'environnement de la procédure réflexive et éviter les créations de variable au vol *) let rec variable_stated_in_trace = function - | act :: l -> - begin match act with - | STATE action -> - (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) - (*i coef: int, var:int i*) - action :: variable_stated_in_trace l - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - variable_stated_in_trace act1 @ variable_stated_in_trace act2 - | _ -> variable_stated_in_trace l - end | [] -> [] -;; + | act :: l -> + match act with + | STATE action -> + (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) + (*i coef: int, var:int i*) + action :: variable_stated_in_trace l + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + variable_stated_in_trace act1 @ variable_stated_in_trace act2 + | _ -> variable_stated_in_trace l let add_stated_equations env tree = (* Il faut trier les variables par ordre d'introduction pour ne pas risquer de définir dans le mauvais ordre *) let stated_equations = - let cmpvar x y = Pervasives.(-) x.st_var y.st_var in + let cmpvar x y = Int.compare x.st_var y.st_var in let rec loop = function | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) @@ -904,22 +917,22 @@ let add_stated_equations env tree = arg, then second arg), unless you know what you're doing. *) let rec get_eclatement env = function - i :: r -> - let l = try (get_equation env i).e_depends with Not_found -> [] in - List.union Pervasives.(=) (List.rev l) (get_eclatement env r) | [] -> [] + | i :: r -> + let l = try (get_equation env i).e_depends with Not_found -> [] in + List.union dir_eq (List.rev l) (get_eclatement env r) let select_smaller l = - let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in + let comp (_,x) (_,y) = Int.compare (List.length x) (List.length y) in try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" let filter_compatible_systems required systems = let rec select = function - (x::l) -> - if List.mem x required then select l - else if List.mem (barre x) required then raise Exit - else x :: select l | [] -> [] + | (x::l) -> + if List.mem_f dir_eq x required then select l + else if List.mem_f dir_eq (barre x) required then raise Exit + else x :: select l in List.map_filter (function (sol, splits) -> @@ -935,46 +948,45 @@ let rec equas_of_solution_tree = function to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance Pfalse is decidable. So should not be used on conclusion (??) *) -let really_useful_prop l_equa c = - let rec real_of = function - Pequa(t,_) -> t - | Ptrue -> app coq_True [||] - | Pfalse -> app coq_False [||] - | Pnot t1 -> app coq_not [|real_of t1|] - | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] - | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] - (* Attention : implications sur le lifting des variables à comprendre ! *) - | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) - | Pprop t -> t in - let rec loop c = - match c with - Pequa(_,e) -> - if List.mem e.e_omega.id l_equa then Some c else None - | Ptrue -> None - | Pfalse -> None +let rec coq_of_oprop = function + | Pequa(t,_) -> t + | Ptrue -> app coq_True [||] + | Pfalse -> app coq_False [||] + | Pnot t1 -> app coq_not [|coq_of_oprop t1|] + | Por(_,t1,t2) -> app coq_or [|coq_of_oprop t1; coq_of_oprop t2|] + | Pand(_,t1,t2) -> app coq_and [|coq_of_oprop t1; coq_of_oprop t2|] + (* Attention : implications sur le lifting des variables à comprendre ! *) + | Pimp(_,t1,t2) -> Term.mkArrow (coq_of_oprop t1) (coq_of_oprop t2) + | Pprop t -> t + +let really_useful_prop equas c = + let rec loop c = match c with + | Pequa(_,e) -> if IntSet.mem e.e_omega.id equas then Some c else None | Pnot t1 -> - begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end + begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 - | Pprop t -> None + | Ptrue | Pfalse | Pprop _ -> None and binop f t1 t2 = begin match loop t1, loop t2 with None, None -> None | Some t1',Some t2' -> Some (f(t1',t2')) - | Some t1',None -> Some (f(t1',Pprop (real_of t2))) - | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) - end in + | Some t1',None -> Some (f(t1',Pprop (coq_of_oprop t2))) + | None,Some t2' -> Some (f(Pprop (coq_of_oprop t1),t2')) + end + in match loop c with - None -> Pprop (real_of c) + | None -> Pprop (coq_of_oprop c) | Some t -> t let rec display_solution_tree ch = function Leaf t -> output_string ch (Printf.sprintf "%d[%s]" - t.s_index - (String.concat " " (List.map string_of_int t.s_equa_deps))) + t.s_index + (String.concat " " (List.map string_of_int + (IntSet.elements t.s_equa_deps)))) | Tree(i,t1,t2) -> Printf.fprintf ch "S%d(%a,%a)" i display_solution_tree t1 display_solution_tree t2 @@ -1024,8 +1036,11 @@ let mk_direction_list l = (* \section{Rejouer l'historique} *) let get_hyp env_hyp i = - try List.index0 Pervasives.(=) (CCEqua i) env_hyp - with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) + let rec loop count = function + | [] -> failwith (Printf.sprintf "get_hyp %d" i) + | CCEqua i' :: _ when Int.equal i i' -> count + | _ :: l -> loop (succ count) l + in loop 0 env_hyp let replay_history env env_hyp = let rec loop env_hyp t = @@ -1120,7 +1135,7 @@ let replay_history env env_hyp = let rec decompose_tree env ctxt = function Tree(i,left,right) -> let org = - try Hashtbl.find env.constructors i + try IntHtbl.find env.constructors i with Not_found -> failwith (Printf.sprintf "Cannot find constructor %d" i) in let (index,path) = find_path org ctxt in @@ -1132,12 +1147,12 @@ let rec decompose_tree env ctxt = function decompose_tree env (left_hyp::ctxt) left; decompose_tree env (right_hyp::ctxt) right |] | Leaf s -> - decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps + decompose_tree_hyps s.s_trace env ctxt (IntSet.elements s.s_equa_deps) and decompose_tree_hyps trace env ctxt = function [] -> app coq_e_solve [| replay_history env ctxt trace |] | (i::l) -> let equation = - try Hashtbl.find env.equations i + try IntHtbl.find env.equations i with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in @@ -1157,7 +1172,7 @@ l'extraction d'un ensemble minimal de solutions permettant la résolution globale du système et enfin construit la trace qui permet de faire rejouer cette solution par la tactique réflexive. *) -let resolution env full_reified_goal systems_list = +let resolution env (reified_concl,reified_hyps) systems_list = let num = ref 0 in let solve_system list_eq = let index = !num in @@ -1166,14 +1181,14 @@ let resolution env full_reified_goal systems_list = simplify_strong (new_omega_eq,new_omega_var,display_omega_var) system in - (* calcule les hypotheses utilisées pour la solution *) + (* Hypotheses used for this solution *) let vars = hyps_used_in_trace trace in - let splits = get_eclatement env vars in + let splits = get_eclatement env (IntSet.elements vars) in if !debug then begin Printf.printf "SYSTEME %d\n" index; display_action display_omega_var trace; print_string "\n Depend :"; - List.iter (fun i -> Printf.printf " %d" i) vars; + IntSet.iter (fun i -> Printf.printf " %d" i) vars; print_string "\n Split points :"; List.iter display_depend splits; Printf.printf "\n------------------------------------\n" @@ -1187,23 +1202,21 @@ let resolution env full_reified_goal systems_list = display_solution_tree stdout solution_tree; print_newline() end; - (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) - let useful_equa_id = equas_of_solution_tree solution_tree in - (* recupere explicitement ces equations *) - let equations = List.map (get_equation env) useful_equa_id in - let l_hyps' = List.uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in - let l_hyps = id_concl :: List.remove Id.equal id_concl l_hyps' in - let useful_hyps = - List.map - (fun id -> List.assoc_f Id.equal id full_reified_goal) l_hyps + (* Collect all hypotheses used in the solution tree *) + let useful_equa_ids = equas_of_solution_tree solution_tree in + let equations = List.map (get_equation env) (IntSet.elements useful_equa_ids) in - let useful_vars = - let really_useful_vars = vars_of_equations equations in - let concl_vars = - vars_of_prop (List.assoc_f Id.equal id_concl full_reified_goal) - in - really_useful_vars @@ concl_vars + let hyps_of_eqns = + List.fold_left (fun s e -> Id.Set.add e.e_origin.o_hyp s) Id.Set.empty in + let hyps = hyps_of_eqns equations in + let useful_hypnames = Id.Set.elements (Id.Set.remove id_concl hyps) in + let all_names = id_concl :: useful_hypnames in + let useful_hyptypes = + List.map (fun id -> List.assoc_f Id.equal id reified_hyps) useful_hypnames + in + let useful_vars = vars_of_equations equations @@ vars_of_prop reified_concl in + (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in @@ -1212,13 +1225,14 @@ let resolution env full_reified_goal systems_list = (* L'environnement de base se construit en deux morceaux : - les variables des équations utiles (et de la conclusion) - les nouvelles variables declarées durant les preuves *) - let all_vars_env = useful_vars @ stated_vars in + let all_vars_env = (IntSet.elements useful_vars) @ stated_vars in let basic_env = let rec loop i = function - var :: l -> - let t = get_reified_atom env var in - Hashtbl.add env.real_indices var i; t :: loop (succ i) l - | [] -> [] in + | [] -> [] + | var :: l -> + let t = get_reified_atom env var in + IntHtbl.add env.real_indices var i; t :: loop (succ i) l + in loop 0 all_vars_env in let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in (* On peut maintenant généraliser le but : env est a jour *) @@ -1227,15 +1241,13 @@ let resolution env full_reified_goal systems_list = app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |]) to_introduce in - let reified_concl = - match useful_hyps with - (Pnot p) :: _ -> reified_of_proposition env p - | _ -> reified_of_proposition env Pfalse in + let reified_concl = reified_of_proposition env reified_concl in let l_reified_terms = - (List.map + List.map (fun p -> - reified_of_proposition env (really_useful_prop useful_equa_id p)) - (List.tl useful_hyps)) in + reified_of_proposition env (really_useful_prop useful_equa_ids p)) + useful_hyptypes + in let env_props_reified = mk_plist env.props in let reified_goal = mk_list (Lazy.force coq_proposition) @@ -1251,7 +1263,7 @@ let resolution env full_reified_goal systems_list = | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = - let i = List.index0 Id.equal e.e_origin.o_hyp l_hyps in + let i = List.index0 Id.equal e.e_origin.o_hyp all_names in (* PL: it seems that additionally introduced hyps are in the way during normalization, hence this index shifting... *) if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) @@ -1261,13 +1273,13 @@ let resolution env full_reified_goal systems_list = mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in let initial_context = - List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in + List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) useful_hypnames in let context = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in Tactics.generalize - (l_generalize_arg @ List.map EConstr.mkVar (List.tl l_hyps)) >> + (l_generalize_arg @ List.map EConstr.mkVar useful_hypnames) >> Tactics.change_concl reified >> Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> show_goal >> @@ -1287,10 +1299,11 @@ let total_reflexive_omega_tactic = rst_omega_var (); try let env = new_environment () in - let full_reified_goal = reify_gl env gl in + let (concl,hyps) as reified_goal = reify_gl env gl in + let full_reified_goal = (id_concl,Pnot concl) :: hyps in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; - resolution env full_reified_goal systems_list + resolution env reified_goal systems_list with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" end } -- cgit v1.2.3 From a79481b86881be12900b9b16b2f384eb3c402215 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 10 May 2017 15:17:20 +0200 Subject: romega: discard constructor D_mono (shorter trace + fix a bug) For the bug, see new test test_romega10 in test-suite/success/ROmega0.v. --- plugins/romega/ReflOmegaCore.v | 105 +++++++++++++---------------------------- plugins/romega/const_omega.ml | 1 - plugins/romega/const_omega.mli | 1 - plugins/romega/refl_omega.ml | 12 ++--- test-suite/success/ROmega0.v | 16 +++++++ 5 files changed, 56 insertions(+), 79 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 60c0018c5..1d24c8c21 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -935,6 +935,7 @@ Inductive t_omega : Set := (* \subsubsection{Rules for normalizing the hypothesis} *) (* These rules indicate how to normalize useful propositions of each useful hypothesis before the decomposition of hypothesis. + Negation nodes could be traversed by either [P_LEFT] or [P_RIGHT]. The rules include the inversion phase for negation removal. *) Inductive p_step : Set := @@ -955,13 +956,12 @@ Inductive h_step : Set := (* \subsubsection{Rules for decomposing the hypothesis} *) (* This type allows navigation in the logical constructors that form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a - conjunction with possibly the right level of negations. *) + This allows in particular to extract one hypothesis from a conjunction. + NB: negations are silently traversed. *) Inductive direction : Set := | D_left : direction - | D_right : direction - | D_mono : direction. + | D_right : direction. (* This type allows extracting useful components from hypothesis, either hypothesis generated by splitting a disjonction, or equations. @@ -2841,77 +2841,42 @@ Proof. intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. -Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : +Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : proposition := - match s with - | D_left :: l => - match p with - | Tand x y => extract_hyp_pos l x - | _ => p - end - | D_right :: l => - match p with - | Tand x y => extract_hyp_pos l y - | _ => p - end - | D_mono :: l => match p with - | Tnot x => extract_hyp_neg l x - | _ => p - end - | _ => p + match p, s with + | Tand x y, D_left :: l => extract_hyp_pos l x + | Tand x y, D_right :: l => extract_hyp_pos l y + | Tnot x, _ => extract_hyp_neg s x + | _, _ => p end - with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : + with extract_hyp_neg (s : list direction) (p : proposition) : proposition := - match s with - | D_left :: l => - match p with - | Tor x y => extract_hyp_neg l x - | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p - | _ => Tnot p - end - | D_right :: l => - match p with - | Tor x y => extract_hyp_neg l y - | Timp x y => extract_hyp_neg l y - | _ => Tnot p - end - | D_mono :: l => - match p with - | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p - | _ => Tnot p - end - | _ => - match p with - | Tnot x => if decidability x then x else Tnot p - | _ => Tnot p - end + match p, s with + | Tor x y, D_left :: l => extract_hyp_neg l x + | Tor x y, D_right :: l => extract_hyp_neg l y + | Timp x y, D_left :: l => + if decidability x then extract_hyp_pos l x else Tnot p + | Timp x y, D_right :: l => extract_hyp_neg l y + | Tnot x, _ => if decidability x then extract_hyp_pos s x else Tnot p + | _, _ => Tnot p end. -Definition co_valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). - Theorem extract_valid : forall s : list direction, - valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). -Proof. - unfold valid1, co_valid1; simple induction s. - - split. - + simpl; auto. - + intros ep e p1; case p1; simpl; auto; intro p. - destruct decidability eqn:H. - * generalize (decidable_correct ep e p H); - unfold decidable; tauto. - * simpl; auto. - - intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; - case p; auto; simpl; intros; - (apply H1; tauto) || - (apply H2; tauto) || - (destruct decidability eqn:H3; try tauto; - generalize (decidable_correct ep e p0 H3); - unfold decidable; intro H4; apply H1; - tauto). + valid1 (extract_hyp_pos s). +Proof. + assert (forall p s ep e, + (interp_proposition ep e p -> + interp_proposition ep e (extract_hyp_pos s p)) /\ + (interp_proposition ep e (Tnot p) -> + interp_proposition ep e (extract_hyp_neg s p))). + { induction p; destruct s; simpl; auto; split; try destruct d; try easy; + intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto; + destruct decidability eqn:D; intros; auto; + pose proof (decidable_correct ep e _ D); unfold decidable in *; + (apply IHp || apply IHp1); tauto. } + red. intros. now apply H. Qed. Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := @@ -2960,11 +2925,9 @@ Proof. - right; apply H0; simpl; tauto. - left; apply H; simpl; tauto. } { simpl; auto. } - + elim (extract_valid l); intros H2 H3. - apply H2, nth_valid; auto. + + apply extract_valid, nth_valid; auto. - intros; apply H; simpl; split; auto. - elim (extract_valid l); intros H2 H3. - apply H2; apply nth_valid; auto. + apply extract_valid, nth_valid; auto. - apply omega_valid with (1 := H). Qed. diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 8d7ae51fc..cf5d20aeb 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -165,7 +165,6 @@ let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") let coq_direction = lazy (constant "direction") let coq_d_left = lazy (constant "D_left") let coq_d_right = lazy (constant "D_right") -let coq_d_mono = lazy (constant "D_mono") let coq_e_split = lazy (constant "E_SPLIT") let coq_e_extract = lazy (constant "E_EXTRACT") diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index ee7ff451a..1c67af806 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -99,7 +99,6 @@ val coq_s_negate_contradict_inv : Term.constr lazy_t val coq_direction : Term.constr lazy_t val coq_d_left : Term.constr lazy_t val coq_d_right : Term.constr lazy_t -val coq_d_mono : Term.constr lazy_t val coq_e_split : Term.constr lazy_t val coq_e_extract : Term.constr lazy_t diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index bb4ab37ff..af396d489 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1029,8 +1029,11 @@ let find_path {o_hyp=id;o_path=p} env = let mk_direction_list l = let trans = function - O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in - mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) + | O_left -> Some (Lazy.force coq_d_left) + | O_right -> Some (Lazy.force coq_d_right) + | O_mono -> None (* No more [D_mono] constructor now *) + in + mk_list (Lazy.force coq_direction) (List.map_filter trans l) (* \section{Rejouer l'historique} *) @@ -1156,13 +1159,10 @@ and decompose_tree_hyps trace env ctxt = function with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in - let full_path = if equation.e_negated then path @ [O_mono] else path in let cont = decompose_tree_hyps trace env (CCEqua equation.e_omega.id :: ctxt) l in - app coq_e_extract [|mk_nat index; - mk_direction_list full_path; - cont |] + app coq_e_extract [|mk_nat index; mk_direction_list path; cont |] (* \section{La fonction principale} *) (* Cette fonction construit la diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v index 1348bb623..42730f2e1 100644 --- a/test-suite/success/ROmega0.v +++ b/test-suite/success/ROmega0.v @@ -135,11 +135,13 @@ Qed. (* Magaud #240 *) Lemma test_romega_8 : forall x y:Z, x*x ~ y*y <= x*x. +Proof. intros. romega. Qed. Lemma test_romega_8b : forall x y:Z, x*x ~ y*y <= x*x. +Proof. intros x y. romega. Qed. @@ -147,6 +149,20 @@ Qed. (* Besson #1298 *) Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False. +Proof. intros. romega. Qed. + +(* Letouzey, May 2017 *) + +Lemma test_romega10 : forall x a a' b b', + a' <= b -> + a <= b' -> + b < b' -> + a < a' -> + a <= x < b' <-> a <= x < b \/ a' <= x < b'. +Proof. + intros. + romega. +Qed. -- cgit v1.2.3 From 7ffb02d2c5534a6c39ee1e5fd42060d559195e39 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 22 May 2017 13:44:49 +0200 Subject: refl_omega: comment the lack of lifts when dealing with arrows --- plugins/romega/refl_omega.ml | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index af396d489..ad934aca2 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -63,8 +63,11 @@ type oformula = (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq -(* Type des prédicats réifiés (fragment de calcul propositionnel. Les - * quantifications sont externes au langage) *) +(* Representation of reified predicats (fragment of propositional calculus, + no quantifier here). *) +(* Note : in [Pprop p], the non-reified constr [p] should be closed + (it could contains some [Term.Var] but no [Term.Rel]). So no need to + lift when breaking or creating arrows. *) type oproposition = Pequa of Term.constr * oequation (* constr = copy of the Coq formula *) | Ptrue @@ -75,7 +78,7 @@ type oproposition = | Pimp of int * oproposition * oproposition | Pprop of Term.constr -(* Les équations ou propositions atomiques utiles du calcul *) +(* The equations *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) @@ -314,12 +317,12 @@ let rec weight env = function let omega_of_oformula env kind = let rec loop accu = function | Oplus(Omult(v,Oint n),r) -> - loop ({v=intern_omega env v; c=n} :: accu) r + loop ({v=intern_omega env v; c=n} :: accu) r | Oint n -> - let id = new_omega_eq () in - (*i tag_equation name id; i*) - {kind = kind; body = List.rev accu; - constant = n; id = id} + let id = new_omega_eq () in + (*i tag_equation name id; i*) + {kind = kind; body = List.rev accu; + constant = n; id = id} | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in loop [] @@ -327,9 +330,9 @@ let omega_of_oformula env kind = let oformula_of_omega env af = let rec loop = function - | ({v=v; c=n}::r) -> - Oplus(Omult(unintern_omega env v,Oint n),loop r) - | [] -> Oint af.constant in + | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) + | [] -> Oint af.constant + in loop af.body let app f v = mkApp(Lazy.force f,v) @@ -750,8 +753,9 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 | Riff (t1,t2) -> - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) + (* No lifting here, since Omega only works on closed propositions. *) + binprop env ctxt negated negated gl + (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c (* Destructuration des hypothèses et de la conclusion *) @@ -955,8 +959,9 @@ let rec coq_of_oprop = function | Pnot t1 -> app coq_not [|coq_of_oprop t1|] | Por(_,t1,t2) -> app coq_or [|coq_of_oprop t1; coq_of_oprop t2|] | Pand(_,t1,t2) -> app coq_and [|coq_of_oprop t1; coq_of_oprop t2|] - (* Attention : implications sur le lifting des variables à comprendre ! *) - | Pimp(_,t1,t2) -> Term.mkArrow (coq_of_oprop t1) (coq_of_oprop t2) + | Pimp(_,t1,t2) -> + (* No lifting here, since Omega only works on closed propositions. *) + Term.mkArrow (coq_of_oprop t1) (coq_of_oprop t2) | Pprop t -> t let really_useful_prop equas c = @@ -1288,7 +1293,7 @@ let resolution env (reified_concl,reified_hyps) systems_list = - Normalisation without VM: Tactics.normalise_in_concl - Skip the conversion check and rely directly on the QED: - Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> + Tactics.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) Tactics.apply (EConstr.of_constr (Lazy.force coq_I)) -- cgit v1.2.3 From 80e21990d36224f2b06bf131cbc87dbfbd274af0 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 10 May 2017 17:35:13 +0200 Subject: romega: if it bugs again, at least do it with a short and quick error --- plugins/romega/ReflOmegaCore.v | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 1d24c8c21..2c8879e66 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -2879,6 +2879,10 @@ Proof. red. intros. now apply H. Qed. +(** Attempt to shorten error messages if romega goes rogue... + NB: [interp_list_goal _ _ BUG = False /\ True]. *) +Definition BUG : lhyps := nil :: nil. + Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := match s with | E_SPLIT i dl s1 s2 => @@ -2889,12 +2893,12 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (Tnot y :: h) - else h :: nil + else BUG | Timp x y => if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) - else h::nil - | _ => h :: nil + else BUG + | _ => BUG end | E_EXTRACT i dl s1 => decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) @@ -2939,9 +2943,9 @@ Definition valid_lhyps (f : lhyps -> lhyps) := Fixpoint reduce_lhyps (lp : lhyps) : lhyps := match lp with + | nil => nil | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' - | x :: lp' => x :: reduce_lhyps lp' - | nil => nil (A:=hyps) + | x :: lp' => BUG end. Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. -- cgit v1.2.3 From 7547cd5ea5ca48a3c1128349e423e464254bc357 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 10 May 2017 17:40:21 +0200 Subject: ReflOmegaCore: lots of dead code + a few refactored proofs --- plugins/romega/ReflOmegaCore.v | 411 ++++++++--------------------------------- 1 file changed, 76 insertions(+), 335 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 2c8879e66..27fd97b2f 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -327,13 +327,6 @@ Module IntProperties (I:Int). now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. Qed. - Lemma OMEGA15 : - forall v c1 c2 l1 l2 k2 : int, - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). - Proof. - intros; autorewrite with int; f_equal; now rewrite plus_permute. - Qed. - Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. Proof. intros; now autorewrite with int. @@ -1520,20 +1513,6 @@ Proof. apply OMEGA13. Qed. -Definition T_OMEGA15 (t : term) := - match t with - | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' - then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term - else t - | _ => t - end. - -Theorem T_OMEGA15_stable : term_stable T_OMEGA15. -Proof. - prove_stable T_OMEGA15 OMEGA15. -Qed. - Definition T_OMEGA16 (t : term) := match t with | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term @@ -1804,20 +1783,6 @@ Proof. * exact T_OMEGA12_stable. Qed. -(* \paragraph{Fusion de deux équations dont une sans coefficient} *) - -Definition fusion_right (trace : list t_fusion) (t : term) : term := - match trace with - | nil => reduce t (* Il faut mettre un compute *) - | step :: trace' => - match step with - | F_equal => apply_right (fusion trace') (T_OMEGA15 t) - | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) - | F_left => apply_right (fusion trace') (Tplus_assoc_r t) - | F_right => apply_right (fusion trace') (T_OMEGA12 t) - end - end. - (* \paragraph{Fusion avec annihilation} *) (* Normalement le résultat est une constante *) @@ -2349,7 +2314,7 @@ Proof. Qed. -(* \subsection{La fonction de rejeu de la trace} *) +(* \subsection{Replaying the resolution trace} *) Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with @@ -2438,266 +2403,6 @@ Definition move_right (s : step) (p : proposition) := | p => p end. -Theorem move_right_valid : forall s : step, valid1 (move_right s). -Proof. - unfold valid1, move_right; intros s ep e p; Simplify; simpl; - elim (t_rewrite_stable s e); simpl. - - symmetry ; apply egal_left; assumption. - - intro; apply le_left; assumption. - - intro; apply le_left; rewrite <- ge_le_iff; assumption. - - intro; apply lt_left; rewrite <- gt_lt_iff; assumption. - - intro; apply lt_left; assumption. - - intro; apply ne_left_2; assumption. -Qed. - -Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). - -Theorem do_normalize_valid : - forall (i : nat) (s : step), valid_hyps (do_normalize i s). -Proof. - intros; unfold do_normalize; apply apply_oper_1_valid; - apply move_right_valid. -Qed. - -Fixpoint do_normalize_list (l : list step) (i : nat) - (h : hyps) {struct l} : hyps := - match l with - | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) - | nil => h - end. - -Theorem do_normalize_list_valid : - forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). -Proof. - simple induction l; simpl; unfold valid_hyps. - - auto. - - intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; - apply (do_normalize_valid i a ep e lp); assumption. -Qed. - -Theorem normalize_goal : - forall (s : list step) (ep : list Prop) (env : list int) (l : hyps), - interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. -Qed. - -(* \subsubsection{Exécution de la trace} *) - -Theorem execute_goal : - forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), - interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. -Proof. - intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). -Qed. - - -Theorem append_goal : - forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), - interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> - interp_list_goal ep e (l1 ++ l2). -Proof. - intros ep e; induction l1; simpl. - - intros l2 (H1, H2); assumption. - - intros l2 ((H1, H2), H3); split; auto. -Qed. - -(* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by - induction and uses well known theorem about arithmetic and propositional - calculus *) - -Fixpoint decidability (p : proposition) : bool := - match p with - | EqTerm _ _ => true - | LeqTerm _ _ => true - | GeqTerm _ _ => true - | GtTerm _ _ => true - | LtTerm _ _ => true - | NeqTerm _ _ => true - | FalseTerm => true - | TrueTerm => true - | Tnot t => decidability t - | Tand t1 t2 => decidability t1 && decidability t2 - | Timp t1 t2 => decidability t1 && decidability t2 - | Tor t1 t2 => decidability t1 && decidability t2 - | Tprop _ => false - end. - -Theorem decidable_correct : - forall (ep : list Prop) (e : list int) (p : proposition), - decidability p = true -> decidable (interp_proposition ep e p). -Proof. - simple induction p; simpl; intros. - - apply dec_eq. - - apply dec_le. - - left; auto. - - right; unfold not; auto. - - apply dec_not; auto. - - apply dec_ge. - - apply dec_gt. - - apply dec_lt. - - apply dec_ne. - - apply dec_or; elim andb_prop with (1 := H1); auto. - - apply dec_and; elim andb_prop with (1 := H1); auto. - - apply dec_imp; elim andb_prop with (1 := H1); auto. - - discriminate H. -Qed. - -(* An interpretation function for a complete goal with an explicit - conclusion. We use an intermediate fixpoint. *) - -Fixpoint interp_full_goal (envp : list Prop) (env : list int) - (c : proposition) (l : hyps) {struct l} : Prop := - match l with - | nil => interp_proposition envp env c - | p' :: l' => - interp_proposition envp env p' -> interp_full_goal envp env c l' - end. - -Definition interp_full (ep : list Prop) (e : list int) - (lc : hyps * proposition) : Prop := - match lc with - | (l, c) => interp_full_goal ep e c l - end. - -(* Relates the interpretation of a complete goal with the interpretation - of its hypothesis and conclusion *) - -Theorem interp_full_false : - forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), - (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). -Proof. - simple induction l; unfold interp_full; simpl. - - auto. - - intros a l1 H1 c H2 H3; apply H1; auto. -Qed. - -(* Push the conclusion in the list of hypothesis using a double negation - If the decidability cannot be "proven", then just forget about the - conclusion (equivalent of replacing it with false) *) - -Definition to_contradict (lc : hyps * proposition) := - match lc with - | (l, c) => if decidability c then Tnot c :: l else l - end. - -(* The previous operation is valid in the sense that the new list of - hypothesis implies the original goal *) - -Theorem to_contradict_valid : - forall (ep : list Prop) (e : list int) (lc : hyps * proposition), - interp_goal ep e (to_contradict lc) -> interp_full ep e lc. -Proof. - intros ep e (l,c); simpl. - destruct decidability eqn:H; simpl; - intros H1; apply interp_full_false; intros H2. - - apply not_not. - + now apply decidable_correct. - + intro; apply hyps_to_goal with (2 := H2); auto. - - now elim hyps_to_goal with (1 := H1). -Qed. - -(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list - of lists *) - -Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : - list (list A) := - match l with - | nil => nil - | l :: ll => (x :: l) :: map_cons A x ll - end. - -(* This function breaks up a list of hypothesis in a list of simpler - list of hypothesis that together implie the original one. The goal - of all this is to transform the goal in a list of solvable problems. - Note that : - - we need a way to drive the analysis as some hypotheis may not - require a split. - - this procedure must be perfectly mimicked by the ML part otherwise - hypothesis will get desynchronised and this will be a mess. - *) - -Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := - match nn with - | O => ll :: nil - | S n => - match ll with - | nil => nil :: nil - | Tor p1 p2 :: l => - destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) - | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) - | Timp p1 p2 :: l => - if decidability p1 - then - destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) - else map_cons _ (Timp p1 p2) (destructure_hyps n l) - | Tnot p :: l => - match p with - | Tnot p1 => - if decidability p1 - then destructure_hyps n (p1 :: l) - else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) - | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) - | Tand p1 p2 => - if decidability p1 - then - destructure_hyps n (Tnot p1 :: l) ++ - destructure_hyps n (Tnot p2 :: l) - else map_cons _ (Tnot p) (destructure_hyps n l) - | _ => map_cons _ (Tnot p) (destructure_hyps n l) - end - | x :: l => map_cons _ x (destructure_hyps n l) - end - end. - -Theorem map_cons_val : - forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps), - interp_proposition ep e p -> - interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). -Proof. - induction l; simpl; intuition. -Qed. - -Hint Resolve map_cons_val append_valid decidable_correct. - -Theorem destructure_hyps_valid : - forall n : nat, valid_list_hyps (destructure_hyps n). -Proof. - simple induction n. - - unfold valid_list_hyps; simpl; auto. - - unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp. - + simpl; auto. - + intros p l; case p; - try - (simpl; intros; apply map_cons_val; simpl; elim H0; - auto). - * intro p'; case p'; simpl; - try - (simpl; intros; apply map_cons_val; simpl; elim H0; - auto). - { simpl; intros p1 (H1, H2). - destruct decidability eqn:H3; auto. - apply H; simpl; split; auto. - apply not_not; auto. } - { simpl; intros p1 p2 (H1, H2); apply H; simpl; - elim not_or with (1 := H1); auto. } - { simpl; intros p1 p2 (H1, H2). - destruct decidability eqn:H3; auto. - apply append_valid; elim not_and with (2 := H1); auto. - - intro; left; apply H; simpl; auto. - - intro; right; apply H; simpl; auto. } - * simpl; intros p1 p2 (H1, H2); apply append_valid; - (elim H1; intro H3; simpl; [ left | right ]); - apply H; simpl; auto. - * simpl; intros; apply H; simpl; tauto. - * simpl; intros p1 p2 (H1, H2). - destruct decidability eqn:H3; auto. - apply append_valid; elim imp_simp with (2 := H1); auto. - { intro; left; simpl; apply H; simpl; auto. } - { intro; right; simpl; apply H; simpl; auto. } -Qed. - Definition prop_stable (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p : proposition), interp_proposition ep e p <-> interp_proposition ep e (f p). @@ -2841,6 +2546,48 @@ Proof. intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. +(* A simple decidability checker : if the proposition belongs to the + simple grammar describe below then it is decidable. Proof is by + induction and uses well known theorem about arithmetic and propositional + calculus *) + +Fixpoint decidability (p : proposition) : bool := + match p with + | EqTerm _ _ => true + | LeqTerm _ _ => true + | GeqTerm _ _ => true + | GtTerm _ _ => true + | LtTerm _ _ => true + | NeqTerm _ _ => true + | FalseTerm => true + | TrueTerm => true + | Tnot t => decidability t + | Tand t1 t2 => decidability t1 && decidability t2 + | Timp t1 t2 => decidability t1 && decidability t2 + | Tor t1 t2 => decidability t1 && decidability t2 + | Tprop _ => false + end. + +Theorem decidable_correct : + forall (ep : list Prop) (e : list int) (p : proposition), + decidability p = true -> decidable (interp_proposition ep e p). +Proof. + simple induction p; simpl; intros. + - apply dec_eq. + - apply dec_le. + - left; auto. + - right; unfold not; auto. + - apply dec_not; auto. + - apply dec_ge. + - apply dec_gt. + - apply dec_lt. + - apply dec_ne. + - apply dec_or; elim andb_prop with (1 := H1); auto. + - apply dec_and; elim andb_prop with (1 := H1); auto. + - apply dec_imp; elim andb_prop with (1 := H1); auto. + - discriminate H. +Qed. + Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : proposition := match p, s with @@ -2863,8 +2610,7 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : end. Theorem extract_valid : - forall s : list direction, - valid1 (extract_hyp_pos s). + forall s : list direction, valid1 (extract_hyp_pos s). Proof. assert (forall p s ep e, (interp_proposition ep e p -> @@ -2873,8 +2619,8 @@ Proof. interp_proposition ep e (extract_hyp_neg s p))). { induction p; destruct s; simpl; auto; split; try destruct d; try easy; intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto; - destruct decidability eqn:D; intros; auto; - pose proof (decidable_correct ep e _ D); unfold decidable in *; + destruct decidability eqn:D; auto; + apply (decidable_correct ep e) in D; unfold decidable in D; (apply IHp || apply IHp1); tauto. } red. intros. now apply H. Qed. @@ -2905,34 +2651,30 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := | E_SOLVE t => execute_omega t h end. -Theorem decompose_solve_valid : - forall s : e_step, valid_list_goal (decompose_solve s). -Proof. - intro s; apply goal_valid; unfold valid_list_hyps; elim s; - simpl; intros. - - cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))). - + case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto. - * intro p; case p; simpl; auto; intros p1 p2 H2. - destruct decidability eqn:H3. - { generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5. - - right; apply H0; simpl; tauto. - - left; apply H; simpl; tauto. } - { simpl; auto. } - * intros p1 p2 H2; apply append_valid; simpl; elim H2. - { intros H3; left; apply H; simpl; auto. } - { intros H3; right; apply H0; simpl; auto. } - * intros p1 p2 H2; - destruct decidability eqn:H3. - { generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5. - - right; apply H0; simpl; tauto. - - left; apply H; simpl; tauto. } - { simpl; auto. } - + apply extract_valid, nth_valid; auto. - - intros; apply H; simpl; split; auto. - apply extract_valid, nth_valid; auto. - - apply omega_valid with (1 := H). +Theorem decompose_solve_valid (s : e_step) : + valid_list_goal (decompose_solve s). +Proof. + apply goal_valid. red. induction s; simpl; intros ep e lp H. + - assert (H' : interp_proposition ep e (extract_hyp_pos l (nth_hyps n lp))). + { now apply extract_valid, nth_valid. } + destruct extract_hyp_pos; simpl in *; auto. + + destruct p; simpl; auto. + destruct decidability eqn:D; [ | simpl; auto]. + apply (decidable_correct ep e) in D. + apply append_valid. simpl in *. destruct D. + * right. apply IHs2. simpl; auto. + * left. apply IHs1. simpl; auto. + + apply append_valid. destruct H'. + * left. apply IHs1. simpl; auto. + * right. apply IHs2. simpl; auto. + + destruct decidability eqn:D; [ | simpl; auto]. + apply (decidable_correct ep e) in D. + apply append_valid. destruct D. + * right. apply IHs2. simpl; auto. + * left. apply IHs1. simpl; auto. + - apply IHs; simpl; split; auto. + now apply extract_valid, nth_valid. + - now apply omega_valid. Qed. (* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) @@ -2974,13 +2716,12 @@ Definition do_concl_to_hyp : interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. Proof. - simpl; intros envp env c l; induction l as [| a l Hrecl]. - - simpl; unfold concl_to_hyp; - destruct decidability eqn:H. - + generalize (decidable_correct envp env c H); - unfold decidable; simpl; tauto. - + simpl; intros H2; elim H2; trivial. - - simpl; tauto. + induction l; simpl. + - unfold concl_to_hyp; simpl. + destruct decidability eqn:D; [ | simpl; tauto ]. + apply (decidable_correct envp env) in D. unfold decidable in D. + simpl. tauto. + - simpl in *; tauto. Qed. Definition omega_tactic (t1 : e_step) (t2 : list h_step) -- cgit v1.2.3 From 2c01ce4b5d52a9f86553d07a83a237902b0cbc64 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 10 May 2017 19:19:45 +0200 Subject: refl_omega: refactoring of normalize_equation --- plugins/romega/refl_omega.ml | 22 +++++++++------------- 1 file changed, 9 insertions(+), 13 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index ad934aca2..866f91b85 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -668,25 +668,21 @@ let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = - let mk_step t1 t2 f kind = - let t = f t1 t2 in + let mk_step t1 t2 t kind = let trace, oterm = normalize_linear_term env t in let equa = omega_of_oformula env kind oterm in { e_comp = oper; e_left = t1; e_right = t2; e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; - e_trace = trace; e_omega = equa } in + e_trace = trace; e_omega = equa } + in try match (if negated then (negate_oper oper) else oper) with - | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA - | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE - | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ - | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ - | Lt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) - INEQ - | Gt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) - INEQ + | Eq -> mk_step t1 t2 (Oplus (t1,Oopp t2)) EQUA + | Neq -> mk_step t1 t2 (Oplus (t1,Oopp t2)) DISE + | Leq -> mk_step t1 t2 (Oplus (t2,Oopp t1)) INEQ + | Geq -> mk_step t1 t2 (Oplus (t1,Oopp t2)) INEQ + | Lt -> mk_step t1 t2 (Oplus (Oplus(t2,Oint negone),Oopp t1)) INEQ + | Gt -> mk_step t1 t2 (Oplus (Oplus(t1,Oint negone),Oopp t2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothèses} *) -- cgit v1.2.3 From f3b186bad386f6215aa9d9ebd02ab97246ee50c1 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Thu, 11 May 2017 16:12:12 +0200 Subject: romega: shorter trace (no more term lengths) --- plugins/romega/ReflOmegaCore.v | 271 ++++++++++++++++++----------------------- plugins/romega/refl_omega.ml | 18 +-- 2 files changed, 122 insertions(+), 167 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 27fd97b2f..b0c9cd6e5 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -327,11 +327,6 @@ Module IntProperties (I:Int). now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. Qed. - Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k. - Proof. - intros; now autorewrite with int. - Qed. - Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. intros; elim H; elim H0; simpl; auto. @@ -911,18 +906,18 @@ Inductive t_omega : Set := | O_CONSTANT_NOT_NUL : nat -> t_omega | O_CONSTANT_NEG : nat -> t_omega (* division and approximation of an equation *) - | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega + | O_DIV_APPROX : int -> int -> term -> t_omega -> nat -> t_omega (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega + | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> t_omega (* exact division *) - | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega + | O_EXACT_DIVIDE : int -> term -> t_omega -> nat -> t_omega | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega - | O_CONTRADICTION : nat -> nat -> nat -> t_omega - | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega - | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega + | O_CONTRADICTION : nat -> nat -> t_omega + | O_MERGE_EQ : nat -> nat -> t_omega -> t_omega + | O_SPLIT_INEQ : nat -> t_omega -> t_omega -> t_omega | O_CONSTANT_NUL : nat -> t_omega | O_NEGATE_CONTRADICT : nat -> nat -> t_omega - | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega + | O_NEGATE_CONTRADICT_INV : nat -> nat -> t_omega | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. (* \subsubsection{Rules for normalizing the hypothesis} *) @@ -1498,33 +1493,6 @@ Proof. prove_stable T_OMEGA12 OMEGA12. Qed. -Definition T_OMEGA13 (t : term) := - match t with - | (v * Tint x + l1 + (v' * Tint x' + l2))%term => - if eq_term v v' && beq x (-x') - then (l1+l2)%term - else t - | _ => t - end. - -Theorem T_OMEGA13_stable : term_stable T_OMEGA13. -Proof. - unfold term_stable, T_OMEGA13; intros; Simplify; simpl; - apply OMEGA13. -Qed. - -Definition T_OMEGA16 (t : term) := - match t with - | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term - | _ => t - end. - - -Theorem T_OMEGA16_stable : term_stable T_OMEGA16. -Proof. - prove_stable T_OMEGA16 OMEGA16. -Qed. - Definition Tred_factor5 (t : term) := match t with | (x * Tint c + y)%term => if beq c 0 then y else t @@ -1786,68 +1754,67 @@ Qed. (* \paragraph{Fusion avec annihilation} *) (* Normalement le résultat est une constante *) -Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => fusion_cancel trace' (T_OMEGA13 t) +Fixpoint fusion_cancel (t1 t2 : term) : term := + match t1, t2 with + | (v1 * Tint x1 + l1)%term, (v2 * Tint x2 + l2)%term => + if eq_term v1 v2 && beq x1 (-x2) + then fusion_cancel l1 l2 + else (t1+t2)%term (* should not happen *) + | Tint x1, Tint x2 => Tint (x1+x2) + | _, _ => (t1+t2)%term (* should not happen *) end. -Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). +Theorem fusion_cancel_stable e t1 t2 : + interp_term e (t1+t2)%term = interp_term e (fusion_cancel t1 t2). Proof. - unfold term_stable, fusion_cancel; intros trace e; elim trace. - - exact (reduce_stable e). - - intros n H t; elim H; exact (T_OMEGA13_stable e t). + revert t2. induction t1; destruct t2; simpl; Simplify; auto. + simpl in *. + rewrite <- IHt1_2. + apply OMEGA13. Qed. (* \subsubsection{Opérations affines sur une équation} *) (* \paragraph{Multiplication scalaire et somme d'une constante} *) -Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) +Fixpoint scalar_norm_add (t : term) (k1 k2 : int) : term := + match t with + | (v1 * Tint x1 + l1)%term => + (v1 * Tint (x1 * k1) + scalar_norm_add l1 k1 k2)%term + | Tint x => Tint (x * k1 + k2) + | _ => (t * Tint k1 + Tint k2)%term (* shouldn't happen *) end. -Theorem scalar_norm_add_stable : - forall t : nat, term_stable (scalar_norm_add t). +Theorem scalar_norm_add_stable e t k1 k2 : + interp_term e (t * Tint k1 + Tint k2)%term = + interp_term e (scalar_norm_add t k1 k2). Proof. - unfold term_stable, scalar_norm_add; intros trace; elim trace. - - exact reduce_stable. - - intros n H e t; elim apply_right_stable. - + exact (T_OMEGA11_stable e t). - + exact H. + induction t; simpl; Simplify; simpl; auto. + rewrite <- IHt2. simpl. apply OMEGA11. Qed. (* \paragraph{Multiplication scalaire} *) -Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) - end. +Definition scalar_norm (t : term) (k : int) := scalar_norm_add t k 0. -Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). +Theorem scalar_norm_stable e t k : + interp_term e (t * Tint k)%term = interp_term e (scalar_norm t k). Proof. - unfold term_stable, scalar_norm; intros trace; elim trace. - - exact reduce_stable. - - intros n H e t; elim apply_right_stable. - + exact (T_OMEGA16_stable e t). - + exact H. + unfold scalar_norm. rewrite <- scalar_norm_add_stable. simpl. + symmetry. apply plus_0_r. Qed. (* \paragraph{Somme d'une constante} *) -Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := - match trace with - | O => reduce t - | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) +Fixpoint add_norm (t : term) (k : int) : term := + match t with + | (m + l)%term => (m + add_norm l k)%term + | Tint x => Tint (x + k) + | _ => (t + Tint k)%term end. -Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). +Theorem add_norm_stable e t k : + interp_term e (t + Tint k)%term = interp_term e (add_norm t k). Proof. - unfold term_stable, add_norm; intros trace; elim trace. - - exact reduce_stable. - - intros n H e t; elim apply_right_stable. - + exact (Tplus_assoc_r_stable e t). - + exact H. + induction t; simpl; Simplify; simpl; auto. + rewrite <- IHt2. simpl. symmetry. apply plus_assoc. Qed. (* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) @@ -1953,11 +1920,11 @@ Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) Definition not_exact_divide (k1 k2 : int) (body : term) - (t i : nat) (l : hyps) := + (i : nat) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => if beq Nul 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + eq_term (scalar_norm_add body k1 k2) b && bgt k2 0 && bgt k1 k2 then absurd @@ -1966,13 +1933,13 @@ Definition not_exact_divide (k1 k2 : int) (body : term) end. Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (t0 i : nat), - valid_hyps (not_exact_divide k1 k2 body t0 i). + forall (k1 k2 : int) (body : term) (i : nat), + valid_hyps (not_exact_divide k1 k2 body i). Proof. - unfold valid_hyps, not_exact_divide; intros; + unfold valid_hyps, not_exact_divide; intros. generalize (nth_valid ep e i lp); Simplify. - rewrite (scalar_norm_add_stable t0 e), <-H1. - do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. + rewrite <-H1, <-scalar_norm_add_stable. simpl. + intros. absurd (interp_term e body * k1 + k2 = 0). - now apply OMEGA4. - symmetry; auto. @@ -1980,12 +1947,12 @@ Qed. (* \paragraph{[O_CONTRADICTION]} *) -Definition contradiction (t i j : nat) (l : hyps) := +Definition contradiction (i j : nat) (l : hyps) := match nth_hyps i l with | LeqTerm (Tint Nul) b1 => match nth_hyps j l with | LeqTerm (Tint Nul') b2 => - match fusion_cancel t (b1 + b2)%term with + match fusion_cancel b1 b2 with | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k then absurd else l @@ -1996,10 +1963,9 @@ Definition contradiction (t i j : nat) (l : hyps) := | _ => l end. -Theorem contradiction_valid : - forall t i j : nat, valid_hyps (contradiction t i j). +Theorem contradiction_valid (i j : nat) : valid_hyps (contradiction i j). Proof. - unfold valid_hyps, contradiction; intros t i j ep e l H. + unfold valid_hyps, contradiction; intros ep e l H. generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H). case (nth_hyps i l); trivial. intros t1 t2. case t1; trivial. clear t1; intros x1. @@ -2037,13 +2003,13 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) := | _ => h end. -Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := +Definition negate_contradict_inv (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + eq_term b1 (scalar_norm b2 (-(1))) then absurd else h | _ => h @@ -2052,7 +2018,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + eq_term b1 (scalar_norm b2 (-(1))) then absurd else h | _ => h @@ -2072,9 +2038,9 @@ Proof. Qed. Theorem negate_contradict_inv_valid : - forall t i j : nat, valid_hyps (negate_contradict_inv t i j). + forall i j : nat, valid_hyps (negate_contradict_inv i j). Proof. - unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H; + unfold valid_hyps, negate_contradict_inv; intros i j ep e l H; generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); @@ -2156,18 +2122,17 @@ Qed. (* \paragraph{[O_EXACT_DIVIDE]} c'est une oper1 valide mais on préfère une substitution a ce point la *) -Definition exact_divide (k : int) (body : term) (t : nat) - (prop : proposition) := +Definition exact_divide (k : int) (body : term) (prop : proposition) := match prop with | EqTerm (Tint Null) b => if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && + eq_term (scalar_norm body k) b && negb (beq k 0) then EqTerm (Tint 0) body else TrueTerm | NeqTerm (Tint Null) b => if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && + eq_term (scalar_norm body k) b && negb (beq k 0) then NeqTerm (Tint 0) body else TrueTerm @@ -2175,9 +2140,9 @@ Definition exact_divide (k : int) (body : term) (t : nat) end. Theorem exact_divide_valid : - forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). + forall (k : int) (t : term), valid1 (exact_divide k t). Proof. - unfold valid1, exact_divide; intros k1 k2 t ep e p1; + unfold valid1, exact_divide; intros k t ep e p1; Simplify; simpl; auto; subst; rewrite <- scalar_norm_stable; simpl; intros. - destruct (mult_integral _ _ (eq_sym H0)); intuition. @@ -2190,11 +2155,11 @@ Qed. est sur une opération de type valid1 et non sur une opération terminale. *) Definition divide_and_approx (k1 k2 : int) (body : term) - (t : nat) (prop : proposition) := + (prop : proposition) := match prop with | LeqTerm (Tint Null) b => if beq Null 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + eq_term (scalar_norm_add body k1 k2) b && bgt k1 0 && bgt k1 k2 then LeqTerm (Tint 0) body @@ -2203,24 +2168,24 @@ Definition divide_and_approx (k1 k2 : int) (body : term) end. Theorem divide_and_approx_valid : - forall (k1 k2 : int) (body : term) (t : nat), - valid1 (divide_and_approx k1 k2 body t). + forall (k1 k2 : int) (body : term), + valid1 (divide_and_approx k1 k2 body). Proof. unfold valid1, divide_and_approx. - intros k1 k2 body t ep e p1. Simplify. subst. - elim (scalar_norm_add_stable t e). simpl. - intro H2; apply mult_le_approx with (3 := H2); assumption. + intros k1 k2 body ep e p1. Simplify. subst. + rewrite <- scalar_norm_add_stable. simpl. + intro H; now apply mult_le_approx with (3 := H). Qed. (* \paragraph{[MERGE_EQ]} *) -Definition merge_eq (t : nat) (prop1 prop2 : proposition) := +Definition merge_eq (prop1 prop2 : proposition) := match prop1 with | LeqTerm (Tint Null) b1 => match prop2 with | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + eq_term b1 (scalar_norm b2 (-(1))) then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm @@ -2228,17 +2193,16 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := | _ => TrueTerm end. -Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). +Theorem merge_eq_valid : valid2 merge_eq. Proof. - unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl; - auto; elim (scalar_norm_stable n e); simpl; + unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. + rewrite <- scalar_norm_stable. simpl. intros; symmetry ; apply OMEGA8 with (2 := H0). - assumption. - elim opp_eq_mult_neg_1; trivial. Qed. - (* \paragraph{[O_CONSTANT_NUL]} *) Definition constant_nul (i : nat) (h : hyps) := @@ -2281,33 +2245,30 @@ Qed. \paragraph{[O_SPLIT_INEQ]} La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) -Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) - (l : hyps) := +Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with | NeqTerm (Tint Null) b1 => if beq Null 0 then - f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ - f2 - (LeqTerm (Tint 0) - (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l) - else l :: nil + f1 (LeqTerm (Tint 0) (add_norm b1 (-(1))) :: l) ++ + f2 (LeqTerm (Tint 0) (scalar_norm_add b1 (-(1)) (-(1))) :: l) + else l :: nil | _ => l :: nil end. Theorem split_ineq_valid : - forall (i t : nat) (f1 f2 : hyps -> lhyps), + forall (i : nat) (f1 f2 : hyps -> lhyps), valid_list_hyps f1 -> - valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). + valid_list_hyps f2 -> valid_list_hyps (split_ineq i f1 f2). Proof. - unfold valid_list_hyps, split_ineq; intros i t f1 f2 H1 H2 ep e lp H; + unfold valid_list_hyps, split_ineq; intros i f1 f2 H1 H2 ep e lp H; generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); simpl; auto; intros t1 t2; case t1; simpl; auto; intros z; simpl; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)). - - intro H4; left; apply H1; simpl; elim (add_norm_stable t); + - intro H4; left; apply H1; simpl; rewrite <- add_norm_stable; simpl; auto. - - intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); + - intro H4; right; apply H2; simpl; rewrite <- scalar_norm_add_stable; simpl; auto. - generalize H3; unfold not; intros E1 E2; apply E1; symmetry ; trivial. @@ -2320,23 +2281,23 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) | O_CONSTANT_NEG n => singleton (constant_neg n l) - | O_DIV_APPROX k1 k2 body t cont n => - execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l) - | O_NOT_EXACT_DIVIDE k1 k2 body t i => - singleton (not_exact_divide k1 k2 body t i l) - | O_EXACT_DIVIDE k body t cont n => - execute_omega cont (apply_oper_1 n (exact_divide k body t) l) + | O_DIV_APPROX k1 k2 body cont n => + execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body) l) + | O_NOT_EXACT_DIVIDE k1 k2 body i => + singleton (not_exact_divide k1 k2 body i l) + | O_EXACT_DIVIDE k body cont n => + execute_omega cont (apply_oper_1 n (exact_divide k body) l) | O_SUM k1 i1 k2 i2 t cont => execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) - | O_CONTRADICTION t i j => singleton (contradiction t i j l) - | O_MERGE_EQ t i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l) - | O_SPLIT_INEQ t i cont1 cont2 => - split_ineq i t (execute_omega cont1) (execute_omega cont2) l + | O_CONTRADICTION i j => singleton (contradiction i j l) + | O_MERGE_EQ i1 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 merge_eq l) + | O_SPLIT_INEQ i cont1 cont2 => + split_ineq i (execute_omega cont1) (execute_omega cont2) l | O_CONSTANT_NUL i => singleton (constant_nul i l) | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) - | O_NEGATE_CONTRADICT_INV t i j => - singleton (negate_contradict_inv t i j l) + | O_NEGATE_CONTRADICT_INV i j => + singleton (negate_contradict_inv i j l) | O_STATE m s i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (state m s) l) end. @@ -2349,40 +2310,40 @@ Proof. - unfold valid_list_hyps; simpl; intros; left; apply (constant_neg_valid n ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; + intros k1 k2 body t' Ht' m ep e lp H; apply Ht'; apply - (apply_oper_1_valid m (divide_and_approx k1 k2 body n) - (divide_and_approx_valid k1 k2 body n) ep e lp H). + (apply_oper_1_valid m (divide_and_approx k1 k2 body) + (divide_and_approx_valid k1 k2 body) ep e lp H). - unfold valid_list_hyps; simpl; intros; left; - apply (not_exact_divide_valid _ _ _ _ _ ep e lp H). + apply (not_exact_divide_valid _ _ _ _ ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros k body n t' Ht' m ep e lp H; apply Ht'; + intros k body t' Ht' m ep e lp H; apply Ht'; apply - (apply_oper_1_valid m (exact_divide k body n) - (exact_divide_valid k body n) ep e lp H). + (apply_oper_1_valid m (exact_divide k body) + (exact_divide_valid k body) ep e lp H). - unfold valid_list_hyps, valid_hyps; intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e lp H). - - unfold valid_list_hyps; simpl; intros; left; - apply (contradiction_valid n n0 n1 ep e lp H). + - unfold valid_list_hyps; simpl; intros; left. + apply (contradiction_valid n n0 ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; + intros i1 i2 t' Ht' ep e lp H; apply Ht'; apply - (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e + (apply_oper_2_valid i1 i2 merge_eq merge_eq_valid ep e lp H). - - intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; + - intros i k1 H1 k2 H2; unfold valid_list_hyps; simpl; intros ep e lp H; apply - (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e + (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e lp H). - unfold valid_list_hyps; simpl; intros i ep e lp H; left; apply (constant_nul_valid i ep e lp H). - unfold valid_list_hyps; simpl; intros i j ep e lp H; left; apply (negate_contradict_valid i j ep e lp H). - - unfold valid_list_hyps; simpl; intros n i j ep e lp H; - left; apply (negate_contradict_inv_valid n i j ep e lp H). + - unfold valid_list_hyps; simpl; intros i j ep e lp H; + left; apply (negate_contradict_inv_valid i j ep e lp H). - unfold valid_list_hyps, valid_hyps; intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H). diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 866f91b85..85f076760 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1050,15 +1050,13 @@ let replay_history env env_hyp = let rec loop env_hyp t = match t with | CONTRADICTION (e1,e2) :: l -> - let trace = mk_nat (List.length e1.body) in - mkApp (Lazy.force coq_s_contradiction, - [| trace ; mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) + mkApp (Lazy.force coq_s_contradiction, + [| mk_nat (get_hyp env_hyp e1.id); + mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> mkApp (Lazy.force coq_s_div_approx, [| Z.mk k; Z.mk d; reified_of_omega env e2.body e2.constant; - mk_nat (List.length e2.body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) | NOT_EXACT_DIVIDE (e1,k) :: l -> let e2_constant = floor_div e1.constant k in @@ -1067,7 +1065,6 @@ let replay_history env env_hyp = mkApp (Lazy.force coq_s_not_exact_divide, [|Z.mk k; Z.mk d; reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); mk_nat (get_hyp env_hyp e1.id)|]) | EXACT_DIVIDE (e1,k) :: l -> let e2_body = @@ -1076,13 +1073,11 @@ let replay_history env env_hyp = mkApp (Lazy.force coq_s_exact_divide, [|Z.mk k; reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) | (MERGE_EQ(e3,e1,e2)) :: l -> let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in mkApp (Lazy.force coq_s_merge_eq, - [| mk_nat (List.length e1.body); - mk_nat n1; mk_nat n2; + [| mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) | SUM(e3,(k1,e1),(k2,e2)) :: l -> let n1 = get_hyp env_hyp e1.id @@ -1121,15 +1116,14 @@ let replay_history env env_hyp = mk_nat (get_hyp env_hyp e2.id) |]) | NEGATE_CONTRADICT(e1,e2,false) :: l -> mkApp (Lazy.force coq_s_negate_contradict_inv, - [| mk_nat (List.length e2.body); - mk_nat (get_hyp env_hyp e1.id); + [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> let i = get_hyp env_hyp e.id in let r1 = loop (CCEqua e1 :: env_hyp) l1 in let r2 = loop (CCEqua e2 :: env_hyp) l2 in mkApp (Lazy.force coq_s_split_ineq, - [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) + [| mk_nat i; r1 ; r2 |]) | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> loop env_hyp l | (WEAKEN _ ) :: l -> failwith "not_treated" -- cgit v1.2.3 From e6eacd35e2822712b35723b372b167ab894d8472 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Thu, 11 May 2017 16:37:58 +0200 Subject: romega: use N instead of nat for Tvar In a coming commit, we'll normalize terms by a Coq function that will compare Tvar's instead of blindly applying a trace, so let's speed-up these comparisons. --- plugins/romega/ReflOmegaCore.v | 15 +++++++++++---- plugins/romega/const_omega.ml | 41 +++++++++++++++++++++++++---------------- plugins/romega/const_omega.mli | 2 ++ plugins/romega/refl_omega.ml | 2 +- 4 files changed, 39 insertions(+), 21 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index b0c9cd6e5..dad9909d2 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -796,7 +796,7 @@ Inductive term : Set := | Tmult : term -> term -> term | Tminus : term -> term -> term | Topp : term -> term - | Tvar : nat -> term. + | Tvar : N -> term. Delimit Scope romega_scope with term. Arguments Tint _%I. @@ -980,7 +980,7 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 | (- st1), (- st2) => eq_term st1 st2 - | [st1], [st2] => beq_nat st1 st2 + | [st1], [st2] => N.eqb st1 st2 | _, _ => false end. @@ -990,7 +990,7 @@ Theorem eq_term_iff (t t' : term) : eq_term t t' = true <-> t = t'. Proof. revert t'. induction t; destruct t'; simpl in *; - rewrite ?andb_true_iff, ?beq_iff, ?Nat.eqb_eq, ?IHt, ?IHt1, ?IHt2; + rewrite ?andb_true_iff, ?beq_iff, ?N.eqb_eq, ?IHt, ?IHt1, ?IHt2; intuition congruence. Qed. @@ -1002,6 +1002,13 @@ Qed. (* \subsection{Interprétations} \subsubsection{Interprétation des termes dans Z} *) +Fixpoint Nnth {A} (n:N)(l:list A)(default:A) := + match n, l with + | _, nil => default + | 0%N, x::_ => x + | _, _::l => Nnth (N.pred n) l default + end. + Fixpoint interp_term (env : list int) (t : term) {struct t} : int := match t with | Tint x => x @@ -1009,7 +1016,7 @@ Fixpoint interp_term (env : list int) (t : term) {struct t} : int := | (t1 * t2)%term => interp_term env t1 * interp_term env t2 | (t1 - t2)%term => interp_term env t1 - interp_term env t2 | (- t)%term => - interp_term env t - | [n]%term => nth n env 0 + | [n]%term => Nnth n env 0 end. (* \subsubsection{Interprétation des prédicats} *) diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index cf5d20aeb..f7eab17df 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -274,6 +274,30 @@ let parse_logic_rel c = | _ -> Rother with e when Logic.catchable_exception e -> Rother +(* Binary numbers *) + +let coq_xH = lazy (bin_constant "xH") +let coq_xO = lazy (bin_constant "xO") +let coq_xI = lazy (bin_constant "xI") +let coq_Z0 = lazy (bin_constant "Z0") +let coq_Zpos = lazy (bin_constant "Zpos") +let coq_Zneg = lazy (bin_constant "Zneg") +let coq_N0 = lazy (bin_constant "N0") +let coq_Npos = lazy (bin_constant "Npos") + +let rec mk_positive n = + if Bigint.equal n Bigint.one then Lazy.force coq_xH + else + let (q,r) = Bigint.euclid n Bigint.two in + Term.mkApp + ((if Bigint.equal r Bigint.zero + then Lazy.force coq_xO else Lazy.force coq_xI), + [| mk_positive q |]) + +let mk_N = function + | 0 -> Lazy.force coq_N0 + | n -> Term.mkApp (Lazy.force coq_Npos, + [| mk_positive (Bigint.of_int n) |]) module type Int = sig val typ : Term.constr Lazy.t @@ -297,13 +321,6 @@ let mult = lazy (z_constant "Z.mul") let opp = lazy (z_constant "Z.opp") let minus = lazy (z_constant "Z.sub") -let coq_xH = lazy (bin_constant "xH") -let coq_xO = lazy (bin_constant "xO") -let coq_xI = lazy (bin_constant "xI") -let coq_Z0 = lazy (bin_constant "Z0") -let coq_Zpos = lazy (bin_constant "Zpos") -let coq_Zneg = lazy (bin_constant "Zneg") - let recognize t = let rec loop t = let f,l = dest_const_apply t in @@ -319,16 +336,8 @@ let recognize t = | "Z0",[] -> Bigint.zero | _ -> failwith "not a number";; -let rec mk_positive n = - if n=Bigint.one then Lazy.force coq_xH - else - let (q,r) = Bigint.euclid n Bigint.two in - Term.mkApp - ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| mk_positive q |]) - let mk_Z n = - if n = Bigint.zero then Lazy.force coq_Z0 + if Bigint.equal n Bigint.zero then Lazy.force coq_Z0 else if Bigint.is_strictly_pos n then Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) else diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 1c67af806..2901cc028 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -116,6 +116,8 @@ val do_seq : Term.constr -> Term.constr -> Term.constr val do_list : Term.constr list -> Term.constr val mk_nat : int -> Term.constr +val mk_N : int -> Term.constr + (** Precondition: the type of the list is in Set *) val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 85f076760..a0ed68a8a 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -371,7 +371,7 @@ let rec reified_of_formula env = function app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] | Oint v -> app coq_t_int [| Z.mk v |] | Oufo t -> reified_of_formula env t - | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] + | Oatom i -> app coq_t_var [| mk_N (reified_of_atom env i) |] | Ominus(t1,t2) -> app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] -- cgit v1.2.3 From fdfdbcda1983c229779a09d77ead5033202bfbc7 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 15 May 2017 12:17:14 +0200 Subject: romega/const_omega : a few improvements (less try with, no gen equality) --- plugins/romega/const_omega.ml | 145 +++++++++++++++++++++--------------------- 1 file changed, 74 insertions(+), 71 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index f7eab17df..d7faaac96 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -10,10 +10,10 @@ let module_refl_name = "ReflOmegaCore" let module_refl_path = ["Coq"; "romega"; module_refl_name] type result = - Kvar of string - | Kapp of string * Term.constr list - | Kimp of Term.constr * Term.constr - | Kufo;; + | Kvar of string + | Kapp of string * Term.constr list + | Kimp of Term.constr * Term.constr + | Kufo let meaningful_submodule = [ "Z"; "N"; "Pos" ] @@ -30,19 +30,17 @@ let string_of_global r = let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with - | Term.Const (sp,_), args -> - Kapp (string_of_global (Globnames.ConstRef sp), args) - | Term.Construct (csp,_) , args -> - Kapp (string_of_global (Globnames.ConstructRef csp), args) - | Term.Ind (isp,_), args -> - Kapp (string_of_global (Globnames.IndRef isp), args) - | Term.Var id,[] -> Kvar(Names.Id.to_string id) - | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) - | Term.Prod (Names.Name _,_,_),[] -> - CErrors.error "Omega: Not a quantifier-free goal" - | _ -> Kufo - -exception Destruct + | Term.Const (sp,_), args -> + Kapp (string_of_global (Globnames.ConstRef sp), args) + | Term.Construct (csp,_) , args -> + Kapp (string_of_global (Globnames.ConstructRef csp), args) + | Term.Ind (isp,_), args -> + Kapp (string_of_global (Globnames.IndRef isp), args) + | Term.Var id, [] -> Kvar(Names.Id.to_string id) + | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) + | _ -> Kufo + +exception DestConstApp let dest_const_apply t = let f,args = Term.decompose_app t in @@ -51,8 +49,8 @@ let dest_const_apply t = | Term.Const (sp,_) -> Globnames.ConstRef sp | Term.Construct (csp,_) -> Globnames.ConstructRef csp | Term.Ind (isp,_) -> Globnames.IndRef isp - | _ -> raise Destruct - in Nametab.basename_of_global ref, args + | _ -> raise DestConstApp + in Nametab.basename_of_global ref, args let logic_dir = ["Coq";"Logic";"Decidable"] @@ -262,17 +260,15 @@ type parse_rel = | Riff of Term.constr * Term.constr | Rother -let parse_logic_rel c = - try match destructurate c with - | Kapp("True",[]) -> Rtrue - | Kapp("False",[]) -> Rfalse - | Kapp("not",[t]) -> Rnot t - | Kapp("or",[t1;t2]) -> Ror (t1,t2) - | Kapp("and",[t1;t2]) -> Rand (t1,t2) - | Kimp(t1,t2) -> Rimp (t1,t2) - | Kapp("iff",[t1;t2]) -> Riff (t1,t2) - | _ -> Rother - with e when Logic.catchable_exception e -> Rother +let parse_logic_rel c = match destructurate c with + | Kapp("True",[]) -> Rtrue + | Kapp("False",[]) -> Rfalse + | Kapp("not",[t]) -> Rnot t + | Kapp("or",[t1;t2]) -> Ror (t1,t2) + | Kapp("and",[t1;t2]) -> Rand (t1,t2) + | Kimp(t1,t2) -> Rimp (t1,t2) + | Kapp("iff",[t1;t2]) -> Riff (t1,t2) + | _ -> Rother (* Binary numbers *) @@ -321,20 +317,26 @@ let mult = lazy (z_constant "Z.mul") let opp = lazy (z_constant "Z.opp") let minus = lazy (z_constant "Z.sub") -let recognize t = +let recognize_pos t = let rec loop t = let f,l = dest_const_apply t in match Names.Id.to_string f,l with - "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) - | "xO",[t] -> Bigint.mult Bigint.two (loop t) - | "xH",[] -> Bigint.one - | _ -> failwith "not a number" in - let f,l = dest_const_apply t in + | "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t)) + | "xO",[t] -> Bigint.mult Bigint.two (loop t) + | "xH",[] -> Bigint.one + | _ -> raise DestConstApp + in + try Some (loop t) with DestConstApp -> None + +let recognize_Z t = + try + let f,l = dest_const_apply t in match Names.Id.to_string f,l with - "Zpos",[t] -> loop t - | "Zneg",[t] -> Bigint.neg (loop t) - | "Z0",[] -> Bigint.zero - | _ -> failwith "not a number";; + | "Zpos",[t] -> recognize_pos t + | "Zneg",[t] -> Option.map Bigint.neg (recognize_pos t) + | "Z0",[] -> Some Bigint.zero + | _ -> None + with DestConstApp -> None let mk_Z n = if Bigint.equal n Bigint.zero then Lazy.force coq_Z0 @@ -346,38 +348,39 @@ let mk_Z n = let mk = mk_Z let parse_term t = - try match destructurate t with - | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) - | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) - | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) - | Kapp("Z.opp",[t]) -> Topp t - | Kapp("Z.succ",[t]) -> Tsucc t - | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with e when CErrors.noncritical e -> Tother) - | _ -> Tother - with e when Logic.catchable_exception e -> Tother - -let pf_nf gl c = Tacmach.New.pf_apply Tacred.simpl gl c + match destructurate t with + | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) + | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) + | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) + | Kapp("Z.opp",[t]) -> Topp t + | Kapp("Z.succ",[t]) -> Tsucc t + | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> + (match recognize_Z t with Some t -> Tnum t | None -> Tother) + | _ -> Tother + +let pf_nf gl c = + EConstr.Unsafe.to_constr + (Tacmach.New.pf_apply Tacred.simpl gl (EConstr.of_constr c)) let parse_rel gl t = - try match destructurate t with - | Kapp("eq",[typ;t1;t2]) - when destructurate (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) = Kapp("Z",[]) -> Req (t1,t2) - | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) - | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) - | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) - | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) - | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) - | _ -> parse_logic_rel t - with e when Logic.catchable_exception e -> Rother - -let is_scalar t = - let rec aux t = match destructurate t with - | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 && aux t2 - | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true - | _ -> false in - try aux t with e when CErrors.noncritical e -> false + match destructurate t with + | Kapp("eq",[typ;t1;t2]) -> + (match destructurate (pf_nf gl typ) with + | Kapp("Z",[]) -> Req (t1,t2) + | _ -> Rother) + | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) + | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) + | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) + | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) + | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) + | _ -> parse_logic_rel t + +let rec is_scalar t = + match destructurate t with + | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> is_scalar t1 && is_scalar t2 + | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> is_scalar t + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> Option.has_some (recognize_Z t) + | _ -> false end -- cgit v1.2.3 From f1e08dd28903513b71909326d60dc77366dca0fa Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 16 May 2017 02:46:17 +0200 Subject: romega: no more normalization trace, replaced by some Coq-side computation This is a major change : - Generated proofs are quite shorter, since only the resolution trace remains. - No time penalty mesured (it even tends to be slightly faster this way). - Less infrastructure in ReflOmegaCore and refl_omega. - Warning: the normalization functions in ML and in Coq should be kept in sync, as well as the variable order. - Btw: get rid of ML constructor Oufo --- plugins/romega/ReflOmegaCore.v | 1110 ++++++++++------------------------------ plugins/romega/const_omega.ml | 90 +--- plugins/romega/const_omega.mli | 51 +- plugins/romega/refl_omega.ml | 556 +++++++------------- 4 files changed, 461 insertions(+), 1346 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index dad9909d2..8fa6905ba 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -16,6 +16,8 @@ Module Type Int. Parameter t : Set. + Bind Scope Int_scope with t. + Parameter zero : t. Parameter one : t. Parameter plus : t -> t -> t. @@ -177,7 +179,7 @@ Module IntProperties (I:Int). Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. Proof. intros. - rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). + rewrite <- (plus_0_r y), <- (plus_0_r z), <-(opp_def x). now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. @@ -193,16 +195,23 @@ Module IntProperties (I:Int). apply mult_plus_distr_r. Qed. - Lemma mult_0_l : forall x, 0*x = 0. + Lemma mult_0_l x : 0*x = 0. Proof. - intros. - generalize (mult_plus_distr_r 0 1 x). - rewrite plus_0_l, mult_1_l, plus_comm; intros. + assert (H := mult_plus_distr_r 0 1 x). + rewrite plus_0_l, mult_1_l, plus_comm in H. apply plus_reg_l with x. - rewrite <- H. - apply plus_0_r_reverse. + now rewrite <- H, plus_0_r. + Qed. + + Lemma mult_0_r x : x*0 = 0. + Proof. + rewrite mult_comm. apply mult_0_l. Qed. + Lemma mult_1_r x : x*1 = x. + Proof. + rewrite mult_comm. apply mult_1_l. + Qed. (* More facts about opp *) @@ -252,6 +261,13 @@ Module IntProperties (I:Int). Lemma egal_left : forall n m, n=m -> n+-m = 0. Proof. intros; subst; apply opp_def. Qed. + Lemma egal_left_iff n m : n = m <-> 0 = n + - m. + Proof. + split. intros. symmetry. now apply egal_left. + intros. apply plus_reg_l with (-m). + rewrite plus_comm, <- H. symmetry. apply plus_opp_l. + Qed. + Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). Proof. intros; contradict H. @@ -262,7 +278,7 @@ Module IntProperties (I:Int). (* Special lemmas for factorisation. *) Lemma red_factor0 : forall n, n = n*1. - Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. + Proof. symmetry; apply mult_1_r. Qed. Lemma red_factor1 : forall n, n+n = n*2. Proof. @@ -273,7 +289,7 @@ Module IntProperties (I:Int). Lemma red_factor2 : forall n m, n + n*m = n * (1+m). Proof. intros; rewrite mult_plus_distr_l. - f_equal; now rewrite mult_comm, mult_1_l. + now rewrite mult_1_r. Qed. Lemma red_factor3 : forall n m, n*m + n = n*(1+m). @@ -450,6 +466,11 @@ Module IntProperties (I:Int). generalize (lt_trans _ _ _ H C); intuition. Qed. + Lemma not_eq (a b:int) : ~ a <> b <-> a = b. + Proof. + destruct (eq_dec a b); intuition. + Qed. + (* order and operations *) Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. @@ -600,13 +621,15 @@ Module IntProperties (I:Int). apply lt_0_1. Qed. - Lemma le_left : forall n m, n <= m -> 0 <= m + - n. + Lemma le_left n m : n <= m <-> 0 <= m + - n. Proof. - intros. - rewrite <- (opp_def m). - apply plus_le_compat. - apply le_refl. - apply opp_le_compat; auto. + split; intros. + - rewrite <- (opp_def m). + apply plus_le_compat. + apply le_refl. + apply opp_le_compat; auto. + - apply plus_le_reg_r with (-n). + now rewrite plus_opp_r. Qed. Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. @@ -662,7 +685,7 @@ Module IntProperties (I:Int). Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. Proof. - intros; apply le_left. + intros. rewrite <- le_left. now rewrite <- le_lt_int. Qed. @@ -735,7 +758,7 @@ Module IntProperties (I:Int). rewrite le_lt_int. apply le_trans with (n+-(1)); [ now apply le_lt_int | ]. apply plus_le_compat; [ | apply le_refl ]. - rewrite <- (mult_1_l n) at 1. rewrite mult_comm. + rewrite <- (mult_1_r n) at 1. apply mult_le_compat_l; auto using lt_le_weak. Qed. @@ -798,6 +821,7 @@ Inductive term : Set := | Topp : term -> term | Tvar : N -> term. +Bind Scope romega_scope with term. Delimit Scope romega_scope with term. Arguments Tint _%I. Arguments Tplus (_ _)%term. @@ -845,58 +869,6 @@ Notation singleton := (fun a : hyps => a :: nil). (* an absurd goal *) Definition absurd := FalseTerm :: nil. -(* \subsubsection{Traces for merging equations} - This inductive type describes how the monomial of two equations should be - merged when the equations are added. - - For [F_equal], both equations have the same head variable and coefficient - must be added, furthermore if coefficients are opposite, [F_cancel] should - be used to collapse the term. [F_left] and [F_right] indicate which monomial - should be put first in the result *) - -Inductive t_fusion : Set := - | F_equal : t_fusion - | F_cancel : t_fusion - | F_left : t_fusion - | F_right : t_fusion. - -(* \subsubsection{Rewriting steps to normalize terms} *) -Inductive step : Set := - (* apply the rewriting steps to both subterms of an operation *) - | C_DO_BOTH : step -> step -> step - (* apply the rewriting step to the first branch *) - | C_LEFT : step -> step - (* apply the rewriting step to the second branch *) - | C_RIGHT : step -> step - (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step - (* empty step *) - | C_NOP : step - (* the following operations correspond to actual rewriting *) - | C_OPP_PLUS : step - | C_OPP_OPP : step - | C_OPP_MULT_R : step - | C_OPP_ONE : step - (* This is a special step that reduces the term (computation) *) - | C_REDUCE : step - | C_MULT_PLUS_DISTR : step - | C_MULT_OPP_LEFT : step - | C_MULT_ASSOC_R : step - | C_PLUS_ASSOC_R : step - | C_PLUS_ASSOC_L : step - | C_PLUS_PERMUTE : step - | C_PLUS_COMM : step - | C_RED0 : step - | C_RED1 : step - | C_RED2 : step - | C_RED3 : step - | C_RED4 : step - | C_RED5 : step - | C_RED6 : step - | C_MULT_ASSOC_REDUCED : step - | C_MINUS : step - | C_MULT_COMM : step. - (* \subsubsection{Omega steps} *) (* The following inductive type describes steps as they can be found in the trace coming from the decision procedure Omega. *) @@ -906,40 +878,19 @@ Inductive t_omega : Set := | O_CONSTANT_NOT_NUL : nat -> t_omega | O_CONSTANT_NEG : nat -> t_omega (* division and approximation of an equation *) - | O_DIV_APPROX : int -> int -> term -> t_omega -> nat -> t_omega + | O_DIV_APPROX : nat -> int -> int -> term -> t_omega -> t_omega (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> t_omega + | O_NOT_EXACT_DIVIDE : nat -> int -> int -> term -> t_omega (* exact division *) - | O_EXACT_DIVIDE : int -> term -> t_omega -> nat -> t_omega - | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega + | O_EXACT_DIVIDE : nat -> int -> term -> t_omega -> t_omega + | O_SUM : int -> nat -> int -> nat -> t_omega -> t_omega | O_CONTRADICTION : nat -> nat -> t_omega | O_MERGE_EQ : nat -> nat -> t_omega -> t_omega | O_SPLIT_INEQ : nat -> t_omega -> t_omega -> t_omega | O_CONSTANT_NUL : nat -> t_omega | O_NEGATE_CONTRADICT : nat -> nat -> t_omega | O_NEGATE_CONTRADICT_INV : nat -> nat -> t_omega - | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. - -(* \subsubsection{Rules for normalizing the hypothesis} *) -(* These rules indicate how to normalize useful propositions - of each useful hypothesis before the decomposition of hypothesis. - Negation nodes could be traversed by either [P_LEFT] or [P_RIGHT]. - The rules include the inversion phase for negation removal. *) - -Inductive p_step : Set := - | P_LEFT : p_step -> p_step - | P_RIGHT : p_step -> p_step - | P_INVERT : step -> p_step - | P_STEP : step -> p_step. - -(* List of normalizations to perform : if the type [p_step] had a constructor - that indicated visiting both left and right branches, we would be able to - restrict ourselves to the case of only one normalization by hypothesis. - And since all hypothesis are useful (otherwise they wouldn't be included), - we would be able to replace [h_step] by a simple list. *) - -Inductive h_step : Set := - pair_step : nat -> p_step -> h_step. + | O_STATE : int -> nat -> nat -> t_omega -> t_omega. (* \subsubsection{Rules for decomposing the hypothesis} *) (* This type allows navigation in the logical constructors that @@ -971,8 +922,6 @@ Inductive e_step : Set := (* \subsubsection{Reified terms} *) -Open Scope romega_scope. - Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := match t1, t2 with | Tint st1, Tint st2 => beq st1 st2 @@ -982,9 +931,7 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := | (- st1), (- st2) => eq_term st1 st2 | [st1], [st2] => N.eqb st1 st2 | _, _ => false - end. - -Close Scope romega_scope. + end%term. Theorem eq_term_iff (t t' : term) : eq_term t t' = true <-> t = t'. @@ -1258,93 +1205,6 @@ Proof. * apply Hrec; assumption. Qed. -(* \subsubsection{Manipulations de termes} *) -(* Les fonctions suivantes permettent d'appliquer une fonction de - réécriture sur un sous terme du terme principal. Avec la composition, - cela permet de construire des réécritures complexes proches des - tactiques de conversion *) - -Definition apply_left (f : term -> term) (t : term) := - match t with - | (x + y)%term => (f x + y)%term - | (x * y)%term => (f x * y)%term - | (- x)%term => (- f x)%term - | x => x - end. - -Definition apply_right (f : term -> term) (t : term) := - match t with - | (x + y)%term => (x + f y)%term - | (x * y)%term => (x * f y)%term - | x => x - end. - -Definition apply_both (f g : term -> term) (t : term) := - match t with - | (x + y)%term => (f x + g y)%term - | (x * y)%term => (f x * g y)%term - | x => x - end. - -(* Les théorèmes suivants montrent la stabilité (conditionnée) des - fonctions. *) - -Theorem apply_left_stable : - forall f : term -> term, term_stable f -> term_stable (apply_left f). -Proof. - unfold term_stable; intros f H e t; case t; auto; simpl; - intros; elim H; trivial. -Qed. - -Theorem apply_right_stable : - forall f : term -> term, term_stable f -> term_stable (apply_right f). -Proof. - unfold term_stable; intros f H e t; case t; auto; simpl; - intros t0 t1; elim H; trivial. -Qed. - -Theorem apply_both_stable : - forall f g : term -> term, - term_stable f -> term_stable g -> term_stable (apply_both f g). -Proof. - unfold term_stable; intros f g H1 H2 e t; case t; auto; simpl; - intros t0 t1; elim H1; elim H2; trivial. -Qed. - -Theorem compose_term_stable : - forall f g : term -> term, - term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). -Proof. - unfold term_stable; intros f g Hf Hg e t; elim Hf; apply Hg. -Qed. - -(* \subsection{Les règles de réécriture} *) -(* Chacune des règles de réécriture est accompagnée par sa preuve de - stabilité. Toutes ces preuves ont la même forme : il faut analyser - suivant la forme du terme (élimination de chaque Case). On a besoin d'une - élimination uniquement dans les cas d'utilisation d'égalité décidable. - - Cette tactique itère la décomposition des Case. Elle est - constituée de deux fonctions s'appelant mutuellement : - \begin{itemize} - \item une fonction d'enrobage qui lance la recherche sur le but, - \item une fonction récursive qui décompose ce but. Quand elle a trouvé un - Case, elle l'élimine. - \end{itemize} - Les motifs sur les cas sont très imparfaits et dans certains cas, il - semble que cela ne marche pas. On aimerait plutot un motif de la - forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on - utilise le bon type. - - Chaque élimination introduit correctement exactement le nombre d'hypothèses - nécessaires et conserve dans le cas d'une égalité la connaissance du - résultat du test en faisant la réécriture. Pour un test de comparaison, - on conserve simplement le résultat. - - Cette fonction déborde très largement la résolution des réécritures - simples et fait une bonne partie des preuves des pas de Omega. -*) - (* \subsubsection{La tactique pour prouver la stabilité} *) Ltac loop t := @@ -1379,6 +1239,8 @@ Ltac loop t := try (rewrite H in *; clear H); simpl; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify + | match N.compare ?X1 ?X2 with _ => _ end => + destruct (N.compare_spec X1 X2); Simplify | match ?X1 with _ => _ end => destruct X1; auto; Simplify | _ => fail end @@ -1388,401 +1250,12 @@ with Simplify := match goal with | _ => idtac end. -Ltac prove_stable x th := - match constr:(x) with - | ?X1 => - unfold term_stable, X1; intros; Simplify; simpl; - apply th - end. - -(* \subsubsection{Les règles elle mêmes} *) -Definition Tplus_assoc_l (t : term) := - match t with - | (n + (m + p))%term => (n + m + p)%term - | _ => t - end. - -Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. -Proof. - prove_stable Tplus_assoc_l (ring.(Radd_assoc)). -Qed. - -Definition Tplus_assoc_r (t : term) := - match t with - | (n + m + p)%term => (n + (m + p))%term - | _ => t - end. - -Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. -Proof. - prove_stable Tplus_assoc_r plus_assoc_reverse. -Qed. - -Definition Tmult_assoc_r (t : term) := - match t with - | (n * m * p)%term => (n * (m * p))%term - | _ => t - end. - -Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. -Proof. - prove_stable Tmult_assoc_r mult_assoc_reverse. -Qed. - -Definition Tplus_permute (t : term) := - match t with - | (n + (m + p))%term => (m + (n + p))%term - | _ => t - end. - -Theorem Tplus_permute_stable : term_stable Tplus_permute. -Proof. - prove_stable Tplus_permute plus_permute. -Qed. - -Definition Tplus_comm (t : term) := - match t with - | (x + y)%term => (y + x)%term - | _ => t - end. - -Theorem Tplus_comm_stable : term_stable Tplus_comm. -Proof. - prove_stable Tplus_comm plus_comm. -Qed. - -Definition Tmult_comm (t : term) := - match t with - | (x * y)%term => (y * x)%term - | _ => t - end. - -Theorem Tmult_comm_stable : term_stable Tmult_comm. -Proof. - prove_stable Tmult_comm mult_comm. -Qed. - -Definition T_OMEGA10 (t : term) := - match t with - | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' - then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term - else t - | _ => t - end. - -Theorem T_OMEGA10_stable : term_stable T_OMEGA10. -Proof. - prove_stable T_OMEGA10 OMEGA10. -Qed. - -Definition T_OMEGA11 (t : term) := - match t with - | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term => - (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term - | _ => t - end. - -Theorem T_OMEGA11_stable : term_stable T_OMEGA11. -Proof. - prove_stable T_OMEGA11 OMEGA11. -Qed. - -Definition T_OMEGA12 (t : term) := - match t with - | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term => - (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term - | _ => t - end. - -Theorem T_OMEGA12_stable : term_stable T_OMEGA12. -Proof. - prove_stable T_OMEGA12 OMEGA12. -Qed. - -Definition Tred_factor5 (t : term) := - match t with - | (x * Tint c + y)%term => if beq c 0 then y else t - | _ => t - end. - -Theorem Tred_factor5_stable : term_stable Tred_factor5. -Proof. - prove_stable Tred_factor5 red_factor5. -Qed. - -Definition Topp_plus (t : term) := - match t with - | (- (x + y))%term => (- x + - y)%term - | _ => t - end. - -Theorem Topp_plus_stable : term_stable Topp_plus. -Proof. - prove_stable Topp_plus opp_plus_distr. -Qed. - - -Definition Topp_opp (t : term) := - match t with - | (- - x)%term => x - | _ => t - end. - -Theorem Topp_opp_stable : term_stable Topp_opp. -Proof. - prove_stable Topp_opp opp_involutive. -Qed. - -Definition Topp_mult_r (t : term) := - match t with - | (- (x * Tint k))%term => (x * Tint (- k))%term - | _ => t - end. - -Theorem Topp_mult_r_stable : term_stable Topp_mult_r. -Proof. - prove_stable Topp_mult_r opp_mult_distr_r. -Qed. - -Definition Topp_one (t : term) := - match t with - | (- x)%term => (x * Tint (-(1)))%term - | _ => t - end. - -Theorem Topp_one_stable : term_stable Topp_one. -Proof. - prove_stable Topp_one opp_eq_mult_neg_1. -Qed. - -Definition Tmult_plus_distr (t : term) := - match t with - | ((n + m) * p)%term => (n * p + m * p)%term - | _ => t - end. - -Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. -Proof. - prove_stable Tmult_plus_distr mult_plus_distr_r. -Qed. - -Definition Tmult_opp_left (t : term) := - match t with - | (- x * Tint y)%term => (x * Tint (- y))%term - | _ => t - end. - -Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. -Proof. - prove_stable Tmult_opp_left mult_opp_comm. -Qed. - -Definition Tmult_assoc_reduced (t : term) := - match t with - | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term - | _ => t - end. - -Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced. -Proof. - prove_stable Tmult_assoc_reduced mult_assoc_reverse. -Qed. - -Definition Tred_factor0 (t : term) := (t * Tint 1)%term. - -Theorem Tred_factor0_stable : term_stable Tred_factor0. -Proof. - prove_stable Tred_factor0 red_factor0. -Qed. - -Definition Tred_factor1 (t : term) := - match t with - | (x + y)%term => - if eq_term x y - then (x * Tint 2)%term - else t - | _ => t - end. - -Theorem Tred_factor1_stable : term_stable Tred_factor1. -Proof. - prove_stable Tred_factor1 red_factor1. -Qed. - -Definition Tred_factor2 (t : term) := - match t with - | (x + y * Tint k)%term => - if eq_term x y - then (x * Tint (1 + k))%term - else t - | _ => t - end. - -Theorem Tred_factor2_stable : term_stable Tred_factor2. -Proof. - prove_stable Tred_factor2 red_factor2. -Qed. - -Definition Tred_factor3 (t : term) := - match t with - | (x * Tint k + y)%term => - if eq_term x y - then (x * Tint (1 + k))%term - else t - | _ => t - end. - -Theorem Tred_factor3_stable : term_stable Tred_factor3. -Proof. - prove_stable Tred_factor3 red_factor3. -Qed. - - -Definition Tred_factor4 (t : term) := - match t with - | (x * Tint k1 + y * Tint k2)%term => - if eq_term x y - then (x * Tint (k1 + k2))%term - else t - | _ => t - end. - -Theorem Tred_factor4_stable : term_stable Tred_factor4. -Proof. - prove_stable Tred_factor4 red_factor4. -Qed. - -Definition Tred_factor6 (t : term) := (t + Tint 0)%term. - -Theorem Tred_factor6_stable : term_stable Tred_factor6. -Proof. - prove_stable Tred_factor6 red_factor6. -Qed. - -Definition Tminus_def (t : term) := - match t with - | (x - y)%term => (x + - y)%term - | _ => t - end. - -Theorem Tminus_def_stable : term_stable Tminus_def. -Proof. - prove_stable Tminus_def minus_def. -Qed. - -(* \subsection{Fonctions de réécriture complexes} *) - -(* \subsubsection{Fonction de réduction} *) -(* Cette fonction réduit un terme dont la forme normale est un entier. Il - suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs - réifiés. La réduction est ``gratuite''. *) - -Fixpoint reduce (t : term) : term := - match t with - | (x + y)%term => - match reduce x with - | Tint xi as xr => - match reduce y with - | Tint yi => Tint (xi + yi) - | yr => (xr + yr)%term - end - | xr => (xr + reduce y)%term - end - | (x * y)%term => - match reduce x with - | Tint xi as xr => - match reduce y with - | Tint yi => Tint (xi * yi) - | yr => (xr * yr)%term - end - | xr => (xr * reduce y)%term - end - | (x - y)%term => - match reduce x with - | Tint xi as xr => - match reduce y with - | Tint yi => Tint (xi - yi) - | yr => (xr - yr)%term - end - | xr => (xr - reduce y)%term - end - | (- x)%term => - match reduce x with - | Tint xi => Tint (- xi) - | xr => (- xr)%term - end - | _ => t - end. - -Theorem reduce_stable : term_stable reduce. -Proof. - red. intros e t; induction t; simpl; auto; - do 2 destruct reduce; simpl; f_equal; auto. -Qed. - -(* \subsubsection{Fusions} - \paragraph{Fusion de deux équations} *) -(* On donne une somme de deux équations qui sont supposées normalisées. - Cette fonction prend une trace de fusion en argument et transforme - le terme en une équation normalisée. C'est une version très simplifiée - du moteur de réécriture [rewrite]. *) - -Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := - match trace with - | nil => reduce t - | step :: trace' => - match step with - | F_equal => apply_right (fusion trace') (T_OMEGA10 t) - | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) - | F_left => apply_right (fusion trace') (T_OMEGA11 t) - | F_right => apply_right (fusion trace') (T_OMEGA12 t) - end - end. - -Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). -Proof. - simple induction trace; simpl. - - exact reduce_stable. - - intros stp l H; case stp. - + apply compose_term_stable. - * apply apply_right_stable; assumption. - * exact T_OMEGA10_stable. - + unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; - rewrite Tred_factor5_stable; apply H. - + apply compose_term_stable. - * apply apply_right_stable; assumption. - * exact T_OMEGA11_stable. - + apply compose_term_stable. - * apply apply_right_stable; assumption. - * exact T_OMEGA12_stable. -Qed. - -(* \paragraph{Fusion avec annihilation} *) -(* Normalement le résultat est une constante *) - -Fixpoint fusion_cancel (t1 t2 : term) : term := - match t1, t2 with - | (v1 * Tint x1 + l1)%term, (v2 * Tint x2 + l2)%term => - if eq_term v1 v2 && beq x1 (-x2) - then fusion_cancel l1 l2 - else (t1+t2)%term (* should not happen *) - | Tint x1, Tint x2 => Tint (x1+x2) - | _, _ => (t1+t2)%term (* should not happen *) - end. - -Theorem fusion_cancel_stable e t1 t2 : - interp_term e (t1+t2)%term = interp_term e (fusion_cancel t1 t2). -Proof. - revert t2. induction t1; destruct t2; simpl; Simplify; auto. - simpl in *. - rewrite <- IHt1_2. - apply OMEGA13. -Qed. - (* \subsubsection{Opérations affines sur une équation} *) + (* \paragraph{Multiplication scalaire et somme d'une constante} *) +(* invariant: k1<>0 *) + Fixpoint scalar_norm_add (t : term) (k1 k2 : int) : term := match t with | (v1 * Tint x1 + l1)%term => @@ -1800,6 +1273,7 @@ Proof. Qed. (* \paragraph{Multiplication scalaire} *) + Definition scalar_norm (t : term) (k : int) := scalar_norm_add t k 0. Theorem scalar_norm_stable e t k : @@ -1810,6 +1284,7 @@ Proof. Qed. (* \paragraph{Somme d'une constante} *) + Fixpoint add_norm (t : term) (k : int) : term := match t with | (m + l)%term => (m + add_norm l k)%term @@ -1824,70 +1299,101 @@ Proof. rewrite <- IHt2. simpl. symmetry. apply plus_assoc. Qed. -(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) +(* \subsubsection{Fusions} + \paragraph{Fusion de deux équations} *) +(* On donne une somme de deux équations qui sont supposées normalisées. + Cette fonction prend une trace de fusion en argument et transforme + le terme en une équation normalisée. *) +(* Invariant : k1 and k2 non-null *) + +Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := + match t1 with + | ([v1] * Tint x1 + l1)%term => + (fix fusion_t1 t2 : term := + match t2 with + | ([v2] * Tint x2 + l2)%term => + match N.compare v1 v2 with + | Eq => + let k := x1 * k1 + x2 * k2 in + if beq k 0 then fusion l1 l2 k1 k2 + else ([v1] * Tint k + fusion l1 l2 k1 k2)%term + | Lt => ([v2] * Tint (x2 * k2) + fusion_t1 l2)%term + | Gt => ([v1] * Tint (x1 * k1) + fusion l1 t2 k1 k2)%term + end + | Tint x2 => ([v1] * Tint (x1 * k1) + fusion l1 t2 k1 k2)%term + | _ => (t1 * Tint k1 + t2 * Tint k2)%term + end) t2 + | Tint x1 => scalar_norm_add t2 k2 (x1 * k1) + | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) + end. + +Theorem fusion_stable e t1 t2 k1 k2 : + interp_term e (t1 * Tint k1 + t2 * Tint k2)%term = + interp_term e (fusion t1 t2 k1 k2). +Proof. + revert t2; induction t1; simpl; Simplify; simpl; auto. + - intros; rewrite <- scalar_norm_add_stable. simpl. apply plus_comm. + - intros. Simplify. induction t2; simpl; Simplify; simpl; auto. + + rewrite <- IHt1_2. simpl. apply OMEGA11. + + rewrite <- IHt1_2. simpl. subst n0. rewrite OMEGA10, H0. + now rewrite mult_comm, mult_0_l, plus_0_l. + + rewrite <- IHt1_2. simpl. subst n0. apply OMEGA10. + + rewrite <- IHt2_2. simpl. apply OMEGA12. + + rewrite <- IHt1_2. simpl. apply OMEGA11. +Qed. + +(* Main function of term normalization. + Precondition: all [Tmult] should be on at least one [Tint]. + Postcondition: [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))] + with [v1>v2>...] and [ki<>0]. + *) + +Fixpoint normalize t := + match t with + | Tint n => Tint n + | [n]%term => ([n] * Tint 1 + Tint 0)%term + | (t + t')%term => fusion (normalize t) (normalize t') 1 1 + | (- t)%term => scalar_norm (normalize t) (-(1)) + | (t - t')%term => fusion (normalize t) (normalize t') 1 (-(1)) + | (Tint k * t)%term | (t * Tint k)%term => + if beq k 0 then Tint 0 + else scalar_norm (normalize t) k + | (t1 * t2)%term => (t1 * t2)%term (* shouldn't happen *) + end. + +Theorem normalize_stable : term_stable normalize. +Proof. + intros e t. + induction t; simpl; Simplify; simpl; + rewrite <- ?scalar_norm_stable; simpl in *; rewrite <- ?IHt1; + rewrite <- ?fusion_stable; simpl; + rewrite ?mult_0_l, ?mult_0_r, ?mult_1_l, ?mult_1_r, ?plus_0_r; auto. + - now f_equal. + - rewrite mult_comm. now f_equal. + - rewrite <- opp_eq_mult_neg_1, <-minus_def. now f_equal. + - rewrite <- opp_eq_mult_neg_1. now f_equal. +Qed. +(* \paragraph{Fusion avec annihilation} *) +(* Normalement le résultat est une constante *) -Fixpoint t_rewrite (s : step) : term -> term := - match s with - | C_DO_BOTH s1 s2 => apply_both (t_rewrite s1) (t_rewrite s2) - | C_LEFT s => apply_left (t_rewrite s) - | C_RIGHT s => apply_right (t_rewrite s) - | C_SEQ s1 s2 => fun t : term => t_rewrite s2 (t_rewrite s1 t) - | C_NOP => fun t : term => t - | C_OPP_PLUS => Topp_plus - | C_OPP_OPP => Topp_opp - | C_OPP_MULT_R => Topp_mult_r - | C_OPP_ONE => Topp_one - | C_REDUCE => reduce - | C_MULT_PLUS_DISTR => Tmult_plus_distr - | C_MULT_OPP_LEFT => Tmult_opp_left - | C_MULT_ASSOC_R => Tmult_assoc_r - | C_PLUS_ASSOC_R => Tplus_assoc_r - | C_PLUS_ASSOC_L => Tplus_assoc_l - | C_PLUS_PERMUTE => Tplus_permute - | C_PLUS_COMM => Tplus_comm - | C_RED0 => Tred_factor0 - | C_RED1 => Tred_factor1 - | C_RED2 => Tred_factor2 - | C_RED3 => Tred_factor3 - | C_RED4 => Tred_factor4 - | C_RED5 => Tred_factor5 - | C_RED6 => Tred_factor6 - | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced - | C_MINUS => Tminus_def - | C_MULT_COMM => Tmult_comm +Fixpoint fusion_cancel (t1 t2 : term) : term := + match t1, t2 with + | (v1 * Tint x1 + l1)%term, (v2 * Tint x2 + l2)%term => + if eq_term v1 v2 && beq x1 (-x2) + then fusion_cancel l1 l2 + else (t1+t2)%term (* should not happen *) + | Tint x1, Tint x2 => Tint (x1+x2) + | _, _ => (t1+t2)%term (* should not happen *) end. -Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s). +Theorem fusion_cancel_stable e t1 t2 : + interp_term e (t1+t2)%term = interp_term e (fusion_cancel t1 t2). Proof. - simple induction s; simpl. - - intros; apply apply_both_stable; auto. - - intros; apply apply_left_stable; auto. - - intros; apply apply_right_stable; auto. - - unfold term_stable; intros; elim H0; apply H. - - unfold term_stable; auto. - - exact Topp_plus_stable. - - exact Topp_opp_stable. - - exact Topp_mult_r_stable. - - exact Topp_one_stable. - - exact reduce_stable. - - exact Tmult_plus_distr_stable. - - exact Tmult_opp_left_stable. - - exact Tmult_assoc_r_stable. - - exact Tplus_assoc_r_stable. - - exact Tplus_assoc_l_stable. - - exact Tplus_permute_stable. - - exact Tplus_comm_stable. - - exact Tred_factor0_stable. - - exact Tred_factor1_stable. - - exact Tred_factor2_stable. - - exact Tred_factor3_stable. - - exact Tred_factor4_stable. - - exact Tred_factor5_stable. - - exact Tred_factor6_stable. - - exact Tmult_assoc_reduced_stable. - - exact Tminus_def_stable. - - exact Tmult_comm_stable. + revert t2. induction t1; destruct t2; simpl; Simplify; auto. + simpl in *. + rewrite <- IHt1_2. + apply OMEGA13. Qed. (* \subsection{tactiques de résolution d'un but omega normalisé} @@ -1926,8 +1432,8 @@ Proof. Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (k1 k2 : int) (body : term) - (i : nat) (l : hyps) := +Definition not_exact_divide (i : nat) (k1 k2 : int) (body : term) + (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => if beq Nul 0 && @@ -1940,8 +1446,8 @@ Definition not_exact_divide (k1 k2 : int) (body : term) end. Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (i : nat), - valid_hyps (not_exact_divide k1 k2 body i). + forall (i : nat)(k1 k2 : int) (body : term), + valid_hyps (not_exact_divide i k1 k2 body). Proof. unfold valid_hyps, not_exact_divide; intros. generalize (nth_valid ep e i lp); Simplify. @@ -2068,19 +1574,17 @@ Qed. preuve un peu compliquée. On utilise quelques lemmes qui sont des généralisations des théorèmes utilisés par OMEGA. *) -Definition sum (k1 k2 : int) (trace : list t_fusion) - (prop1 prop2 : proposition) := +Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 - then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + then EqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end @@ -2089,13 +1593,11 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) then match prop2 with | EqTerm (Tint Null') b2 => if beq Null' 0 then - LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | LeqTerm (Tint Null') b2 => if beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end @@ -2104,8 +1606,7 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) match prop2 with | EqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) - then NeqTerm (Tint 0) - (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) + then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end @@ -2114,11 +1615,11 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) Theorem sum_valid : - forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). + forall (k1 k2 : int), valid2 (sum k1 k2). Proof. unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; - Simplify; simpl; auto; try elim (fusion_stable t); - simpl; intros. + Simplify; simpl; rewrite <- ?fusion_stable; + simpl; intros; auto. - apply sum1; assumption. - apply sum2; try assumption; apply sum4; assumption. - rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption. @@ -2227,25 +1728,25 @@ Qed. (* \paragraph{[O_STATE]} *) -Definition state (m : int) (s : step) (prop1 prop2 : proposition) := +Definition state (m : int) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Null) b1 => match prop2 with - | EqTerm b2 b3 => - if beq Null 0 - then EqTerm (Tint 0) (t_rewrite s (b1 + (- b3 + b2) * Tint m)%term) + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 + then EqTerm (Tint 0) (fusion b1 b2 1 m) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. -Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). +Theorem state_valid : forall (m : int), valid2 (state m). Proof. - unfold valid2; intros m s ep e p1 p2; unfold state; Simplify; - simpl; auto; elim (t_rewrite_stable s e); simpl; - intros H1 H2; elim H1. - now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. + unfold valid2; intros m ep e p1 p2. + unfold state; Simplify; simpl; auto. + rewrite <- fusion_stable. simpl in *. intros H H'. + rewrite <- H, <- H'. now rewrite !mult_0_l, plus_0_l. Qed. (* \subsubsection{Tactiques générant plusieurs but} @@ -2288,14 +1789,14 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) | O_CONSTANT_NEG n => singleton (constant_neg n l) - | O_DIV_APPROX k1 k2 body cont n => + | O_DIV_APPROX n k1 k2 body cont => execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body) l) - | O_NOT_EXACT_DIVIDE k1 k2 body i => - singleton (not_exact_divide k1 k2 body i l) - | O_EXACT_DIVIDE k body cont n => + | O_NOT_EXACT_DIVIDE i k1 k2 body => + singleton (not_exact_divide i k1 k2 body l) + | O_EXACT_DIVIDE n k body cont => execute_omega cont (apply_oper_1 n (exact_divide k body) l) - | O_SUM k1 i1 k2 i2 t cont => - execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l) + | O_SUM k1 i1 k2 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l) | O_CONTRADICTION i j => singleton (contradiction i j l) | O_MERGE_EQ i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 merge_eq l) @@ -2305,8 +1806,8 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) | O_NEGATE_CONTRADICT_INV i j => singleton (negate_contradict_inv i j l) - | O_STATE m s i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (state m s) l) + | O_STATE m i1 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 (state m) l) end. Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). @@ -2317,21 +1818,21 @@ Proof. - unfold valid_list_hyps; simpl; intros; left; apply (constant_neg_valid n ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros k1 k2 body t' Ht' m ep e lp H; apply Ht'; + intros m k1 k2 body t' Ht' ep e lp H; apply Ht'; apply (apply_oper_1_valid m (divide_and_approx k1 k2 body) (divide_and_approx_valid k1 k2 body) ep e lp H). - unfold valid_list_hyps; simpl; intros; left; apply (not_exact_divide_valid _ _ _ _ ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros k body t' Ht' m ep e lp H; apply Ht'; + intros m k body t' Ht' ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body) (exact_divide_valid k body) ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; + intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; apply - (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e + (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e lp H). - unfold valid_list_hyps; simpl; intros; left. apply (contradiction_valid n n0 ep e lp H). @@ -2352,164 +1853,98 @@ Proof. - unfold valid_list_hyps; simpl; intros i j ep e lp H; left; apply (negate_contradict_inv_valid i j ep e lp H). - unfold valid_list_hyps, valid_hyps; - intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; - apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H). + intros m i1 i2 t' Ht' ep e lp H; apply Ht'; + apply (apply_oper_2_valid i1 i2 (state m) (state_valid m) ep e lp H). Qed. - (* \subsection{Les opérations globales sur le but} \subsubsection{Normalisation} *) -Definition move_right (s : step) (p : proposition) := +Fixpoint normalize_prop (negated:bool)(p:proposition) := match p with - | EqTerm t1 t2 => EqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) - | LeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + - t1)%term) - | GeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) - | LtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + Tint (-(1)) + - t1)%term) - | GtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + Tint (-(1)) + - t2)%term) - | NeqTerm t1 t2 => NeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) - | p => p - end. - -Definition prop_stable (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p : proposition), - interp_proposition ep e p <-> interp_proposition ep e (f p). - -Definition p_apply_left (f : proposition -> proposition) - (p : proposition) := - match p with - | Timp x y => Timp (f x) y - | Tor x y => Tor (f x) y - | Tand x y => Tand (f x) y - | Tnot x => Tnot (f x) - | x => x - end. - -Theorem p_apply_left_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_apply_left f). -Proof. - unfold prop_stable; intros f H ep e p; split; - (case p; simpl; auto; intros p1; elim (H ep e p1); tauto). -Qed. - -Definition p_apply_right (f : proposition -> proposition) - (p : proposition) := - match p with - | Timp x y => Timp x (f y) - | Tor x y => Tor x (f y) - | Tand x y => Tand x (f y) - | Tnot x => Tnot (f x) - | x => x - end. - -Theorem p_apply_right_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_apply_right f). -Proof. - unfold prop_stable; intros f H ep e p. - case p; simpl; try tauto. - - intros p1; rewrite (H ep e p1); tauto. - - intros p1 p2; elim (H ep e p2); tauto. - - intros p1 p2; elim (H ep e p2); tauto. - - intros p1 p2; elim (H ep e p2); tauto. -Qed. - -Definition p_invert (f : proposition -> proposition) - (p : proposition) := - match p with - | EqTerm x y => Tnot (f (NeqTerm x y)) - | LeqTerm x y => Tnot (f (GtTerm x y)) - | GeqTerm x y => Tnot (f (LtTerm x y)) - | GtTerm x y => Tnot (f (LeqTerm x y)) - | LtTerm x y => Tnot (f (GeqTerm x y)) - | NeqTerm x y => Tnot (f (EqTerm x y)) - | x => x - end. - -Theorem p_invert_stable : - forall f : proposition -> proposition, - prop_stable f -> prop_stable (p_invert f). -Proof. - unfold prop_stable; intros f H ep e p. - case p; simpl; try tauto; intros t1 t2; rewrite <- (H ep e); simpl. - - generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable; try tauto. - - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto. - - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto. - - generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite ?le_lt_iff, ?gt_lt_iff; tauto. - - generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable; rewrite ?ge_le_iff, ?le_lt_iff; tauto. - - reflexivity. -Qed. - -Theorem move_right_stable : forall s : step, prop_stable (move_right s). -Proof. - unfold move_right, prop_stable; intros s ep e p; split. - - Simplify; simpl; elim (t_rewrite_stable s e); simpl. - + symmetry ; apply egal_left; assumption. - + intro; apply le_left; assumption. - + intro; apply le_left; rewrite <- ge_le_iff; assumption. - + intro; apply lt_left; rewrite <- gt_lt_iff; assumption. - + intro; apply lt_left; assumption. - + intro; apply ne_left_2; assumption. - - case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); - simpl; intro H1. - + rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; - now rewrite plus_permute, plus_opp_r, plus_0_r. - + apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); - rewrite plus_opp_r; assumption. - + rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); - rewrite plus_opp_r; assumption. - + rewrite gt_lt_iff; apply lt_left_inv; assumption. - + apply lt_left_inv; assumption. - + unfold not; intro H2; apply H1; - rewrite H2, plus_opp_r; trivial. -Qed. - - -Fixpoint p_rewrite (s : p_step) : proposition -> proposition := - match s with - | P_LEFT s => p_apply_left (p_rewrite s) - | P_RIGHT s => p_apply_right (p_rewrite s) - | P_STEP s => move_right s - | P_INVERT s => p_invert (move_right s) - end. - -Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). -Proof. - simple induction s; simpl. - - intros; apply p_apply_left_stable; trivial. - - intros; apply p_apply_right_stable; trivial. - - intros; apply p_invert_stable; apply move_right_stable. - - apply move_right_stable. -Qed. - -Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := - match l with - | nil => lh - | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) - end. - -Theorem normalize_hyps_valid : - forall l : list h_step, valid_hyps (normalize_hyps l). -Proof. - simple induction l; unfold valid_hyps; simpl. - - auto. - - intros n_s r; case n_s; intros n s H ep e lp H1; apply H; - apply apply_oper_1_valid. - + unfold valid1; intros ep1 e1 p1 H2; - elim (p_rewrite_stable s ep1 e1 p1); auto. - + assumption. -Qed. - -Theorem normalize_hyps_goal : - forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps), - interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l. + | EqTerm t1 t2 => + if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2))) + else EqTerm (Tint 0) (normalize (t1-t2)) + | NeqTerm t1 t2 => + if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2))) + else NeqTerm (Tint 0) (normalize (t1-t2)) + | LeqTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))) + else LeqTerm (Tint 0) (normalize (t2-t1)) + | GeqTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))) + else LeqTerm (Tint 0) (normalize (t1-t2)) + | LtTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2))) + else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))) + | GtTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1))) + else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))) + | Tnot p => Tnot (normalize_prop (negb negated) p) + | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p') + | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p') + | Timp p p' => Timp (normalize_prop (negb negated) p) + (normalize_prop negated p') + | Tprop _ | TrueTerm | FalseTerm => p + end. + +Definition normalize_hyps := List.map (normalize_prop false). + +Opaque normalize. + +Theorem normalize_prop_valid b e ep p : + interp_proposition e ep p <-> + interp_proposition e ep (normalize_prop b p). +Proof. + revert b. + induction p; intros; simpl; try tauto. + - destruct b; simpl; + rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. + + rewrite not_eq. apply egal_left_iff. + + apply egal_left_iff. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite le_lt_iff. apply not_iff_compat. + rewrite le_lt_int. rewrite le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + + apply le_left. + - now rewrite <- IHp. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite ge_le_iff, le_lt_iff. apply not_iff_compat. + rewrite le_lt_int. rewrite le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + + rewrite ge_le_iff. apply le_left. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. + apply le_left. + + rewrite gt_lt_iff. rewrite le_lt_int. rewrite le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite lt_le_iff. apply not_iff_compat. + apply le_left. + + rewrite le_lt_int, le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def; + apply not_iff_compat, egal_left_iff. + - now rewrite <- IHp1, <- IHp2. + - now rewrite <- IHp1, <- IHp2. + - now rewrite <- IHp1, <- IHp2. +Qed. + +Transparent normalize. + +Theorem normalize_hyps_valid : valid_hyps normalize_hyps. +Proof. + intros e ep l. induction l; simpl; intuition. + now rewrite <- normalize_prop_valid. +Qed. + +Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : + interp_goal ep env (normalize_hyps l) -> interp_goal ep env l. Proof. intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. Qed. @@ -2692,19 +2127,20 @@ Proof. - simpl in *; tauto. Qed. -Definition omega_tactic (t1 : e_step) (t2 : list h_step) - (c : proposition) (l : hyps) := - reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). +Definition omega_tactic (t1 : e_step) (c : proposition) (l : hyps) := + reduce_lhyps (decompose_solve t1 (normalize_hyps (concl_to_hyp c :: l))). Theorem do_omega : - forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) + forall (t : e_step) (envp : list Prop) (env : list int) (c : proposition) (l : hyps), - interp_list_goal envp env (omega_tactic t1 t2 c l) -> + interp_list_goal envp env (omega_tactic t c l) -> interp_goal_concl c envp env l. Proof. - unfold omega_tactic; intros; apply do_concl_to_hyp; - apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); - apply do_reduce_lhyps; assumption. + unfold omega_tactic; intros t ep e c l H. + apply do_concl_to_hyp. + apply normalize_hyps_goal. + apply (decompose_solve_valid t). + now apply do_reduce_lhyps. Qed. End IntOmega. diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index d7faaac96..4fd224e2b 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -79,13 +79,6 @@ let coq_I = lazy(init_constant "I") (* ReflOmegaCore/ZOmega *) -let coq_h_step = lazy (constant "h_step") -let coq_pair_step = lazy (constant "pair_step") -let coq_p_left = lazy (constant "P_LEFT") -let coq_p_right = lazy (constant "P_RIGHT") -let coq_p_invert = lazy (constant "P_INVERT") -let coq_p_step = lazy (constant "P_STEP") - let coq_t_int = lazy (constant "Tint") let coq_t_plus = lazy (constant "Tplus") let coq_t_mult = lazy (constant "Tmult") @@ -108,43 +101,6 @@ let coq_p_and = lazy (constant "Tand") let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") -(* Constructors for shuffle tactic *) -let coq_t_fusion = lazy (constant "t_fusion") -let coq_f_equal = lazy (constant "F_equal") -let coq_f_cancel = lazy (constant "F_cancel") -let coq_f_left = lazy (constant "F_left") -let coq_f_right = lazy (constant "F_right") - -(* Constructors for reordering tactics *) -let coq_c_do_both = lazy (constant "C_DO_BOTH") -let coq_c_do_left = lazy (constant "C_LEFT") -let coq_c_do_right = lazy (constant "C_RIGHT") -let coq_c_do_seq = lazy (constant "C_SEQ") -let coq_c_nop = lazy (constant "C_NOP") -let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") -let coq_c_opp_opp = lazy (constant "C_OPP_OPP") -let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") -let coq_c_opp_one = lazy (constant "C_OPP_ONE") -let coq_c_reduce = lazy (constant "C_REDUCE") -let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") -let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") -let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") -let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") -let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") -let coq_c_plus_comm = lazy (constant "C_PLUS_COMM") -let coq_c_red0 = lazy (constant "C_RED0") -let coq_c_red1 = lazy (constant "C_RED1") -let coq_c_red2 = lazy (constant "C_RED2") -let coq_c_red3 = lazy (constant "C_RED3") -let coq_c_red4 = lazy (constant "C_RED4") -let coq_c_red5 = lazy (constant "C_RED5") -let coq_c_red6 = lazy (constant "C_RED6") -let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") -let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED") -let coq_c_minus = lazy (constant "C_MINUS") -let coq_c_mult_comm = lazy (constant "C_MULT_COMM") - let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") let coq_s_div_approx = lazy (constant "O_DIV_APPROX") @@ -171,31 +127,6 @@ let coq_e_solve = lazy (constant "E_SOLVE") let coq_interp_sequent = lazy (constant "interp_goal_concl") let coq_do_omega = lazy (constant "do_omega") -(* \subsection{Construction d'expressions} *) - -let do_left t = - if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop - else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) - -let do_right t = - if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop - else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) - -let do_both t1 t2 = - if Term.eq_constr t1 (Lazy.force coq_c_nop) then do_right t2 - else if Term.eq_constr t2 (Lazy.force coq_c_nop) then do_left t1 - else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) - -let do_seq t1 t2 = - if Term.eq_constr t1 (Lazy.force coq_c_nop) then t2 - else if Term.eq_constr t2 (Lazy.force coq_c_nop) then t1 - else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) - -let rec do_list = function - | [] -> Lazy.force coq_c_nop - | [x] -> x - | (x::l) -> do_seq x (do_list l) - (* Nat *) let coq_S = lazy(init_constant "S") @@ -232,8 +163,6 @@ let mk_plist = fun l -> mk_list type1lev Term.mkProp l let mk_list = mk_list Univ.Level.set -let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l - type parse_term = | Tplus of Term.constr * Term.constr @@ -306,7 +235,7 @@ module type Int = sig val parse_term : Term.constr -> parse_term val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) - val is_scalar : Term.constr -> bool + val get_scalar : Term.constr -> Bigint.bigint option end module Z : Int = struct @@ -376,11 +305,18 @@ let parse_rel gl t = | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) | _ -> parse_logic_rel t -let rec is_scalar t = +let rec get_scalar t = match destructurate t with - | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> is_scalar t1 && is_scalar t2 - | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> is_scalar t - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> Option.has_some (recognize_Z t) - | _ -> false + | Kapp("Z.add", [t1;t2]) -> + Option.lift2 Bigint.add (get_scalar t1) (get_scalar t2) + | Kapp ("Z.sub",[t1;t2]) -> + Option.lift2 Bigint.sub (get_scalar t1) (get_scalar t2) + | Kapp ("Z.mul",[t1;t2]) -> + Option.lift2 Bigint.mult (get_scalar t1) (get_scalar t2) + | Kapp("Z.opp", [t]) -> Option.map Bigint.neg (get_scalar t) + | Kapp("Z.succ", [t]) -> Option.map Bigint.add_1 (get_scalar t) + | Kapp("Z.pred", [t]) -> Option.map Bigint.sub_1 (get_scalar t) + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> recognize_Z t + | _ -> None end diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 2901cc028..787ace603 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -19,12 +19,6 @@ val coq_False : Term.constr lazy_t val coq_I : Term.constr lazy_t (* from ReflOmegaCore/ZOmega *) -val coq_h_step : Term.constr lazy_t -val coq_pair_step : Term.constr lazy_t -val coq_p_left : Term.constr lazy_t -val coq_p_right : Term.constr lazy_t -val coq_p_invert : Term.constr lazy_t -val coq_p_step : Term.constr lazy_t val coq_t_int : Term.constr lazy_t val coq_t_plus : Term.constr lazy_t @@ -48,40 +42,6 @@ val coq_p_and : Term.constr lazy_t val coq_p_imp : Term.constr lazy_t val coq_p_prop : Term.constr lazy_t -val coq_f_equal : Term.constr lazy_t -val coq_f_cancel : Term.constr lazy_t -val coq_f_left : Term.constr lazy_t -val coq_f_right : Term.constr lazy_t - -val coq_c_do_both : Term.constr lazy_t -val coq_c_do_left : Term.constr lazy_t -val coq_c_do_right : Term.constr lazy_t -val coq_c_do_seq : Term.constr lazy_t -val coq_c_nop : Term.constr lazy_t -val coq_c_opp_plus : Term.constr lazy_t -val coq_c_opp_opp : Term.constr lazy_t -val coq_c_opp_mult_r : Term.constr lazy_t -val coq_c_opp_one : Term.constr lazy_t -val coq_c_reduce : Term.constr lazy_t -val coq_c_mult_plus_distr : Term.constr lazy_t -val coq_c_opp_left : Term.constr lazy_t -val coq_c_mult_assoc_r : Term.constr lazy_t -val coq_c_plus_assoc_r : Term.constr lazy_t -val coq_c_plus_assoc_l : Term.constr lazy_t -val coq_c_plus_permute : Term.constr lazy_t -val coq_c_plus_comm : Term.constr lazy_t -val coq_c_red0 : Term.constr lazy_t -val coq_c_red1 : Term.constr lazy_t -val coq_c_red2 : Term.constr lazy_t -val coq_c_red3 : Term.constr lazy_t -val coq_c_red4 : Term.constr lazy_t -val coq_c_red5 : Term.constr lazy_t -val coq_c_red6 : Term.constr lazy_t -val coq_c_mult_opp_left : Term.constr lazy_t -val coq_c_mult_assoc_reduced : Term.constr lazy_t -val coq_c_minus : Term.constr lazy_t -val coq_c_mult_comm : Term.constr lazy_t - val coq_s_constant_not_nul : Term.constr lazy_t val coq_s_constant_neg : Term.constr lazy_t val coq_s_div_approx : Term.constr lazy_t @@ -107,21 +67,12 @@ val coq_e_solve : Term.constr lazy_t val coq_interp_sequent : Term.constr lazy_t val coq_do_omega : Term.constr lazy_t -(** Building expressions *) - -val do_left : Term.constr -> Term.constr -val do_right : Term.constr -> Term.constr -val do_both : Term.constr -> Term.constr -> Term.constr -val do_seq : Term.constr -> Term.constr -> Term.constr -val do_list : Term.constr list -> Term.constr - val mk_nat : int -> Term.constr val mk_N : int -> Term.constr (** Precondition: the type of the list is in Set *) val mk_list : Term.constr -> Term.constr list -> Term.constr val mk_plist : Term.types list -> Term.types -val mk_shuffle_list : Term.constr list -> Term.constr (** Analyzing a coq term *) @@ -171,7 +122,7 @@ module type Int = (* parsing a relation expression, including = < <= >= > *) val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) - val is_scalar : Term.constr -> bool + val get_scalar : Term.constr -> Bigint.bigint option end (* Currently, we only use Z numbers *) diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index a0ed68a8a..7b63d5503 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -46,19 +46,19 @@ type occ_path = occ_step list d'une liste de pas à partir de la racine de l'hypothèse *) type occurrence = {o_hyp : Id.t; o_path : occ_path} +type atom_index = int + (* \subsection{reifiable formulas} *) type oformula = (* integer *) | Oint of Bigint.bigint (* recognized binary and unary operations *) | Oplus of oformula * oformula - | Omult of oformula * oformula + | Omult of oformula * oformula (* Invariant : one side is [Oint] *) | Ominus of oformula * oformula | Oopp of oformula (* an atom in the environment *) - | Oatom of int - (* weird expression that cannot be translated *) - | Oufo of oformula + | Oatom of atom_index (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq @@ -83,7 +83,6 @@ and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) e_right: oformula; (* formule brute droite *) - e_trace: Term.constr; (* tactique de normalisation *) e_origin: occurrence; (* l'hypothèse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié après normalisation *) @@ -108,7 +107,7 @@ type environment = { (* La meme chose pour les propositions *) mutable props : Term.constr list; (* Les variables introduites par omega *) - mutable om_vars : (oformula * int) list; + mutable om_vars : (int * oformula) list; (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) real_indices : int IntHtbl.t; @@ -155,7 +154,6 @@ let rec oform_eq f f' = match f,f' with | Ominus (f1,f2), Ominus (f1',f2') -> oform_eq f1 f1' && oform_eq f2 f2' | Oopp f, Oopp f' -> oform_eq f f' | Oatom a, Oatom a' -> Int.equal a a' - | Oufo f, Oufo f' -> oform_eq f f' | _ -> false let dir_eq d d' = match d, d' with @@ -201,42 +199,38 @@ let print_env_reification env = (* generation d'identifiant d'equation pour Omega *) let new_omega_eq, rst_omega_eq = - let cpt = ref 0 in + let cpt = ref (-1) in (function () -> incr cpt; !cpt), - (function () -> cpt:=0) + (function () -> cpt:=(-1)) (* generation d'identifiant de variable pour Omega *) let new_omega_var, rst_omega_var = - let cpt = ref 0 in + let cpt = ref (-1) in (function () -> incr cpt; !cpt), - (function () -> cpt:=0) + (function () -> cpt:=(-1)) (* Affichage des variables d'un système *) let display_omega_var i = Printf.sprintf "OV%d" i -(* Recherche la variable codant un terme pour Omega et crée la variable dans - l'environnement si il n'existe pas. Cas ou la variable dans Omega représente - le terme d'un monome (le plus souvent un atome) *) +(* Register a new internal variable corresponding to some oformula + (normally an [Oatom]). *) -let intern_omega env t = - try List.assoc_f oform_eq t env.om_vars - with Not_found -> - let v = new_omega_var () in - env.om_vars <- (t,v) :: env.om_vars; v +let add_omega_var env t = + let v = new_omega_var () in + env.om_vars <- (v,t) :: env.om_vars (* Ajout forcé d'un lien entre un terme et une variable Cas où la variable est créée par Omega et où il faut la lier après coup à un atome réifié introduit de force *) -let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars +let force_omega_var env t v = + env.om_vars <- (v,t) :: env.om_vars -(* Récupère le terme associé à une variable *) -let unintern_omega env id = - let rec loop = function - | [] -> failwith "unintern" - | ((t,j)::l) -> if Int.equal id j then t else loop l in - loop env.om_vars +(* Récupère le terme associé à une variable omega *) +let unintern_omega env v = + try List.assoc_f Int.equal v env.om_vars + with Not_found -> failwith "unintern_omega" (* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions @@ -244,10 +238,12 @@ let unintern_omega env id = l'environnement initial contenant tout. Il faudra le réduire après calcul des variables utiles. *) -let add_reified_atom t env = +let add_reified_atom sync t env = try List.index0 Term.eq_constr t env.terms with Not_found -> let i = List.length env.terms in + (* synchronize atom indexes and omega variables *) + let () = if sync then add_omega_var env (Oatom i) in env.terms <- env.terms @ [t]; i let get_reified_atom env = @@ -284,7 +280,6 @@ let rec oprint ch = function | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 | Oatom n -> Printf.fprintf ch "V%02d" n - | Oufo x -> Printf.fprintf ch "?" let print_comp = function | Eq -> "=" | Leq -> "<=" | Geq -> ">=" @@ -301,31 +296,6 @@ let rec pprint ch = function | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 | Pprop c -> Printf.fprintf ch "Prop" -let rec weight env = function - | Oint _ -> -1 - | Oopp c -> weight env c - | Omult(c,_) -> weight env c - | Oplus _ -> failwith "weight" - | Ominus _ -> failwith "weight minus" - | Oufo _ -> -1 - | Oatom _ as c -> (intern_omega env c) - -(* \section{Passage entre oformules et représentation interne de Omega} *) - -(* \subsection{Oformula vers Omega} *) - -let omega_of_oformula env kind = - let rec loop accu = function - | Oplus(Omult(v,Oint n),r) -> - loop ({v=intern_omega env v; c=n} :: accu) r - | Oint n -> - let id = new_omega_eq () in - (*i tag_equation name id; i*) - {kind = kind; body = List.rev accu; - constant = n; id = id} - | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in - loop [] - (* \subsection{Omega vers Oformula} *) let oformula_of_omega env af = @@ -345,7 +315,6 @@ let coq_of_formula env t = | Oopp t -> app Z.opp [| loop t |] | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |] | Oint v -> Z.mk v - | Oufo t -> loop t | Oatom var -> (* attention ne traite pas les nouvelles variables si on ne les * met pas dans env.term *) @@ -362,53 +331,49 @@ let reified_of_atom env i = IntHtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; raise Not_found -let rec reified_of_formula env = function - | Oplus (t1,t2) -> - app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oopp t -> - app coq_t_opp [| reified_of_formula env t |] - | Omult(t1,t2) -> - app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] - | Oint v -> app coq_t_int [| Z.mk v |] - | Oufo t -> reified_of_formula env t +let reified_binop = function + | Oplus _ -> app coq_t_plus + | Ominus _ -> app coq_t_minus + | Omult _ -> app coq_t_mult + | _ -> assert false + +let rec reified_of_formula env t = match t with + | Oplus (t1,t2) | Omult (t1,t2) | Ominus (t1,t2) -> + reified_binop t [| reified_of_formula env t1; reified_of_formula env t2 |] + | Oopp t -> app coq_t_opp [| reified_of_formula env t |] + | Oint v -> app coq_t_int [| Z.mk v |] | Oatom i -> app coq_t_var [| mk_N (reified_of_atom env i) |] - | Ominus(t1,t2) -> - app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] let reified_of_formula env f = try reified_of_formula env f with reraise -> oprint stderr f; raise reraise -let rec reified_of_proposition env = function - Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> - app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> - app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> - app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> - app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> - app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> - app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] +let reified_cmp = function + | Eq -> app coq_p_eq + | Leq -> app coq_p_leq + | Geq -> app coq_p_geq + | Gt -> app coq_p_gt + | Lt -> app coq_p_lt + | Neq -> app coq_p_neq + +let reified_conn = function + | Por _ -> app coq_p_or + | Pand _ -> app coq_p_and + | Pimp _ -> app coq_p_imp + | _ -> assert false + +let rec reified_of_oprop env t = match t with + | Pequa (_,{ e_comp=cmp; e_left=t1; e_right=t2 }) -> + reified_cmp cmp [| reified_of_formula env t1; reified_of_formula env t2 |] | Ptrue -> Lazy.force coq_p_true | Pfalse -> Lazy.force coq_p_false - | Pnot t -> - app coq_p_not [| reified_of_proposition env t |] - | Por (_,t1,t2) -> - app coq_p_or - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pand(_,t1,t2) -> - app coq_p_and - [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pimp(_,t1,t2) -> - app coq_p_imp - [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pnot t -> app coq_p_not [| reified_of_oprop env t |] + | Por (_,t1,t2) | Pand (_,t1,t2) | Pimp (_,t1,t2) -> + reified_conn t [| reified_of_oprop env t1; reified_of_oprop env t2 |] | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - try reified_of_proposition env f + try reified_of_oprop env f with reraise -> pprint stderr f; raise reraise (* \subsection{Omega vers COQ réifié} *) @@ -445,7 +410,6 @@ let rec vars_of_formula = function | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2) | Oopp e -> vars_of_formula e | Oatom i -> IntSet.singleton i - | Oufo _ -> IntSet.empty let rec vars_of_equations = function | [] -> IntSet.empty @@ -462,241 +426,99 @@ let rec vars_of_prop = function | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) | Pprop _ | Ptrue | Pfalse -> IntSet.empty -(* \subsection{Multiplication par un scalaire} *) - -let rec scalar n = function - Oplus(t1,t2) -> - let tac1,t1' = scalar n t1 and - tac2,t2' = scalar n t2 in - do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], - Oplus(t1',t2') - | Oopp t -> - do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) - | Omult(t1,Oint x) -> - do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) - | Omult(t1,t2) -> - CErrors.error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> do_list [], Omult(t,Oint n) - | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) - | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) - | Ominus _ -> failwith "scalar minus" - -(* \subsection{Propagation de l'inversion} *) - -let rec negate = function - Oplus(t1,t2) -> - let tac1,t1' = negate t1 and - tac2,t2' = negate t2 in - do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], - Oplus(t1',t2') - | Oopp t -> - do_list [Lazy.force coq_c_opp_opp], t - | Omult(t1,Oint x) -> - do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) - | Omult(t1,t2) -> - CErrors.error "Omega: Can't solve a goal with non-linear products" - | (Oatom _ as t) -> - do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) - | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) - | Oufo c -> do_list [], Oufo (Oopp c) - | Ominus _ -> failwith "negate minus" - -let norm l = (List.length l) - -(* \subsection{Mélange (fusion) de deux équations} *) -(* \subsubsection{Version avec coefficients} *) -let shuffle_path k1 e1 k2 e2 = - let rec loop = function - (({c=c1;v=v1}::l1) as l1'), - (({c=c2;v=v2}::l2) as l2') -> - if Int.equal v1 v2 then - if Bigint.equal (k1 * c1 + k2 * c2) zero then ( - Lazy.force coq_f_cancel :: loop (l1,l2)) - else ( - Lazy.force coq_f_equal :: loop (l1,l2) ) - else if v1 > v2 then ( - Lazy.force coq_f_left :: loop(l1,l2')) - else ( - Lazy.force coq_f_right :: loop(l1',l2)) - | ({c=c1;v=v1}::l1), [] -> - Lazy.force coq_f_left :: loop(l1,[]) - | [],({c=c2;v=v2}::l2) -> - Lazy.force coq_f_right :: loop([],l2) - | [],[] -> flush stdout; [] in - mk_shuffle_list (loop (e1,e2)) - -(* \subsubsection{Version sans coefficients} *) -let rec shuffle env (t1,t2) = - match t1,t2 with - Oplus(l1,r1), Oplus(l2,r2) -> - if weight env l1 > weight env l2 then - let l_action,t' = shuffle env (r1,t2) in - do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') - else - let l_action,t' = shuffle env (t1,r2) in - do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - | Oplus(l1,r1), t2 -> - if weight env l1 > weight env t2 then - let (l_action,t') = shuffle env (r1,t2) in - do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') - else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> - if weight env l2 > weight env t1 then - let (l_action,t') = shuffle env (t1,r2) in - do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - else do_list [],Oplus(t1,t2) - | Oint t1,Oint t2 -> - do_list [Lazy.force coq_c_reduce], Oint(t1+t2) - | t1,t2 -> - if weight env t1 < weight env t2 then - do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - else do_list [],Oplus(t1,t2) - -(* \subsection{Fusion avec réduction} *) - -let shrink_pair f1 f2 = - begin match f1,f2 with - Oatom v,Oatom _ -> - Lazy.force coq_c_red1, Omult(Oatom v,Oint two) - | Oatom v, Omult(_,c2) -> - Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) - | Omult (v1,c1),Oatom v -> - Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) - | Omult (Oatom v,c1),Omult (v2,c2) -> - Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) - | t1,t2 -> - oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); - flush Pervasives.stdout; CErrors.error "shrink.1" - end - -(* \subsection{Calcul d'une sous formule constante} *) - -let reduce_factor = function - Oatom v -> - let r = Omult(Oatom v,Oint one) in - [Lazy.force coq_c_red0],r - | Omult(Oatom v,Oint n) as f -> [],f - | Omult(Oatom v,c) -> - let rec compute = function - Oint n -> n - | Oplus(t1,t2) -> compute t1 + compute t2 - | _ -> CErrors.error "condense.1" in - [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) - | t -> CErrors.error "reduce_factor.1" - -(* \subsection{Réordonnancement} *) - -let rec condense env = function - Oplus(f1,(Oplus(f2,r) as t)) -> - if Int.equal (weight env f1) (weight env f2) then begin - let shrink_tac,t = shrink_pair f1 f2 in - let assoc_tac = Lazy.force coq_c_plus_assoc_l in - let tac_list,t' = condense env (Oplus(t,r)) in - assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' - end else begin - let tac,f = reduce_factor f1 in - let tac',t' = condense env t in - [do_both (do_list tac) (do_list tac')], Oplus(f,t') - end - | Oplus(f1,Oint n) -> - let tac,f1' = reduce_factor f1 in - [do_left (do_list tac)],Oplus(f1',Oint n) - | Oplus(f1,f2) -> - if Int.equal (weight env f1) (weight env f2) then begin - let tac_shrink,t = shrink_pair f1 f2 in - let tac,t' = condense env t in - tac_shrink :: tac,t' - end else begin - let tac,f = reduce_factor f1 in - let tac',t' = condense env f2 in - [do_both (do_list tac) (do_list tac')],Oplus(f,t') - end - | (Oint _ as t)-> [],t - | t -> - let tac,t' = reduce_factor t in - let final = Oplus(t',Oint zero) in - tac @ [Lazy.force coq_c_red6], final - -(* \subsection{Elimination des zéros} *) - -let rec clear_zero = function - Oplus(Omult(Oatom v,Oint n),r) when Bigint.equal n zero -> - let tac',t = clear_zero r in - Lazy.force coq_c_red5 :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero r in - (if List.is_empty tac then [] else [do_right (do_list tac)]),Oplus(f,t) - | t -> [],t;; - -(* \subsection{Transformation des hypothèses} *) - -let rec reduce env = function - Oplus(t1,t2) -> - let t1', trace1 = reduce env t1 in - let t2', trace2 = reduce env t2 in - let trace3,t' = shuffle env (t1',t2') in - t', do_list [do_both trace1 trace2; trace3] - | Ominus(t1,t2) -> - let t,trace = reduce env (Oplus(t1, Oopp t2)) in - t, do_list [Lazy.force coq_c_minus; trace] - | Omult(t1,t2) as t -> - let t1', trace1 = reduce env t1 in - let t2', trace2 = reduce env t2 in - begin match t1',t2' with - | (_, Oint n) -> - let tac,t' = scalar n t1' in - t', do_list [do_both trace1 trace2; tac] - | (Oint n,_) -> - let tac,t' = scalar n t2' in - t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac] - | _ -> Oufo t, Lazy.force coq_c_nop - end - | Oopp t -> - let t',trace = reduce env t in - let trace',t'' = negate t' in - t'', do_list [do_left trace; trace'] - | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop - -let normalize_linear_term env t = - let t1,trace1 = reduce env t in - let trace2,t2 = condense env t1 in - let trace3,t3 = clear_zero t2 in - do_list [trace1; do_list trace2; do_list trace3], t3 - -(* Cette fonction reproduit très exactement le comportement de [p_invert] *) +(* Normalized formulas : + + - sorted list of monomials, largest index first, + with non-null coefficients + - a constant coefficient + + /!\ Keep in sync with the corresponding functions in ReflOmegaCore ! +*) + +type nformula = + { coefs : (atom_index * bigint) list; + cst : bigint } + +let scale n { coefs; cst } = + { coefs = List.map (fun (v,k) -> (v,k*n)) coefs; + cst = cst*n } + +let shuffle nf1 nf2 = + let rec merge l1 l2 = match l1,l2 with + | [],_ -> l2 + | _,[] -> l1 + | (v1,k1)::r1,(v2,k2)::r2 -> + if Int.equal v1 v2 then + let k = k1+k2 in + if Bigint.equal k Bigint.zero then merge r1 r2 + else (v1,k) :: merge r1 r2 + else if v1 > v2 then (v1,k1) :: merge r1 l2 + else (v2,k2) :: merge l1 r2 + in + { coefs = merge nf1.coefs nf2.coefs; + cst = nf1.cst + nf2.cst } + +let rec normalize = function + | Oplus(t1,t2) -> shuffle (normalize t1) (normalize t2) + | Ominus(t1,t2) -> normalize (Oplus (t1, Oopp(t2))) + | Oopp(t) -> scale negone (normalize t) + | Omult(t,Oint n) | Omult (Oint n, t) -> + if Bigint.equal n Bigint.zero then { coefs = []; cst = zero } + else scale n (normalize t) + | Omult _ -> assert false (* invariant on Omult *) + | Oint n -> { coefs = []; cst = n } + | Oatom v -> { coefs = [v,Bigint.one]; cst=Bigint.zero} + +(* From normalized formulas to omega representations *) + +let omega_of_nformula env kind nf = + { id = new_omega_eq (); + kind; + constant=nf.cst; + body = List.map (fun (v,c) -> { v; c }) nf.coefs } + + let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq -let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = - let mk_step t1 t2 t kind = - let trace, oterm = normalize_linear_term env t in - let equa = omega_of_oformula env kind oterm in +let normalize_equation env (negated,depends,origin,path) oper t1 t2 = + let mk_step t kind = + let equa = omega_of_nformula env kind (normalize t) in { e_comp = oper; e_left = t1; e_right = t2; e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; - e_trace = trace; e_omega = equa } + e_omega = equa } in try match (if negated then (negate_oper oper) else oper) with - | Eq -> mk_step t1 t2 (Oplus (t1,Oopp t2)) EQUA - | Neq -> mk_step t1 t2 (Oplus (t1,Oopp t2)) DISE - | Leq -> mk_step t1 t2 (Oplus (t2,Oopp t1)) INEQ - | Geq -> mk_step t1 t2 (Oplus (t1,Oopp t2)) INEQ - | Lt -> mk_step t1 t2 (Oplus (Oplus(t2,Oint negone),Oopp t1)) INEQ - | Gt -> mk_step t1 t2 (Oplus (Oplus(t1,Oint negone),Oopp t2)) INEQ + | Eq -> mk_step (Oplus (t1,Oopp t2)) EQUA + | Neq -> mk_step (Oplus (t1,Oopp t2)) DISE + | Leq -> mk_step (Oplus (t2,Oopp t1)) INEQ + | Geq -> mk_step (Oplus (t1,Oopp t2)) INEQ + | Lt -> mk_step (Oplus (Oplus(t2,Oint negone),Oopp t1)) INEQ + | Gt -> mk_step (Oplus (Oplus(t1,Oint negone),Oopp t2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothèses} *) +let mkPor i x y = Por (i,x,y) +let mkPand i x y = Pand (i,x,y) +let mkPimp i x y = Pimp (i,x,y) + let rec oformula_of_constr env t = match Z.parse_term t with | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 - | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> - binop env (fun x y -> Omult(x,y)) t1 t2 + | Tmult (t1,t2) -> + (match Z.get_scalar t1 with + | Some n -> Omult (Oint n,oformula_of_constr env t2) + | None -> + match Z.get_scalar t2 with + | Some n -> Omult (oformula_of_constr env t1, Oint n) + | None -> Oatom (add_reified_atom true t env)) | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n - | _ -> Oatom (add_reified_atom t env) + | Tother -> Oatom (add_reified_atom true t env) and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in @@ -721,7 +543,7 @@ and mk_equation env ctxt c connector t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in (* On ajoute l'equation dans l'environnement. *) - let omega = normalize_equation env ctxt (connector,t1',t2') in + let omega = normalize_equation env ctxt connector t1' t2' in add_equation env omega; Pequa (c,omega) @@ -736,22 +558,16 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = | Rtrue -> Ptrue | Rfalse -> Pfalse | Rnot t -> - let t' = - oproposition_of_constr - env (not negated, depends, origin,(O_mono::path)) gl t in - Pnot t' - | Ror (t1,t2) -> - binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 - | Rand (t1,t2) -> - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) t1 t2 + let ctxt' = (not negated, depends, origin,(O_mono::path)) in + Pnot (oproposition_of_constr env ctxt' gl t) + | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl mkPor t1 t2 + | Rand (t1,t2) -> binprop env ctxt negated negated gl mkPand t1 t2 | Rimp (t1,t2) -> - binprop env ctxt (not negated) (not negated) gl - (fun i x y -> Pimp(i,x,y)) t1 t2 + binprop env ctxt (not negated) (not negated) gl mkPimp t1 t2 | Riff (t1,t2) -> (* No lifting here, since Omega only works on closed propositions. *) - binprop env ctxt negated negated gl - (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) + binprop env ctxt negated negated gl mkPand + (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c (* Destructuration des hypothèses et de la conclusion *) @@ -836,7 +652,7 @@ let display_systems syst_list = (operator_of_eq om_e.kind) in let display_equation oformula_eq = - pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); + pprint stdout (Pequa (Lazy.force coq_I,oformula_eq)); print_newline (); display_omega oformula_eq.e_omega; Printf.printf " Depends on:"; List.iter display_depend oformula_eq.e_depends; @@ -897,14 +713,14 @@ let add_stated_equations env tree = (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in - let v = add_reified_atom coq_v env in + let v = add_reified_atom false coq_v env in (* Le terme qu'il va falloir introduire *) let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in (* sa représentation sous forme d'équation mais non réifié car on n'a pas * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in (* enregistre le lien entre la variable omega et la variable Coq *) - intern_omega_force env (Oatom v) st.st_var; + force_omega_var env (Oatom v) st.st_var; (v, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations @@ -1054,38 +870,35 @@ let replay_history env env_hyp = [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - mkApp (Lazy.force coq_s_div_approx, - [| Z.mk k; Z.mk d; - reified_of_omega env e2.body e2.constant; - loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) + mkApp (Lazy.force coq_s_div_approx, + [| mk_nat (get_hyp env_hyp e1.id); Z.mk k; Z.mk d; + reified_of_omega env e2.body e2.constant; + loop env_hyp l |]) | NOT_EXACT_DIVIDE (e1,k) :: l -> - let e2_constant = floor_div e1.constant k in - let d = e1.constant - e2_constant * k in - let e2_body = map_eq_linear (fun c -> c / k) e1.body in - mkApp (Lazy.force coq_s_not_exact_divide, - [|Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant; - mk_nat (get_hyp env_hyp e1.id)|]) + let e2_constant = floor_div e1.constant k in + let d = e1.constant - e2_constant * k in + let e2_body = map_eq_linear (fun c -> c / k) e1.body in + mkApp (Lazy.force coq_s_not_exact_divide, + [| mk_nat (get_hyp env_hyp e1.id); Z.mk k; Z.mk d; + reified_of_omega env e2_body e2_constant |]) | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = - map_eq_linear (fun c -> c / k) e1.body in - let e2_constant = floor_div e1.constant k in - mkApp (Lazy.force coq_s_exact_divide, - [|Z.mk k; - reified_of_omega env e2_body e2_constant; - loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) + let e2_body = map_eq_linear (fun c -> c / k) e1.body in + let e2_constant = floor_div e1.constant k in + mkApp (Lazy.force coq_s_exact_divide, + [| mk_nat (get_hyp env_hyp e1.id); Z.mk k; + reified_of_omega env e2_body e2_constant; + loop env_hyp l |]) | (MERGE_EQ(e3,e1,e2)) :: l -> let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in mkApp (Lazy.force coq_s_merge_eq, [| mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id - and n2 = get_hyp env_hyp e2.id in - let trace = shuffle_path k1 e1.body k2 e2.body in - mkApp (Lazy.force coq_s_sum, - [| Z.mk k1; mk_nat n1; Z.mk k2; - mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) + let n1 = get_hyp env_hyp e1.id + and n2 = get_hyp env_hyp e2.id in + mkApp (Lazy.force coq_s_sum, + [| Z.mk k1; mk_nat n1; Z.mk k2; + mk_nat n2; (loop (CCEqua e3 :: env_hyp) l) |]) | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, [| mk_nat (get_hyp env_hyp e) |]) @@ -1093,19 +906,13 @@ let replay_history env env_hyp = mkApp (Lazy.force coq_s_constant_neg, [| mk_nat (get_hyp env_hyp e) |]) | STATE {st_new_eq=new_eq; st_def =def; - st_orig=orig; st_coef=m; - st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.id - and n2 = get_hyp env_hyp def.id in - let v = unintern_omega env sigma in - let o_def = oformula_of_omega env def in - let o_orig = oformula_of_omega env orig in - let body = - Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in - let trace,_ = normalize_linear_term env body in - mkApp (Lazy.force coq_s_state, - [| Z.mk m; trace; mk_nat n1; mk_nat n2; - loop (CCEqua new_eq.id :: env_hyp) l |]) + st_orig=orig; st_coef=m; + st_var=sigma } :: l -> + let n1 = get_hyp env_hyp orig.id + and n2 = get_hyp env_hyp def.id in + mkApp (Lazy.force coq_s_state, + [| Z.mk m; mk_nat n1; mk_nat n2; + loop (CCEqua new_eq.id :: env_hyp) l |]) | HYP _ :: l -> loop env_hyp l | CONSTANT_NUL e :: l -> mkApp (Lazy.force coq_s_constant_nul, @@ -1205,7 +1012,6 @@ let resolution env (reified_concl,reified_hyps) systems_list = List.fold_left (fun s e -> Id.Set.add e.e_origin.o_hyp s) Id.Set.empty in let hyps = hyps_of_eqns equations in let useful_hypnames = Id.Set.elements (Id.Set.remove id_concl hyps) in - let all_names = id_concl :: useful_hypnames in let useful_hyptypes = List.map (fun id -> List.assoc_f Id.equal id reified_hyps) useful_hypnames in @@ -1229,6 +1035,8 @@ let resolution env (reified_concl,reified_hyps) systems_list = IntHtbl.add env.real_indices var i; t :: loop (succ i) l in loop 0 all_vars_env in + (* Since [all_vars_env] is sorted, this renumbering of variables + should have preserved order *) let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in (* On peut maintenant généraliser le but : env est a jour *) let l_reified_stated = @@ -1249,24 +1057,8 @@ let resolution env (reified_concl,reified_hyps) systems_list = (l_reified_stated @ l_reified_terms) in let reified = app coq_interp_sequent - [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in - let reified = EConstr.of_constr reified in - let normalize_equation e = - let rec loop = function - [] -> app (if e.e_negated then coq_p_invert else coq_p_step) - [| e.e_trace |] - | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] - | (O_right :: l) -> app coq_p_right [| loop l |] in - let correct_index = - let i = List.index0 Id.equal e.e_origin.o_hyp all_names in - (* PL: it seems that additionally introduced hyps are in the way during - normalization, hence this index shifting... *) - if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) - in - app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in - let normalization_trace = - mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in - + [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] + in let initial_context = List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) useful_hypnames in let context = @@ -1275,8 +1067,8 @@ let resolution env (reified_concl,reified_hyps) systems_list = Tactics.generalize (l_generalize_arg @ List.map EConstr.mkVar useful_hypnames) >> - Tactics.change_concl reified >> - Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> + Tactics.change_concl (EConstr.of_constr reified) >> + Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic|])) >> show_goal >> Tactics.normalise_vm_in_concl >> (*i Alternatives to the previous line: -- cgit v1.2.3 From a8808e8d3935430f4dc24b68a828620a9e9f12a4 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Mon, 22 May 2017 14:24:47 +0200 Subject: romega: add a tactic named unsafe_romega (for debugging, or bold users) In this variant, the proof term produced by romega isn't verified at the tactic run-time (no vm_compute). In theory, [unsafe_romega] should behave exactly as [romega], but faster. Now, if there's a bug in romega, we'll be notified only at the following Qed. This could be interesting for debugging purpose : you could inspect the produced buggish term via a Show Proof. --- plugins/romega/g_romega.ml4 | 12 ++++++------ plugins/romega/refl_omega.ml | 20 ++++++++++---------- 2 files changed, 16 insertions(+), 16 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index df7e5cb99..c2d7d5050 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -21,7 +21,7 @@ let eval_tactic name = let tac = Tacenv.interp_ltac kn in Tacinterp.eval_tactic tac -let romega_tactic l = +let romega_tactic unsafe l = let tacs = List.map (function | "nat" -> eval_tactic "zify_nat" @@ -38,15 +38,15 @@ let romega_tactic l = we'd better leave as little as possible in the conclusion, for an easier decidability argument. *) (Tactics.intros) - (total_reflexive_omega_tactic)) - + (total_reflexive_omega_tactic unsafe)) TACTIC EXTEND romega -| [ "romega" ] -> [ romega_tactic [] ] +| [ "romega" ] -> [ romega_tactic false [] ] +| [ "unsafe_romega" ] -> [ romega_tactic true [] ] END TACTIC EXTEND romega' | [ "romega" "with" ne_ident_list(l) ] -> - [ romega_tactic (List.map Names.Id.to_string l) ] -| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] + [ romega_tactic false (List.map Names.Id.to_string l) ] +| [ "romega" "with" "*" ] -> [ romega_tactic false ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 7b63d5503..7a48b9788 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -974,7 +974,7 @@ l'extraction d'un ensemble minimal de solutions permettant la résolution globale du système et enfin construit la trace qui permet de faire rejouer cette solution par la tactique réflexive. *) -let resolution env (reified_concl,reified_hyps) systems_list = +let resolution unsafe env (reified_concl,reified_hyps) systems_list = let num = ref 0 in let solve_system list_eq = let index = !num in @@ -1070,16 +1070,16 @@ let resolution env (reified_concl,reified_hyps) systems_list = Tactics.change_concl (EConstr.of_constr reified) >> Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic|])) >> show_goal >> - Tactics.normalise_vm_in_concl >> - (*i Alternatives to the previous line: - - Normalisation without VM: - Tactics.normalise_in_concl - - Skip the conversion check and rely directly on the QED: - Tactics.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> - i*) + (if unsafe then + (* Trust the produced term. Faster, but might fail later at Qed. + Also handy when debugging, e.g. via a Show Proof after romega. *) + Tactics.convert_concl_no_check + (EConstr.of_constr (Lazy.force coq_True)) Term.VMcast + else + Tactics.normalise_vm_in_concl) >> Tactics.apply (EConstr.of_constr (Lazy.force coq_I)) -let total_reflexive_omega_tactic = +let total_reflexive_omega_tactic unsafe = Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); @@ -1090,7 +1090,7 @@ let total_reflexive_omega_tactic = let full_reified_goal = (id_concl,Pnot concl) :: hyps in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; - resolution env reified_goal systems_list + resolution unsafe env reified_goal systems_list with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" end } -- cgit v1.2.3 From 531aa42ebbd63f45f2b768f570239516e6ec3edb Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 17 May 2017 11:39:02 +0200 Subject: ReflOmegaCore: comment, reorganize, permut some constructors, etc --- plugins/romega/ReflOmegaCore.v | 1160 ++++++++++++++++++++-------------------- 1 file changed, 571 insertions(+), 589 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 8fa6905ba..2a0705b3d 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -10,7 +10,7 @@ Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base. Delimit Scope Int_scope with I. -(* Abstract Integers. *) +(** * Abstract Integers. *) Module Type Int. @@ -34,10 +34,10 @@ Module Type Int. Open Scope Int_scope. - (* First, int is a ring: *) + (** First, Int is a ring: *) Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). - (* int should also be ordered: *) + (** Int should also be ordered: *) Parameter le : t -> t -> Prop. Parameter lt : t -> t -> Prop. @@ -51,35 +51,35 @@ Module Type Int. Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i). Axiom gt_lt_iff : forall i j, (i>j) <-> (j j i i<>j. - (* Compatibilities *) + (** Compatibilities *) Axiom lt_0_1 : 0<1. Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). Axiom mult_lt_compat_l : forall i j k, 0 < k -> i < j -> k*i t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i i>j. - (* Up to here, these requirements could be fulfilled + (** Up to here, these requirements could be fulfilled by any totally ordered ring. Let's now be int-specific: *) Axiom le_lt_int : forall x y, x x<=y+-(1). - (* Btw, lt_0_1 could be deduced from this last axiom *) + (** Btw, lt_0_1 could be deduced from this last axiom *) End Int. -(* Of course, Z is a model for our abstract int *) +(** Of course, Z is a model for our abstract int *) Module Z_as_Int <: Int. @@ -136,18 +136,18 @@ Module Z_as_Int <: Int. End Z_as_Int. - +(** * Properties of abstract integers *) Module IntProperties (I:Int). Import I. Local Notation int := I.t. - (* Primo, some consequences of being a ring theory... *) + (** Primo, some consequences of being a ring theory... *) Definition two := 1+1. Notation "2" := two : Int_scope. - (* Aliases for properties packed in the ring record. *) + (** Aliases for properties packed in the ring record. *) Definition plus_assoc := ring.(Radd_assoc). Definition plus_comm := ring.(Radd_comm). @@ -162,7 +162,7 @@ Module IntProperties (I:Int). Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l mult_plus_distr_r opp_def minus_def. - (* More facts about plus *) + (** More facts about [plus] *) Lemma plus_0_r : forall x, x+0 = x. Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. @@ -183,7 +183,7 @@ Module IntProperties (I:Int). now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. - (* More facts about mult *) + (** More facts about [mult] *) Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). Proof. intros; symmetry; apply mult_assoc. Qed. @@ -213,7 +213,7 @@ Module IntProperties (I:Int). rewrite mult_comm. apply mult_1_l. Qed. - (* More facts about opp *) + (** More facts about [opp] *) Definition plus_opp_r := opp_def. @@ -275,38 +275,7 @@ Module IntProperties (I:Int). now rewrite plus_opp_l, plus_comm, H. Qed. - (* Special lemmas for factorisation. *) - - Lemma red_factor0 : forall n, n = n*1. - Proof. symmetry; apply mult_1_r. Qed. - - Lemma red_factor1 : forall n, n+n = n*2. - Proof. - intros; unfold two. - now rewrite mult_comm, mult_plus_distr_r, mult_1_l. - Qed. - - Lemma red_factor2 : forall n m, n + n*m = n * (1+m). - Proof. - intros; rewrite mult_plus_distr_l. - now rewrite mult_1_r. - Qed. - - Lemma red_factor3 : forall n m, n*m + n = n*(1+m). - Proof. intros; now rewrite plus_comm, red_factor2. Qed. - - Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). - Proof. - intros; now rewrite mult_plus_distr_l. - Qed. - - Lemma red_factor5 : forall n m , n * 0 + m = m. - Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. - - Definition red_factor6 := plus_0_r_reverse. - - - (* Specialized distributivities *) + (** Specialized distributivities *) Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. Hint Rewrite <- plus_assoc : int. @@ -350,7 +319,7 @@ Module IntProperties (I:Int). Qed. - (* Secondo, some results about order (and equality) *) + (** Secondo, some results about order (and equality) *) Lemma lt_irrefl : forall n, ~ n -n <= 0. Proof. @@ -681,7 +650,7 @@ Module IntProperties (I:Int). intros k; rewrite gt_lt_iff; apply lt_le_weak. Qed. - (* Lemmas specific to integers (they use lt_le_int) *) + (** Lemmas specific to integers (they use [le_lt_int]) *) Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. Proof. @@ -762,7 +731,7 @@ Module IntProperties (I:Int). apply mult_le_compat_l; auto using lt_le_weak. Qed. - (* Some decidabilities *) + (** Some decidabilities *) Lemma dec_eq : forall i j:int, decidable (i=j). Proof. @@ -797,7 +766,7 @@ Module IntProperties (I:Int). End IntProperties. - +(** * The Coq side of the romega tactic *) Module IntOmega (I:Int). Import I. @@ -805,13 +774,16 @@ Module IP:=IntProperties(I). Import IP. Local Notation int := I.t. -(* \subsubsection{Definition of reified integer expressions} +(* ** Definition of reified integer expressions + Terms are either: - \begin{itemize} - \item integers [Tint] - \item variables [Tvar] - \item operation over integers (addition, product, opposite, subtraction) - The last two are translated in additions and products. *) + - integers [Tint] + - variables [Tvar] + - operation over integers (addition, product, opposite, subtraction) + + Opposite and subtraction are translated in additions and products. + Note that we'll only deal with products for which at least one side + is [Tint]. *) Inductive term : Set := | Tint : int -> term @@ -835,101 +807,53 @@ Infix "-" := Tminus : romega_scope. Notation "- x" := (Topp x) : romega_scope. Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope. -(* \subsubsection{Definition of reified goals} *) +(* ** Definition of reified goals -(* Very restricted definition of handled predicates that should be extended + Very restricted definition of handled predicates that should be extended to cover a wider set of operations. Taking care of negations and disequations require solving more than a goal in parallel. This is a major improvement over previous versions. *) Inductive proposition : Set := - | EqTerm : term -> term -> proposition (* equality between terms *) - | LeqTerm : term -> term -> proposition (* less or equal on terms *) - | TrueTerm : proposition (* true *) - | FalseTerm : proposition (* false *) - | Tnot : proposition -> proposition (* negation *) + (** First, basic equations, disequations, inequations *) + | EqTerm : term -> term -> proposition + | NeqTerm : term -> term -> proposition + | LeqTerm : term -> term -> proposition | GeqTerm : term -> term -> proposition | GtTerm : term -> term -> proposition | LtTerm : term -> term -> proposition - | NeqTerm : term -> term -> proposition + (** Then, the supported logical connectors *) + | TrueTerm : proposition + | FalseTerm : proposition + | Tnot : proposition -> proposition | Tor : proposition -> proposition -> proposition | Tand : proposition -> proposition -> proposition | Timp : proposition -> proposition -> proposition + (** Everything else is left as a propositional atom (and ignored). *) | Tprop : nat -> proposition. -(* Definition of goals as a list of hypothesis *) +(** Definition of goals as a list of hypothesis *) Notation hyps := (list proposition). -(* Definition of lists of subgoals (set of open goals) *) +(** Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). -(* a single goal packed in a subgoal list *) +(** A single goal packed in a subgoal list *) Notation singleton := (fun a : hyps => a :: nil). -(* an absurd goal *) +(** An absurd goal *) Definition absurd := FalseTerm :: nil. -(* \subsubsection{Omega steps} *) -(* The following inductive type describes steps as they can be found in - the trace coming from the decision procedure Omega. *) - -Inductive t_omega : Set := - (* n = 0 and n!= 0 *) - | O_CONSTANT_NOT_NUL : nat -> t_omega - | O_CONSTANT_NEG : nat -> t_omega - (* division and approximation of an equation *) - | O_DIV_APPROX : nat -> int -> int -> term -> t_omega -> t_omega - (* no solution because no exact division *) - | O_NOT_EXACT_DIVIDE : nat -> int -> int -> term -> t_omega - (* exact division *) - | O_EXACT_DIVIDE : nat -> int -> term -> t_omega -> t_omega - | O_SUM : int -> nat -> int -> nat -> t_omega -> t_omega - | O_CONTRADICTION : nat -> nat -> t_omega - | O_MERGE_EQ : nat -> nat -> t_omega -> t_omega - | O_SPLIT_INEQ : nat -> t_omega -> t_omega -> t_omega - | O_CONSTANT_NUL : nat -> t_omega - | O_NEGATE_CONTRADICT : nat -> nat -> t_omega - | O_NEGATE_CONTRADICT_INV : nat -> nat -> t_omega - | O_STATE : int -> nat -> nat -> t_omega -> t_omega. - -(* \subsubsection{Rules for decomposing the hypothesis} *) -(* This type allows navigation in the logical constructors that - form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a conjunction. - NB: negations are silently traversed. *) - -Inductive direction : Set := - | D_left : direction - | D_right : direction. - -(* This type allows extracting useful components from hypothesis, either - hypothesis generated by splitting a disjonction, or equations. - The last constructor indicates how to solve the obtained system - via the use of the trace type of Omega [t_omega] *) - -Inductive e_step : Set := - | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step - | E_EXTRACT : nat -> list direction -> e_step -> e_step - | E_SOLVE : t_omega -> e_step. - -(* \subsection{Efficient decidable equality} *) -(* For each reified data-type, we define an efficient equality test. - It is not the one produced by [Decide Equality]. - Then we prove the correctness of this test : - \begin{verbatim} - forall t1 t2 : term; eq_term t1 t2 = true <-> t1 = t2. - \end{verbatim} *) - -(* \subsubsection{Reified terms} *) +(** ** Decidable equality on terms *) Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := match t1, t2 with - | Tint st1, Tint st2 => beq st1 st2 - | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22 - | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22 - | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22 - | (- st1), (- st2) => eq_term st1 st2 - | [st1], [st2] => N.eqb st1 st2 + | Tint i1, Tint i2 => beq i1 i2 + | (t11 + t12), (t21 + t22) => eq_term t11 t21 && eq_term t12 t22 + | (t11 * t12), (t21 * t22) => eq_term t11 t21 && eq_term t12 t22 + | (t11 - t12), (t21 - t22) => eq_term t11 t21 && eq_term t12 t22 + | (- t1), (- t2) => eq_term t1 t2 + | [v1], [v2] => N.eqb v1 v2 | _, _ => false end%term. @@ -946,8 +870,7 @@ Proof. apply iff_reflect. symmetry. apply eq_term_iff. Qed. -(* \subsection{Interprétations} - \subsubsection{Interprétation des termes dans Z} *) +(** ** Interpretations of terms (as integers). *) Fixpoint Nnth {A} (n:N)(l:list A)(default:A) := match n, l with @@ -956,7 +879,7 @@ Fixpoint Nnth {A} (n:N)(l:list A)(default:A) := | _, _::l => Nnth (N.pred n) l default end. -Fixpoint interp_term (env : list int) (t : term) {struct t} : int := +Fixpoint interp_term (env : list int) (t : term) : int := match t with | Tint x => x | (t1 + t2)%term => interp_term env t1 + interp_term env t2 @@ -966,157 +889,128 @@ Fixpoint interp_term (env : list int) (t : term) {struct t} : int := | [n]%term => Nnth n env 0 end. -(* \subsubsection{Interprétation des prédicats} *) +(** ** Interpretation of predicats (as Coq propositions) *) -Fixpoint interp_proposition (envp : list Prop) (env : list int) - (p : proposition) {struct p} : Prop := +Fixpoint interp_prop (envp : list Prop) (env : list int) + (p : proposition) : Prop := match p with | EqTerm t1 t2 => interp_term env t1 = interp_term env t2 + | NeqTerm t1 t2 => (interp_term env t1) <> (interp_term env t2) | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2 - | TrueTerm => True - | FalseTerm => False - | Tnot p' => ~ interp_proposition envp env p' | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2 | GtTerm t1 t2 => interp_term env t1 > interp_term env t2 | LtTerm t1 t2 => interp_term env t1 < interp_term env t2 - | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2) - | Tor p1 p2 => - interp_proposition envp env p1 \/ interp_proposition envp env p2 - | Tand p1 p2 => - interp_proposition envp env p1 /\ interp_proposition envp env p2 - | Timp p1 p2 => - interp_proposition envp env p1 -> interp_proposition envp env p2 + | TrueTerm => True + | FalseTerm => False + | Tnot p' => ~ interp_prop envp env p' + | Tor p1 p2 => interp_prop envp env p1 \/ interp_prop envp env p2 + | Tand p1 p2 => interp_prop envp env p1 /\ interp_prop envp env p2 + | Timp p1 p2 => interp_prop envp env p1 -> interp_prop envp env p2 | Tprop n => nth n envp True end. -(* \subsubsection{Inteprétation des listes d'hypothèses} - \paragraph{Sous forme de conjonction} - Interprétation sous forme d'une conjonction d'hypothèses plus faciles - à manipuler individuellement *) +(** ** Intepretation of hypothesis lists (as Coq conjunctions) *) -Fixpoint interp_hyps (envp : list Prop) (env : list int) - (l : hyps) {struct l} : Prop := +Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) + : Prop := match l with | nil => True - | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' + | p' :: l' => interp_prop envp env p' /\ interp_hyps envp env l' end. -(* \paragraph{sous forme de but} - C'est cette interpétation que l'on utilise sur le but (car on utilise - [Generalize] et qu'une conjonction est forcément lourde (répétition des - types dans les conjonctions intermédiaires) *) +(** ** Interpretation of conclusion + hypotheses + + Here we use Coq implications : it's less easy to manipulate, + but handy to relate to the Coq original goal (cf. the use of + [generalize], and lighter (no repetition of types in intermediate + conjunctions). *) Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) - (env : list int) (l : hyps) {struct l} : Prop := + (env : list int) (l : hyps) : Prop := match l with - | nil => interp_proposition envp env c + | nil => interp_prop envp env c | p' :: l' => - interp_proposition envp env p' -> interp_goal_concl c envp env l' + interp_prop envp env p' -> interp_goal_concl c envp env l' end. Notation interp_goal := (interp_goal_concl FalseTerm). -(* Les théorèmes qui suivent assurent la correspondance entre les deux - interprétations. *) +(** Equivalence between these two interpretations. *) Theorem goal_to_hyps : forall (envp : list Prop) (env : list int) (l : hyps), (interp_hyps envp env l -> False) -> interp_goal envp env l. Proof. - simple induction l. - - simpl; auto. - - simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto. + induction l; simpl; auto. Qed. Theorem hyps_to_goal : forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. Proof. - simple induction l; simpl. - - auto. - - intros; apply H; elim H1; auto. -Qed. - -(* \subsection{Manipulations sur les hypothèses} *) - -(* \subsubsection{Définitions de base de stabilité pour la réflexion} *) -(* Une opération laisse un terme stable si l'égalité est préservée *) -Definition term_stable (f : term -> term) := - forall (e : list int) (t : term), interp_term e t = interp_term e (f t). - -(* Une opération est valide sur une hypothèse, si l'hypothèse implique le - résultat de l'opération. \emph{Attention : cela ne concerne que des - opérations sur les hypothèses et non sur les buts (contravariance)}. - On définit la validité pour une opération prenant une ou deux propositions - en argument (cela suffit pour omega). *) - -Definition valid1 (f : proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 : proposition), - interp_proposition ep e p1 -> interp_proposition ep e (f p1). - -Definition valid2 (f : proposition -> proposition -> proposition) := - forall (ep : list Prop) (e : list int) (p1 p2 : proposition), - interp_proposition ep e p1 -> - interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). - -(* Dans cette notion de validité, la fonction prend directement une - liste de propositions et rend une nouvelle liste de proposition. - On reste contravariant *) - -Definition valid_hyps (f : hyps -> hyps) := - forall (ep : list Prop) (e : list int) (lp : hyps), - interp_hyps ep e lp -> interp_hyps ep e (f lp). - -(* Enfin ce théorème élimine la contravariance et nous ramène à une - opération sur les buts *) - -Theorem valid_goal : - forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), - valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. -Proof. - intros; simpl; apply goal_to_hyps; intro H1; - apply (hyps_to_goal ep env (a l) H0); apply H; assumption. + induction l; simpl; auto. + intros H (H1,H2). auto. Qed. -(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) +(** ** Interpretations of list of goals + Here again, two flavours... *) Fixpoint interp_list_hyps (envp : list Prop) (env : list int) - (l : lhyps) {struct l} : Prop := + (l : lhyps) : Prop := match l with | nil => False | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' end. Fixpoint interp_list_goal (envp : list Prop) (env : list int) - (l : lhyps) {struct l} : Prop := + (l : lhyps) : Prop := match l with | nil => True | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l' end. +(** Equivalence between the two flavours. *) + Theorem list_goal_to_hyps : forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. Proof. - simple induction l; simpl. - - auto. - - intros h1 l1 H H1; split. - + apply goal_to_hyps; intro H2; apply H1; auto. - + apply H; intro H2; apply H1; auto. + induction l; simpl; intuition. now apply goal_to_hyps. Qed. Theorem list_hyps_to_goal : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. Proof. - simple induction l; simpl. - - auto. - - intros h1 l1 H (H1, H2) H3; elim H3; intro H4. - + apply hyps_to_goal with (1 := H1); assumption. - + auto. + induction l; simpl; intuition. eapply hyps_to_goal; eauto. Qed. +(** ** Stabiliy and validity of operations *) + +(** An operation on terms is stable if the interpretation is unchanged. *) + +Definition term_stable (f : term -> term) := + forall (e : list int) (t : term), interp_term e t = interp_term e (f t). + +(** An operation on one hypothesis is valid if this hypothesis implies + the result of this operation. *) + +Definition valid1 (f : proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 : proposition), + interp_prop ep e p1 -> interp_prop ep e (f p1). + +Definition valid2 (f : proposition -> proposition -> proposition) := + forall (ep : list Prop) (e : list int) (p1 p2 : proposition), + interp_prop ep e p1 -> + interp_prop ep e p2 -> interp_prop ep e (f p1 p2). + +(** Same for lists of hypotheses, and for list of goals *) + +Definition valid_hyps (f : hyps -> hyps) := + forall (ep : list Prop) (e : list int) (lp : hyps), + interp_hyps ep e lp -> interp_hyps ep e (f lp). + Definition valid_list_hyps (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_list_hyps ep e (f lp). @@ -1125,6 +1019,16 @@ Definition valid_list_goal (f : hyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_list_goal ep e (f lp) -> interp_goal ep e lp. +(** Some results about these validities. *) + +Theorem valid_goal : + forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), + valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. +Proof. + intros; simpl; apply goal_to_hyps; intro H1; + apply (hyps_to_goal ep env (a l) H0); apply H; assumption. +Qed. + Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. Proof. @@ -1146,21 +1050,23 @@ Proof. + right; apply IHl1; now right. Qed. -(* \subsubsection{Opérateurs valides sur les hypothèses} *) +(** ** Valid operations on hypotheses *) + +(** Extract an hypothesis from the list *) -(* Extraire une hypothèse de la liste *) Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm. Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), - interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). + interp_hyps ep e l -> interp_prop ep e (nth_hyps i l). Proof. unfold nth_hyps. induction i; destruct l; simpl in *; try easy. intros (H1,H2). now apply IHi. Qed. -(* Appliquer une opération (valide) sur deux hypothèses extraites de - la liste et ajouter le résultat à la liste. *) +(** Apply a valid operation on two hypotheses from the list, and + store the result in the list. *) + Definition apply_oper_2 (i j : nat) (f : proposition -> proposition -> proposition) (l : hyps) := f (nth_hyps i l) (nth_hyps j l) :: l. @@ -1175,12 +1081,13 @@ Proof. - assumption. Qed. -(* Modifier une hypothèse par application d'une opération valide *) +(** In-place modification of an hypothesis by application of + a valid operation. *) Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) (l : hyps) {struct i} : hyps := match l with - | nil => nil (A:=proposition) + | nil => nil | p :: l' => match i with | O => f p :: l' @@ -1192,20 +1099,11 @@ Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). Proof. - unfold valid_hyps; intros i f Hf ep e; elim i. - - intro lp; case lp. - + simpl; trivial. - + simpl; intros p l' (H1, H2); split. - * apply Hf with (1 := H1). - * assumption. - - intros n Hrec lp; case lp. - + simpl; auto. - + simpl; intros p l' (H1, H2); split. - * assumption. - * apply Hrec; assumption. + unfold valid_hyps. + induction i; intros f Hf ep e [ | p lp]; simpl; intuition. Qed. -(* \subsubsection{La tactique pour prouver la stabilité} *) +(** ** A tactic for proving stability *) Ltac loop t := match t with @@ -1215,7 +1113,7 @@ Ltac loop t := (* Interpretations *) | (interp_hyps _ _ ?X1) => loop X1 | (interp_list_hyps _ _ ?X1) => loop X1 - | (interp_proposition _ _ ?X1) => loop X1 + | (interp_prop _ _ ?X1) => loop X1 | (interp_term _ ?X1) => loop X1 (* Propositions *) | (EqTerm ?X1 ?X2) => loop X1 || loop X2 @@ -1250,11 +1148,23 @@ with Simplify := match goal with | _ => idtac end. -(* \subsubsection{Opérations affines sur une équation} *) +(** ** Operations on equation bodies *) + +(** The operations below handle in priority _normalized_ terms, i.e. + terms of the form: + [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))] + with [v1>v2>...] and all [ki<>0]. + See [normalize] below for a way to put terms in this form. + + These operations also produce a correct (but suboptimal) + result in case of non-normalized input terms, but this situation + should normally not happen when running [romega]. -(* \paragraph{Multiplication scalaire et somme d'une constante} *) + /!\ Do not modify this section (especially [fusion] and [normalize]) + without tweaking the corresponding functions in [refl_omega.ml]. +*) -(* invariant: k1<>0 *) +(** Multiplication and sum by two constants. Invariant: [k1<>0]. *) Fixpoint scalar_norm_add (t : term) (k1 k2 : int) : term := match t with @@ -1272,7 +1182,7 @@ Proof. rewrite <- IHt2. simpl. apply OMEGA11. Qed. -(* \paragraph{Multiplication scalaire} *) +(** Multiplication by a (non-nul) constant. *) Definition scalar_norm (t : term) (k : int) := scalar_norm_add t k 0. @@ -1283,7 +1193,7 @@ Proof. symmetry. apply plus_0_r. Qed. -(* \paragraph{Somme d'une constante} *) +(** Adding a constant *) Fixpoint add_norm (t : term) (k : int) : term := match t with @@ -1299,12 +1209,12 @@ Proof. rewrite <- IHt2. simpl. symmetry. apply plus_assoc. Qed. -(* \subsubsection{Fusions} - \paragraph{Fusion de deux équations} *) -(* On donne une somme de deux équations qui sont supposées normalisées. - Cette fonction prend une trace de fusion en argument et transforme - le terme en une équation normalisée. *) -(* Invariant : k1 and k2 non-null *) +(** Fusion of two equations. + + From two normalized equations, this fusion will produce + a normalized output corresponding to the coefficiented sum. + Invariant: [k1<>0] and [k2<>0]. +*) Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := match t1 with @@ -1321,7 +1231,7 @@ Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := | Gt => ([v1] * Tint (x1 * k1) + fusion l1 t2 k1 k2)%term end | Tint x2 => ([v1] * Tint (x1 * k1) + fusion l1 t2 k1 k2)%term - | _ => (t1 * Tint k1 + t2 * Tint k2)%term + | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) end) t2 | Tint x1 => scalar_norm_add t2 k2 (x1 * k1) | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) @@ -1342,11 +1252,11 @@ Proof. + rewrite <- IHt1_2. simpl. apply OMEGA11. Qed. -(* Main function of term normalization. +(** Term normalization. + Precondition: all [Tmult] should be on at least one [Tint]. - Postcondition: [([v1]*Tint k1 + ([v2]*Tint k2 + (... + Tint cst)))] - with [v1>v2>...] and [ki<>0]. - *) + Postcondition: a normalized equivalent term (see below). +*) Fixpoint normalize t := match t with @@ -1374,8 +1284,9 @@ Proof. - rewrite <- opp_eq_mult_neg_1. now f_equal. Qed. -(* \paragraph{Fusion avec annihilation} *) -(* Normalement le résultat est une constante *) +(** Fusion by cancellation. + Particular case of [fusion] where the final result should + be a constant. *) Fixpoint fusion_cancel (t1 t2 : term) : term := match t1, t2 with @@ -1396,10 +1307,208 @@ Proof. apply OMEGA13. Qed. -(* \subsection{tactiques de résolution d'un but omega normalisé} - Trace de la procédure -\subsubsection{Tactiques générant une contradiction} -\paragraph{[O_CONSTANT_NOT_NUL]} *) +(** ** Normalization of a proposition. + + The only basic facts left after normalization are + [0 = ...] or [0 <> ...] or [0 <= ...]. + When a fact is in negative position, we factorize a [Tnot] + out of it, and normalize the reversed fact inside. + + /!\ Here again, do not change this code without corresponding + modifications in [refl_omega.ml]. +*) + +Fixpoint normalize_prop (negated:bool)(p:proposition) := + match p with + | EqTerm t1 t2 => + if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2))) + else EqTerm (Tint 0) (normalize (t1-t2)) + | NeqTerm t1 t2 => + if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2))) + else NeqTerm (Tint 0) (normalize (t1-t2)) + | LeqTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))) + else LeqTerm (Tint 0) (normalize (t2-t1)) + | GeqTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))) + else LeqTerm (Tint 0) (normalize (t1-t2)) + | LtTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2))) + else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))) + | GtTerm t1 t2 => + if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1))) + else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))) + | Tnot p => Tnot (normalize_prop (negb negated) p) + | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p') + | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p') + | Timp p p' => Timp (normalize_prop (negb negated) p) + (normalize_prop negated p') + | Tprop _ | TrueTerm | FalseTerm => p + end. + +Definition normalize_hyps := List.map (normalize_prop false). + +Opaque normalize. + +Theorem normalize_prop_valid b e ep p : + interp_prop e ep p <-> + interp_prop e ep (normalize_prop b p). +Proof. + revert b. + induction p; intros; simpl; try tauto. + - destruct b; simpl; + rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. + + rewrite not_eq. apply egal_left_iff. + + apply egal_left_iff. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def; + apply not_iff_compat, egal_left_iff. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite le_lt_iff. apply not_iff_compat. + rewrite le_lt_int. rewrite le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + + apply le_left. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite ge_le_iff, le_lt_iff. apply not_iff_compat. + rewrite le_lt_int. rewrite le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + + rewrite ge_le_iff. apply le_left. + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. + apply le_left. + + rewrite gt_lt_iff. rewrite le_lt_int. rewrite le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + - destruct b; simpl; + rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + + rewrite lt_le_iff. apply not_iff_compat. + apply le_left. + + rewrite le_lt_int, le_left. + rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). + - now rewrite <- IHp. + - now rewrite <- IHp1, <- IHp2. + - now rewrite <- IHp1, <- IHp2. + - now rewrite <- IHp1, <- IHp2. +Qed. + +Transparent normalize. + +Theorem normalize_hyps_valid : valid_hyps normalize_hyps. +Proof. + intros e ep l. induction l; simpl; intuition. + now rewrite <- normalize_prop_valid. +Qed. + +Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : + interp_goal ep env (normalize_hyps l) -> interp_goal ep env l. +Proof. + intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. +Qed. + +(** ** A simple decidability checker + + For us, everything is considered decidable except + propositional atoms [Tprop _]. *) + +Fixpoint decidability (p : proposition) : bool := + match p with + | Tnot t => decidability t + | Tand t1 t2 => decidability t1 && decidability t2 + | Timp t1 t2 => decidability t1 && decidability t2 + | Tor t1 t2 => decidability t1 && decidability t2 + | Tprop _ => false + | _ => true + end. + +Theorem decidable_correct : + forall (ep : list Prop) (e : list int) (p : proposition), + decidability p = true -> decidable (interp_prop ep e p). +Proof. + induction p; simpl; intros Hp; try destruct (andb_prop _ _ Hp). + - apply dec_eq. + - apply dec_ne. + - apply dec_le. + - apply dec_ge. + - apply dec_gt. + - apply dec_lt. + - left; auto. + - right; unfold not; auto. + - apply dec_not; auto. + - apply dec_or; auto. + - apply dec_and; auto. + - apply dec_imp; auto. + - discriminate. +Qed. + +(** ** Omega steps + + The following inductive type describes steps as they can be + found in the trace coming from the decision procedure Omega. + We consider here only normalized equations [0=...], disequations + [0<>...] or inequations [0<=...]. + + First, the final steps leading to a contradiction: + - [O_CONSTANT_NOT_NUL i] : + equation i is [0=k] with a non-nul constant [k]. + - [O_CONSTANT_NUL i] : disequation i is [0<>0]. + - [O_CONSTANT_NEG i] : + inequation i is [0<=k] with a negative constant [k]. + - [O_CONTRADICTION i j] : + inequations i and j have a sum which is a negative constant. + Shortcut for [(O_SUM 1 i 1 j (O_CONSTANT_NEG 0))]. + - [O_NEGATE_CONTRADICT i j] : + equation i and disequation j (or vice-versa) have the same body. + Shortcut for [(O_SUM 1 i (-1) j (O_CONSTANT_NUL 0))]. + - [O_NEGATE_CONTRADICT_INV i j] : + equation i and disequation j (or vice-versa) have opposite bodies. + Shortcut for [(O_SUM 1 i 1 j (O_CONSTANT_NUL 0))]. + - [O_NOT_EXACT_DIVIDE i k1 k2 t] : + equation i has a body equivalent to [k1*t+k2] with [00], + we change it (in-place) for (dis)equation [0=t]. + - [O_DIV_APPROX i k1 k2 t cont] : + inequation i has a body equivalent to [k1*t+k2] with [0 t_omega + | O_CONSTANT_NUL : idx -> t_omega + | O_CONSTANT_NEG : idx -> t_omega + | O_CONTRADICTION : idx -> idx -> t_omega + | O_NEGATE_CONTRADICT : idx -> idx -> t_omega + | O_NEGATE_CONTRADICT_INV : idx -> idx -> t_omega + | O_NOT_EXACT_DIVIDE : idx -> int -> int -> term -> t_omega + + | O_EXACT_DIVIDE : idx -> int -> term -> t_omega -> t_omega + | O_DIV_APPROX : idx -> int -> int -> term -> t_omega -> t_omega + | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega + | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega + | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega + | O_STATE : int -> idx -> idx -> t_omega -> t_omega. + +(** ** Actual resolution steps of an omega normalized goal *) + +(** First, the final steps, leading to a contradiction *) + +(** [O_CONSTANT_NOT_NUL] *) Definition constant_not_nul (i : nat) (h : hyps) := match nth_hyps i h with @@ -1415,7 +1524,22 @@ Proof. generalize (nth_valid ep e i lp H); Simplify. Qed. -(* \paragraph{[O_CONSTANT_NEG]} *) +(** [O_CONSTANT_NUL] *) + +Definition constant_nul (i : nat) (h : hyps) := + match nth_hyps i h with + | NeqTerm (Tint Null) (Tint Null') => + if beq Null Null' then absurd else h + | _ => h + end. + +Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). +Proof. + unfold valid_hyps, constant_nul; intros; + generalize (nth_valid ep e i lp); Simplify; simpl; intuition. +Qed. + +(** [O_CONSTANT_NEG] *) Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with @@ -1431,34 +1555,7 @@ Proof. rewrite gt_lt_iff in *; rewrite le_lt_iff; intuition. Qed. -(* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (i : nat) (k1 k2 : int) (body : term) - (l : hyps) := - match nth_hyps i l with - | EqTerm (Tint Nul) b => - if beq Nul 0 && - eq_term (scalar_norm_add body k1 k2) b && - bgt k2 0 && - bgt k1 k2 - then absurd - else l - | _ => l - end. - -Theorem not_exact_divide_valid : - forall (i : nat)(k1 k2 : int) (body : term), - valid_hyps (not_exact_divide i k1 k2 body). -Proof. - unfold valid_hyps, not_exact_divide; intros. - generalize (nth_valid ep e i lp); Simplify. - rewrite <-H1, <-scalar_norm_add_stable. simpl. - intros. - absurd (interp_term e body * k1 + k2 = 0). - - now apply OMEGA4. - - symmetry; auto. -Qed. - -(* \paragraph{[O_CONTRADICTION]} *) +(** [O_CONTRADICTION] *) Definition contradiction (i j : nat) (l : hyps) := match nth_hyps i l with @@ -1493,7 +1590,7 @@ Proof. rewrite gt_lt_iff in *; rewrite le_lt_iff. intuition. Qed. -(* \paragraph{[O_NEGATE_CONTRADICT]} *) +(** [O_NEGATE_CONTRADICT] *) Definition negate_contradict (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with @@ -1516,6 +1613,19 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) := | _ => h end. +Theorem negate_contradict_valid : + forall i j : nat, valid_hyps (negate_contradict i j). +Proof. + unfold valid_hyps, negate_contradict; intros i j ep e l H; + generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; + auto; simpl; intros; Simplify. +Qed. + +(** [O_NEGATE_CONTRADICT_INV] *) + Definition negate_contradict_inv (i1 i2 : nat) (h : hyps) := match nth_hyps i1 h with | EqTerm (Tint Nul) b1 => @@ -1539,17 +1649,6 @@ Definition negate_contradict_inv (i1 i2 : nat) (h : hyps) := | _ => h end. -Theorem negate_contradict_valid : - forall i j : nat, valid_hyps (negate_contradict i j). -Proof. - unfold valid_hyps, negate_contradict; intros i j ep e l H; - generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros; Simplify. -Qed. - Theorem negate_contradict_inv_valid : forall i j : nat, valid_hyps (negate_contradict_inv i j). Proof. @@ -1567,83 +1666,48 @@ Proof. now rewrite <- H2, mult_0_l. Qed. -(* \subsubsection{Tactiques générant une nouvelle équation} *) -(* \paragraph{[O_SUM]} - C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant - les opérateurs de comparaison des deux arguments) d'où une - preuve un peu compliquée. On utilise quelques lemmes qui sont des - généralisations des théorèmes utilisés par OMEGA. *) +(** [NOT_EXACT_DIVIDE] *) -Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint Null) b1 => - match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 - then EqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - | LeqTerm (Tint Null) b1 => - if beq Null 0 && bgt k1 0 - then match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null' 0 then - LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null' 0 && bgt k2 0 - then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - else TrueTerm - | NeqTerm (Tint Null) b1 => - match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && (negb (beq k1 0)) - then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm +Definition not_exact_divide (i : nat) (k1 k2 : int) (body : term) + (l : hyps) := + match nth_hyps i l with + | EqTerm (Tint Nul) b => + if beq Nul 0 && + eq_term (scalar_norm_add body k1 k2) b && + bgt k2 0 && + bgt k1 k2 + then absurd + else l + | _ => l end. - -Theorem sum_valid : - forall (k1 k2 : int), valid2 (sum k1 k2). +Theorem not_exact_divide_valid : + forall (i : nat)(k1 k2 : int) (body : term), + valid_hyps (not_exact_divide i k1 k2 body). Proof. - unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; - Simplify; simpl; rewrite <- ?fusion_stable; - simpl; intros; auto. - - apply sum1; assumption. - - apply sum2; try assumption; apply sum4; assumption. - - rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption. - - apply sum3; try assumption; apply sum4; assumption. - - apply sum5; auto. + unfold valid_hyps, not_exact_divide; intros. + generalize (nth_valid ep e i lp); Simplify. + rewrite <-H1, <-scalar_norm_add_stable. simpl. + intros. + absurd (interp_term e body * k1 + k2 = 0). + - now apply OMEGA4. + - symmetry; auto. Qed. -(* \paragraph{[O_EXACT_DIVIDE]} - c'est une oper1 valide mais on préfère une substitution a ce point la *) +(** Now, the steps generating a new equation. *) + +(** [O_EXACT_DIVIDE] *) Definition exact_divide (k : int) (body : term) (prop : proposition) := match prop with | EqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm body k) b && - negb (beq k 0) - then EqTerm (Tint 0) body - else TrueTerm + if beq Null 0 && eq_term (scalar_norm body k) b && negb (beq k 0) + then EqTerm (Tint 0) body + else TrueTerm | NeqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm body k) b && - negb (beq k 0) - then NeqTerm (Tint 0) body - else TrueTerm + if beq Null 0 && eq_term (scalar_norm body k) b && negb (beq k 0) + then NeqTerm (Tint 0) body + else TrueTerm | _ => TrueTerm end. @@ -1657,10 +1721,7 @@ Proof. - contradict H0; rewrite <- H0, mult_0_l; auto. Qed. - -(* \paragraph{[O_DIV_APPROX]} - La preuve reprend le schéma de la précédente mais on - est sur une opération de type valid1 et non sur une opération terminale. *) +(** [O_DIV_APPROX] *) Definition divide_and_approx (k1 k2 : int) (body : term) (prop : proposition) := @@ -1685,73 +1746,87 @@ Proof. intro H; now apply mult_le_approx with (3 := H). Qed. -(* \paragraph{[MERGE_EQ]} *) +(** [O_SUM]. Invariant: [k1] and [k2] non-nul. *) -Definition merge_eq (prop1 prop2 : proposition) := +Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := match prop1 with - | LeqTerm (Tint Null) b1 => + | EqTerm (Tint Null) b1 => match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 + then EqTerm (Tint 0) (fusion b1 b2 k1 k2) + else TrueTerm | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm b2 (-(1))) - then EqTerm (Tint 0) b1 + if beq Null 0 && beq Null' 0 && bgt k2 0 + then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) + else TrueTerm + | NeqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && negb (beq k2 0) + then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) + else TrueTerm + | _ => TrueTerm + end + | LeqTerm (Tint Null) b1 => + if beq Null 0 && bgt k1 0 + then match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null' 0 then + LeqTerm (Tint 0) (fusion b1 b2 k1 k2) + else TrueTerm + | LeqTerm (Tint Null') b2 => + if beq Null' 0 && bgt k2 0 + then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) + else TrueTerm + | _ => TrueTerm + end + else TrueTerm + | NeqTerm (Tint Null) b1 => + match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && negb (beq k1 0) + then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. -Theorem merge_eq_valid : valid2 merge_eq. -Proof. - unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. - rewrite <- scalar_norm_stable. simpl. - intros; symmetry ; apply OMEGA8 with (2 := H0). - - assumption. - - elim opp_eq_mult_neg_1; trivial. -Qed. - - -(* \paragraph{[O_CONSTANT_NUL]} *) - -Definition constant_nul (i : nat) (h : hyps) := - match nth_hyps i h with - | NeqTerm (Tint Null) (Tint Null') => - if beq Null Null' then absurd else h - | _ => h - end. - -Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). +Theorem sum_valid : + forall (k1 k2 : int), valid2 (sum k1 k2). Proof. - unfold valid_hyps, constant_nul; intros; - generalize (nth_valid ep e i lp); Simplify; simpl; intuition. + unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; + Simplify; simpl; rewrite <- ?fusion_stable; + simpl; intros; auto using sum1, sum2, sum3, sum4, sum5. + - rewrite plus_comm. now apply sum5. + - rewrite plus_comm. apply sum2; trivial; now apply sum4. Qed. -(* \paragraph{[O_STATE]} *) +(** [MERGE_EQ] *) -Definition state (m : int) (prop1 prop2 : proposition) := +Definition merge_eq (prop1 prop2 : proposition) := match prop1 with - | EqTerm (Tint Null) b1 => + | LeqTerm (Tint Null) b1 => match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 - then EqTerm (Tint 0) (fusion b1 b2 1 m) + | LeqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 && + eq_term b1 (scalar_norm b2 (-(1))) + then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm end | _ => TrueTerm end. -Theorem state_valid : forall (m : int), valid2 (state m). +Theorem merge_eq_valid : valid2 merge_eq. Proof. - unfold valid2; intros m ep e p1 p2. - unfold state; Simplify; simpl; auto. - rewrite <- fusion_stable. simpl in *. intros H H'. - rewrite <- H, <- H'. now rewrite !mult_0_l, plus_0_l. + unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. + rewrite <- scalar_norm_stable. simpl. + intros; symmetry ; apply OMEGA8 with (2 := H0). + - assumption. + - elim opp_eq_mult_neg_1; trivial. Qed. -(* \subsubsection{Tactiques générant plusieurs but} - \paragraph{[O_SPLIT_INEQ]} - La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) +(** [O_SPLIT_INEQ] (only step to produce two subgoals). *) Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with @@ -1783,213 +1858,114 @@ Proof. Qed. -(* \subsection{Replaying the resolution trace} *) +(** [O_STATE] *) + +Definition state (m : int) (prop1 prop2 : proposition) := + match prop1 with + | EqTerm (Tint Null) b1 => + match prop2 with + | EqTerm (Tint Null') b2 => + if beq Null 0 && beq Null' 0 + then EqTerm (Tint 0) (fusion b1 b2 1 m) + else TrueTerm + | _ => TrueTerm + end + | _ => TrueTerm + end. + +Theorem state_valid : forall (m : int), valid2 (state m). +Proof. + unfold valid2; intros m ep e p1 p2. + unfold state; Simplify; simpl; auto. + rewrite <- fusion_stable. simpl in *. intros H H'. + rewrite <- H, <- H'. now rewrite !mult_0_l, plus_0_l. +Qed. + +(** ** Replaying the resolution trace *) Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) + | O_CONSTANT_NUL i => singleton (constant_nul i l) | O_CONSTANT_NEG n => singleton (constant_neg n l) - | O_DIV_APPROX n k1 k2 body cont => - execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body) l) + | O_CONTRADICTION i j => singleton (contradiction i j l) + | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) + | O_NEGATE_CONTRADICT_INV i j => + singleton (negate_contradict_inv i j l) | O_NOT_EXACT_DIVIDE i k1 k2 body => singleton (not_exact_divide i k1 k2 body l) | O_EXACT_DIVIDE n k body cont => execute_omega cont (apply_oper_1 n (exact_divide k body) l) + | O_DIV_APPROX n k1 k2 body cont => + execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body) l) | O_SUM k1 i1 k2 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l) - | O_CONTRADICTION i j => singleton (contradiction i j l) | O_MERGE_EQ i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 merge_eq l) | O_SPLIT_INEQ i cont1 cont2 => split_ineq i (execute_omega cont1) (execute_omega cont2) l - | O_CONSTANT_NUL i => singleton (constant_nul i l) - | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) - | O_NEGATE_CONTRADICT_INV i j => - singleton (negate_contradict_inv i j l) | O_STATE m i1 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (state m) l) end. Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. - simple induction tr; simpl. - - unfold valid_list_hyps; simpl; intros; left; - apply (constant_not_nul_valid n ep e lp H). - - unfold valid_list_hyps; simpl; intros; left; - apply (constant_neg_valid n ep e lp H). - - unfold valid_list_hyps, valid_hyps; - intros m k1 k2 body t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (divide_and_approx k1 k2 body) - (divide_and_approx_valid k1 k2 body) ep e lp H). - - unfold valid_list_hyps; simpl; intros; left; - apply (not_exact_divide_valid _ _ _ _ ep e lp H). - - unfold valid_list_hyps, valid_hyps; - intros m k body t' Ht' ep e lp H; apply Ht'; + simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. + - intros; left; now apply constant_not_nul_valid. + - intros; left; now apply constant_nul_valid. + - intros; left; now apply constant_neg_valid. + - intros; left; now apply contradiction_valid. + - intros; left; now apply negate_contradict_valid. + - intros; left; now apply negate_contradict_inv_valid. + - intros; left; now apply not_exact_divide_valid. + + - intros m k body t' Ht' ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body) (exact_divide_valid k body) ep e lp H). - - unfold valid_list_hyps, valid_hyps; - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; + - intros m k1 k2 body t' Ht' ep e lp H; apply Ht'; + apply + (apply_oper_1_valid m (divide_and_approx k1 k2 body) + (divide_and_approx_valid k1 k2 body) ep e lp H). + - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e lp H). - - unfold valid_list_hyps; simpl; intros; left. - apply (contradiction_valid n n0 ep e lp H). - - unfold valid_list_hyps, valid_hyps; - intros i1 i2 t' Ht' ep e lp H; apply Ht'; + - intros i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 merge_eq merge_eq_valid ep e lp H). - - intros i k1 H1 k2 H2; unfold valid_list_hyps; simpl; - intros ep e lp H; + - intros i k1 H1 k2 H2 ep e lp H; apply (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e lp H). - - unfold valid_list_hyps; simpl; intros i ep e lp H; left; - apply (constant_nul_valid i ep e lp H). - - unfold valid_list_hyps; simpl; intros i j ep e lp H; left; - apply (negate_contradict_valid i j ep e lp H). - - unfold valid_list_hyps; simpl; intros i j ep e lp H; - left; apply (negate_contradict_inv_valid i j ep e lp H). - - unfold valid_list_hyps, valid_hyps; - intros m i1 i2 t' Ht' ep e lp H; apply Ht'; + - intros m i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (state m) (state_valid m) ep e lp H). Qed. -(* \subsection{Les opérations globales sur le but} - \subsubsection{Normalisation} *) -Fixpoint normalize_prop (negated:bool)(p:proposition) := - match p with - | EqTerm t1 t2 => - if negated then Tnot (NeqTerm (Tint 0) (normalize (t1-t2))) - else EqTerm (Tint 0) (normalize (t1-t2)) - | NeqTerm t1 t2 => - if negated then Tnot (EqTerm (Tint 0) (normalize (t1-t2))) - else NeqTerm (Tint 0) (normalize (t1-t2)) - | LeqTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1))))) - else LeqTerm (Tint 0) (normalize (t2-t1)) - | GeqTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1))))) - else LeqTerm (Tint 0) (normalize (t1-t2)) - | LtTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t1-t2))) - else LeqTerm (Tint 0) (normalize (t2-t1+Tint (-(1)))) - | GtTerm t1 t2 => - if negated then Tnot (LeqTerm (Tint 0) (normalize (t2-t1))) - else LeqTerm (Tint 0) (normalize (t1-t2+Tint (-(1)))) - | Tnot p => Tnot (normalize_prop (negb negated) p) - | Tor p p' => Tor (normalize_prop negated p) (normalize_prop negated p') - | Tand p p' => Tand (normalize_prop negated p) (normalize_prop negated p') - | Timp p p' => Timp (normalize_prop (negb negated) p) - (normalize_prop negated p') - | Tprop _ | TrueTerm | FalseTerm => p - end. - -Definition normalize_hyps := List.map (normalize_prop false). +(** ** Rules for decomposing the hypothesis -Opaque normalize. - -Theorem normalize_prop_valid b e ep p : - interp_proposition e ep p <-> - interp_proposition e ep (normalize_prop b p). -Proof. - revert b. - induction p; intros; simpl; try tauto. - - destruct b; simpl; - rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. - + rewrite not_eq. apply egal_left_iff. - + apply egal_left_iff. - - destruct b; simpl; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite le_lt_iff. apply not_iff_compat. - rewrite le_lt_int. rewrite le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - + apply le_left. - - now rewrite <- IHp. - - destruct b; simpl; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite ge_le_iff, le_lt_iff. apply not_iff_compat. - rewrite le_lt_int. rewrite le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - + rewrite ge_le_iff. apply le_left. - - destruct b; simpl; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. - apply le_left. - + rewrite gt_lt_iff. rewrite le_lt_int. rewrite le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - - destruct b; simpl; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite lt_le_iff. apply not_iff_compat. - apply le_left. - + rewrite le_lt_int, le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - - destruct b; simpl; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def; - apply not_iff_compat, egal_left_iff. - - now rewrite <- IHp1, <- IHp2. - - now rewrite <- IHp1, <- IHp2. - - now rewrite <- IHp1, <- IHp2. -Qed. - -Transparent normalize. - -Theorem normalize_hyps_valid : valid_hyps normalize_hyps. -Proof. - intros e ep l. induction l; simpl; intuition. - now rewrite <- normalize_prop_valid. -Qed. + This type allows navigation in the logical constructors that + form the predicats of the hypothesis in order to decompose them. + This allows in particular to extract one hypothesis from a conjunction. + NB: negations are now silently traversed. *) -Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : - interp_goal ep env (normalize_hyps l) -> interp_goal ep env l. -Proof. - intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. -Qed. +Inductive direction : Set := + | D_left : direction + | D_right : direction. -(* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by - induction and uses well known theorem about arithmetic and propositional - calculus *) +(** This type allows extracting useful components from hypothesis, either + hypothesis generated by splitting a disjonction, or equations. + The last constructor indicates how to solve the obtained system + via the use of the trace type of Omega [t_omega] *) -Fixpoint decidability (p : proposition) : bool := - match p with - | EqTerm _ _ => true - | LeqTerm _ _ => true - | GeqTerm _ _ => true - | GtTerm _ _ => true - | LtTerm _ _ => true - | NeqTerm _ _ => true - | FalseTerm => true - | TrueTerm => true - | Tnot t => decidability t - | Tand t1 t2 => decidability t1 && decidability t2 - | Timp t1 t2 => decidability t1 && decidability t2 - | Tor t1 t2 => decidability t1 && decidability t2 - | Tprop _ => false - end. +Inductive e_step : Set := + | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step + | E_EXTRACT : nat -> list direction -> e_step -> e_step + | E_SOLVE : t_omega -> e_step. -Theorem decidable_correct : - forall (ep : list Prop) (e : list int) (p : proposition), - decidability p = true -> decidable (interp_proposition ep e p). -Proof. - simple induction p; simpl; intros. - - apply dec_eq. - - apply dec_le. - - left; auto. - - right; unfold not; auto. - - apply dec_not; auto. - - apply dec_ge. - - apply dec_gt. - - apply dec_lt. - - apply dec_ne. - - apply dec_or; elim andb_prop with (1 := H1); auto. - - apply dec_and; elim andb_prop with (1 := H1); auto. - - apply dec_imp; elim andb_prop with (1 := H1); auto. - - discriminate H. -Qed. +(** Selection of a basic fact inside an hypothesis. *) Fixpoint extract_hyp_pos (s : list direction) (p : proposition) : proposition := @@ -2016,10 +1992,10 @@ Theorem extract_valid : forall s : list direction, valid1 (extract_hyp_pos s). Proof. assert (forall p s ep e, - (interp_proposition ep e p -> - interp_proposition ep e (extract_hyp_pos s p)) /\ - (interp_proposition ep e (Tnot p) -> - interp_proposition ep e (extract_hyp_neg s p))). + (interp_prop ep e p -> + interp_prop ep e (extract_hyp_pos s p)) /\ + (interp_prop ep e (Tnot p) -> + interp_prop ep e (extract_hyp_neg s p))). { induction p; destruct s; simpl; auto; split; try destruct d; try easy; intros; (apply IHp || apply IHp1 || apply IHp2 || idtac); simpl; try tauto; destruct decidability eqn:D; auto; @@ -2032,7 +2008,9 @@ Qed. NB: [interp_list_goal _ _ BUG = False /\ True]. *) Definition BUG : lhyps := nil :: nil. -Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := +(** Split and extract in hypotheses *) + +Fixpoint decompose_solve (s : e_step) (h : hyps) : lhyps := match s with | E_SPLIT i dl s1 s2 => match extract_hyp_pos dl (nth_hyps i h) with @@ -2058,7 +2036,7 @@ Theorem decompose_solve_valid (s : e_step) : valid_list_goal (decompose_solve s). Proof. apply goal_valid. red. induction s; simpl; intros ep e lp H. - - assert (H' : interp_proposition ep e (extract_hyp_pos l (nth_hyps n lp))). + - assert (H' : interp_prop ep e (extract_hyp_pos l (nth_hyps n lp))). { now apply extract_valid, nth_valid. } destruct extract_hyp_pos; simpl in *; auto. + destruct p; simpl; auto. @@ -2080,7 +2058,7 @@ Proof. - now apply omega_valid. Qed. -(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *) +(** Reduction of subgoal list by discarding the contradictory subgoals. *) Definition valid_lhyps (f : lhyps -> lhyps) := forall (ep : list Prop) (e : list int) (lp : lhyps), @@ -2111,6 +2089,8 @@ Proof. assumption. Qed. +(** Pushing the conclusion into the hypotheses. *) + Definition concl_to_hyp (p : proposition) := if decidability p then Tnot p else TrueTerm. @@ -2127,6 +2107,8 @@ Proof. - simpl in *; tauto. Qed. +(** The omega tactic : all steps together *) + Definition omega_tactic (t1 : e_step) (c : proposition) (l : hyps) := reduce_lhyps (decompose_solve t1 (normalize_hyps (concl_to_hyp c :: l))). @@ -2145,7 +2127,7 @@ Qed. End IntOmega. -(* For now, the above modular construction is instanciated on Z, - in order to retrieve the initial ROmega. *) +(** For now, the above modular construction is instanciated on Z, + in order to retrieve the initial ROmega. *) Module ZOmega := IntOmega(Z_as_Int). -- cgit v1.2.3 From eae11e85b5fe578fbec404b91628062aa255be92 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 17 May 2017 12:33:50 +0200 Subject: ReflOmegaCore: reverse some integer mult (coefs k1,k2 will often be simple) --- plugins/romega/ReflOmegaCore.v | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 2a0705b3d..0476c385c 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1170,7 +1170,7 @@ Fixpoint scalar_norm_add (t : term) (k1 k2 : int) : term := match t with | (v1 * Tint x1 + l1)%term => (v1 * Tint (x1 * k1) + scalar_norm_add l1 k1 k2)%term - | Tint x => Tint (x * k1 + k2) + | Tint x => Tint (k1 * x + k2) | _ => (t * Tint k1 + Tint k2)%term (* shouldn't happen *) end. @@ -1178,7 +1178,7 @@ Theorem scalar_norm_add_stable e t k1 k2 : interp_term e (t * Tint k1 + Tint k2)%term = interp_term e (scalar_norm_add t k1 k2). Proof. - induction t; simpl; Simplify; simpl; auto. + induction t; simpl; Simplify; simpl; auto. f_equal. apply mult_comm. rewrite <- IHt2. simpl. apply OMEGA11. Qed. @@ -1224,16 +1224,16 @@ Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := | ([v2] * Tint x2 + l2)%term => match N.compare v1 v2 with | Eq => - let k := x1 * k1 + x2 * k2 in + let k := k1 * x1 + k2 * x2 in if beq k 0 then fusion l1 l2 k1 k2 else ([v1] * Tint k + fusion l1 l2 k1 k2)%term - | Lt => ([v2] * Tint (x2 * k2) + fusion_t1 l2)%term - | Gt => ([v1] * Tint (x1 * k1) + fusion l1 t2 k1 k2)%term + | Lt => ([v2] * Tint (k2 * x2) + fusion_t1 l2)%term + | Gt => ([v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2)%term end - | Tint x2 => ([v1] * Tint (x1 * k1) + fusion l1 t2 k1 k2)%term + | Tint x2 => ([v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2)%term | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) end) t2 - | Tint x1 => scalar_norm_add t2 k2 (x1 * k1) + | Tint x1 => scalar_norm_add t2 k2 (k1 * x1) | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) end. @@ -1242,14 +1242,18 @@ Theorem fusion_stable e t1 t2 k1 k2 : interp_term e (fusion t1 t2 k1 k2). Proof. revert t2; induction t1; simpl; Simplify; simpl; auto. - - intros; rewrite <- scalar_norm_add_stable. simpl. apply plus_comm. + - intros; rewrite <- scalar_norm_add_stable. simpl. + rewrite plus_comm. f_equal. apply mult_comm. - intros. Simplify. induction t2; simpl; Simplify; simpl; auto. - + rewrite <- IHt1_2. simpl. apply OMEGA11. - + rewrite <- IHt1_2. simpl. subst n0. rewrite OMEGA10, H0. - now rewrite mult_comm, mult_0_l, plus_0_l. - + rewrite <- IHt1_2. simpl. subst n0. apply OMEGA10. - + rewrite <- IHt2_2. simpl. apply OMEGA12. - + rewrite <- IHt1_2. simpl. apply OMEGA11. + + rewrite <- IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. + + rewrite <- IHt1_2. simpl. subst n0. + rewrite (mult_comm k1), (mult_comm k2) in H0. + rewrite OMEGA10, H0. + now rewrite mult_0_r, plus_0_l. + + rewrite <- IHt1_2. simpl. subst n0. + rewrite (mult_comm k1), (mult_comm k2); apply OMEGA10. + + rewrite <- IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12. + + rewrite <- IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. Qed. (** Term normalization. -- cgit v1.2.3 From 7509f5c8eab84fda5a9029329c6b70758259765f Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 17 May 2017 13:39:59 +0200 Subject: ROmega : merge O_CONSTANT* into a single O_BAD_CONSTANT --- plugins/omega/omega.ml | 4 -- plugins/romega/ReflOmegaCore.v | 71 +++++---------------- plugins/romega/const_omega.ml | 4 +- plugins/romega/const_omega.mli | 4 +- plugins/romega/refl_omega.ml | 136 ++++++++++++++++++----------------------- 5 files changed, 77 insertions(+), 142 deletions(-) (limited to 'plugins') diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 334b03de1..f655c176f 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -587,10 +587,6 @@ let rec depend relie_on accu = function end | [] -> relie_on, accu -let solve (new_eq_id,new_eq_var,print_var) system = - try let _ = simplify new_eq_id false system in failwith "no contradiction" - with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) - let negation (eqs,ineqs) = let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 0476c385c..057752271 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1454,20 +1454,17 @@ Qed. [0<>...] or inequations [0<=...]. First, the final steps leading to a contradiction: - - [O_CONSTANT_NOT_NUL i] : - equation i is [0=k] with a non-nul constant [k]. - - [O_CONSTANT_NUL i] : disequation i is [0<>0]. - - [O_CONSTANT_NEG i] : - inequation i is [0<=k] with a negative constant [k]. + - [O_BAD_CONSTANT i] : hypothesis i has a constant body + and this constant is not compatible with the kind of i. - [O_CONTRADICTION i j] : inequations i and j have a sum which is a negative constant. - Shortcut for [(O_SUM 1 i 1 j (O_CONSTANT_NEG 0))]. + Shortcut for [(O_SUM 1 i 1 j (O_BAD_CONSTANT 0))]. - [O_NEGATE_CONTRADICT i j] : equation i and disequation j (or vice-versa) have the same body. - Shortcut for [(O_SUM 1 i (-1) j (O_CONSTANT_NUL 0))]. + Shortcut for [(O_SUM 1 i (-1) j (O_BAD_CONSTANT 0))]. - [O_NEGATE_CONTRADICT_INV i j] : equation i and disequation j (or vice-versa) have opposite bodies. - Shortcut for [(O_SUM 1 i 1 j (O_CONSTANT_NUL 0))]. + Shortcut for [(O_SUM 1 i 1 j (O_BAD_CONSTANT 0))]. - [O_NOT_EXACT_DIVIDE i k1 k2 t] : equation i has a body equivalent to [k1*t+k2] with [0 t_omega - | O_CONSTANT_NUL : idx -> t_omega - | O_CONSTANT_NEG : idx -> t_omega + | O_BAD_CONSTANT : idx -> t_omega | O_CONTRADICTION : idx -> idx -> t_omega | O_NEGATE_CONTRADICT : idx -> idx -> t_omega | O_NEGATE_CONTRADICT_INV : idx -> idx -> t_omega @@ -1512,51 +1507,21 @@ Inductive t_omega : Set := (** First, the final steps, leading to a contradiction *) -(** [O_CONSTANT_NOT_NUL] *) +(** [O_BAD_CONSTANT] *) -Definition constant_not_nul (i : nat) (h : hyps) := +Definition bad_constant (i : nat) (h : hyps) := match nth_hyps i h with - | EqTerm (Tint Nul) (Tint n) => - if beq n Nul then h else absurd + | EqTerm (Tint Nul) (Tint n) => if beq n Nul then h else absurd + | NeqTerm (Tint Nul) (Tint n) => if beq n Nul then absurd else h + | LeqTerm (Tint Nul) (Tint n) => if bgt Nul n then absurd else h | _ => h end. -Theorem constant_not_nul_valid : - forall i : nat, valid_hyps (constant_not_nul i). +Theorem bad_constant_valid i : valid_hyps (bad_constant i). Proof. - unfold valid_hyps, constant_not_nul; intros i ep e lp H. + unfold valid_hyps, bad_constant; intros ep e lp H. generalize (nth_valid ep e i lp H); Simplify. -Qed. - -(** [O_CONSTANT_NUL] *) - -Definition constant_nul (i : nat) (h : hyps) := - match nth_hyps i h with - | NeqTerm (Tint Null) (Tint Null') => - if beq Null Null' then absurd else h - | _ => h - end. - -Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). -Proof. - unfold valid_hyps, constant_nul; intros; - generalize (nth_valid ep e i lp); Simplify; simpl; intuition. -Qed. - -(** [O_CONSTANT_NEG] *) - -Definition constant_neg (i : nat) (h : hyps) := - match nth_hyps i h with - | LeqTerm (Tint Nul) (Tint Neg) => - if bgt Nul Neg then absurd else h - | _ => h - end. - -Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). -Proof. - unfold valid_hyps, constant_neg. intros. - generalize (nth_valid ep e i lp). Simplify; simpl. - rewrite gt_lt_iff in *; rewrite le_lt_iff; intuition. + rewrite gt_lt_iff in *. rewrite le_lt_iff. intuition. Qed. (** [O_CONTRADICTION] *) @@ -1889,9 +1854,7 @@ Qed. Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := match t with - | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l) - | O_CONSTANT_NUL i => singleton (constant_nul i l) - | O_CONSTANT_NEG n => singleton (constant_neg n l) + | O_BAD_CONSTANT i => singleton (bad_constant i l) | O_CONTRADICTION i j => singleton (contradiction i j l) | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) | O_NEGATE_CONTRADICT_INV i j => @@ -1915,9 +1878,7 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. - - intros; left; now apply constant_not_nul_valid. - - intros; left; now apply constant_nul_valid. - - intros; left; now apply constant_neg_valid. + - intros; left; now apply bad_constant_valid. - intros; left; now apply contradiction_valid. - intros; left; now apply negate_contradict_valid. - intros; left; now apply negate_contradict_inv_valid. diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 4fd224e2b..fa92903ba 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -101,8 +101,7 @@ let coq_p_and = lazy (constant "Tand") let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") -let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") -let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") +let coq_s_bad_constant = lazy (constant "O_BAD_CONSTANT") let coq_s_div_approx = lazy (constant "O_DIV_APPROX") let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") @@ -111,7 +110,6 @@ let coq_s_state = lazy (constant "O_STATE") let coq_s_contradiction = lazy (constant "O_CONTRADICTION") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") -let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 787ace603..ba8b097fe 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -42,8 +42,7 @@ val coq_p_and : Term.constr lazy_t val coq_p_imp : Term.constr lazy_t val coq_p_prop : Term.constr lazy_t -val coq_s_constant_not_nul : Term.constr lazy_t -val coq_s_constant_neg : Term.constr lazy_t +val coq_s_bad_constant : Term.constr lazy_t val coq_s_div_approx : Term.constr lazy_t val coq_s_not_exact_divide : Term.constr lazy_t val coq_s_exact_divide : Term.constr lazy_t @@ -52,7 +51,6 @@ val coq_s_state : Term.constr lazy_t val coq_s_contradiction : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t -val coq_s_constant_nul : Term.constr lazy_t val coq_s_negate_contradict : Term.constr lazy_t val coq_s_negate_contradict_inv : Term.constr lazy_t diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 7a48b9788..45b141f92 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -855,87 +855,69 @@ let mk_direction_list l = (* \section{Rejouer l'historique} *) -let get_hyp env_hyp i = +let hyp_idx env_hyp i = let rec loop count = function | [] -> failwith (Printf.sprintf "get_hyp %d" i) - | CCEqua i' :: _ when Int.equal i i' -> count + | CCEqua i' :: _ when Int.equal i i' -> mk_nat count | _ :: l -> loop (succ count) l in loop 0 env_hyp -let replay_history env env_hyp = - let rec loop env_hyp t = - match t with - | CONTRADICTION (e1,e2) :: l -> - mkApp (Lazy.force coq_s_contradiction, - [| mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - mkApp (Lazy.force coq_s_div_approx, - [| mk_nat (get_hyp env_hyp e1.id); Z.mk k; Z.mk d; - reified_of_omega env e2.body e2.constant; - loop env_hyp l |]) - | NOT_EXACT_DIVIDE (e1,k) :: l -> - let e2_constant = floor_div e1.constant k in - let d = e1.constant - e2_constant * k in - let e2_body = map_eq_linear (fun c -> c / k) e1.body in - mkApp (Lazy.force coq_s_not_exact_divide, - [| mk_nat (get_hyp env_hyp e1.id); Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant |]) - | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = map_eq_linear (fun c -> c / k) e1.body in - let e2_constant = floor_div e1.constant k in - mkApp (Lazy.force coq_s_exact_divide, - [| mk_nat (get_hyp env_hyp e1.id); Z.mk k; - reified_of_omega env e2_body e2_constant; - loop env_hyp l |]) - | (MERGE_EQ(e3,e1,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in - mkApp (Lazy.force coq_s_merge_eq, - [| mk_nat n1; mk_nat n2; - loop (CCEqua e3:: env_hyp) l |]) - | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id - and n2 = get_hyp env_hyp e2.id in - mkApp (Lazy.force coq_s_sum, - [| Z.mk k1; mk_nat n1; Z.mk k2; - mk_nat n2; (loop (CCEqua e3 :: env_hyp) l) |]) - | CONSTANT_NOT_NUL(e,k) :: l -> - mkApp (Lazy.force coq_s_constant_not_nul, - [| mk_nat (get_hyp env_hyp e) |]) - | CONSTANT_NEG(e,k) :: l -> - mkApp (Lazy.force coq_s_constant_neg, - [| mk_nat (get_hyp env_hyp e) |]) - | STATE {st_new_eq=new_eq; st_def =def; - st_orig=orig; st_coef=m; - st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.id - and n2 = get_hyp env_hyp def.id in - mkApp (Lazy.force coq_s_state, - [| Z.mk m; mk_nat n1; mk_nat n2; - loop (CCEqua new_eq.id :: env_hyp) l |]) - | HYP _ :: l -> loop env_hyp l - | CONSTANT_NUL e :: l -> - mkApp (Lazy.force coq_s_constant_nul, - [| mk_nat (get_hyp env_hyp e) |]) - | NEGATE_CONTRADICT(e1,e2,true) :: l -> - mkApp (Lazy.force coq_s_negate_contradict, - [| mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | NEGATE_CONTRADICT(e1,e2,false) :: l -> - mkApp (Lazy.force coq_s_negate_contradict_inv, - [| mk_nat (get_hyp env_hyp e1.id); - mk_nat (get_hyp env_hyp e2.id) |]) - | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> - let i = get_hyp env_hyp e.id in - let r1 = loop (CCEqua e1 :: env_hyp) l1 in - let r2 = loop (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, - [| mk_nat i; r1 ; r2 |]) - | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> - loop env_hyp l - | (WEAKEN _ ) :: l -> failwith "not_treated" - | [] -> failwith "no contradiction" - in loop env_hyp +let rec reify_trace env env_hyp = function + | CONSTANT_NOT_NUL(e,_) :: [] + | CONSTANT_NEG(e,_) :: [] + | CONSTANT_NUL e :: [] -> + mkApp (Lazy.force coq_s_bad_constant,[| hyp_idx env_hyp e |]) + | NEGATE_CONTRADICT(e1,e2,direct) :: [] -> + let c = if direct then coq_s_negate_contradict + else coq_s_negate_contradict_inv + in + mkApp (Lazy.force c, [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2.id |]) + | CONTRADICTION (e1,e2) :: [] -> + mkApp (Lazy.force coq_s_contradiction, + [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2.id |]) + | NOT_EXACT_DIVIDE (e1,k) :: [] -> + let e2_constant = floor_div e1.constant k in + let d = e1.constant - e2_constant * k in + let e2_body = map_eq_linear (fun c -> c / k) e1.body in + mkApp (Lazy.force coq_s_not_exact_divide, + [| hyp_idx env_hyp e1.id; Z.mk k; Z.mk d; + reified_of_omega env e2_body e2_constant |]) + | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> + mkApp (Lazy.force coq_s_div_approx, + [| hyp_idx env_hyp e1.id; Z.mk k; Z.mk d; + reified_of_omega env e2.body e2.constant; + reify_trace env env_hyp l |]) + | EXACT_DIVIDE (e1,k) :: l -> + let e2_body = map_eq_linear (fun c -> c / k) e1.body in + let e2_constant = floor_div e1.constant k in + mkApp (Lazy.force coq_s_exact_divide, + [| hyp_idx env_hyp e1.id; Z.mk k; + reified_of_omega env e2_body e2_constant; + reify_trace env env_hyp l |]) + | MERGE_EQ(e3,e1,e2) :: l -> + mkApp (Lazy.force coq_s_merge_eq, + [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2; + reify_trace env (CCEqua e3:: env_hyp) l |]) + | SUM(e3,(k1,e1),(k2,e2)) :: l -> + mkApp (Lazy.force coq_s_sum, + [| Z.mk k1; hyp_idx env_hyp e1.id; + Z.mk k2; hyp_idx env_hyp e2.id; + reify_trace env (CCEqua e3 :: env_hyp) l |]) + | STATE {st_new_eq=new_eq; st_def =def; + st_orig=orig; st_coef=m; + st_var=sigma } :: l -> + mkApp (Lazy.force coq_s_state, + [| Z.mk m; hyp_idx env_hyp orig.id; hyp_idx env_hyp def.id; + reify_trace env (CCEqua new_eq.id :: env_hyp) l |]) + | HYP _ :: l -> reify_trace env env_hyp l + | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: _ -> + let r1 = reify_trace env (CCEqua e1 :: env_hyp) l1 in + let r2 = reify_trace env (CCEqua e2 :: env_hyp) l2 in + mkApp (Lazy.force coq_s_split_ineq, + [| hyp_idx env_hyp e.id; r1 ; r2 |]) + | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> reify_trace env env_hyp l + | WEAKEN _ :: l -> failwith "not_treated" + | _ -> failwith "bad history" let rec decompose_tree env ctxt = function Tree(i,left,right) -> @@ -954,7 +936,7 @@ let rec decompose_tree env ctxt = function | Leaf s -> decompose_tree_hyps s.s_trace env ctxt (IntSet.elements s.s_equa_deps) and decompose_tree_hyps trace env ctxt = function - [] -> app coq_e_solve [| replay_history env ctxt trace |] + [] -> app coq_e_solve [| reify_trace env ctxt trace |] | (i::l) -> let equation = try IntHtbl.find env.equations i -- cgit v1.2.3 From a1b6cb8c2742bc76707db8d13abbbd2d218b6486 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 17 May 2017 14:14:48 +0200 Subject: ROmega: less contructors in the final omega trace Now that O_SUM is properly optimized (cf. the [fusion] function), we could use it to encode CONTRADICTION and NEGATE_CONTRADICT(_INV). This way, the trace has almost the same size, but ReflOmegaCore.v is shorter and easier to maintain. --- plugins/romega/ReflOmegaCore.v | 173 +---------------------------------------- plugins/romega/const_omega.ml | 3 - plugins/romega/const_omega.mli | 3 - plugins/romega/refl_omega.ml | 18 +++-- 4 files changed, 13 insertions(+), 184 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 057752271..972070657 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -302,16 +302,6 @@ Module IntProperties (I:Int). intros; autorewrite with int; now rewrite plus_permute. Qed. - Lemma OMEGA13 : - forall v l1 l2 x : int, - v * -x + l1 + (v * x + l2) = l1 + l2. - Proof. - intros; autorewrite with int. - rewrite plus_permute; f_equal. - rewrite plus_assoc. - now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l. - Qed. - Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. intros; elim H; elim H0; simpl; auto. @@ -601,14 +591,6 @@ Module IntProperties (I:Int). now rewrite plus_opp_r. Qed. - Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y. - Proof. - intros. - replace 0 with (0+0). - apply plus_le_compat; auto. - rewrite plus_0_l; auto. - Qed. - Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros. @@ -1288,29 +1270,6 @@ Proof. - rewrite <- opp_eq_mult_neg_1. now f_equal. Qed. -(** Fusion by cancellation. - Particular case of [fusion] where the final result should - be a constant. *) - -Fixpoint fusion_cancel (t1 t2 : term) : term := - match t1, t2 with - | (v1 * Tint x1 + l1)%term, (v2 * Tint x2 + l2)%term => - if eq_term v1 v2 && beq x1 (-x2) - then fusion_cancel l1 l2 - else (t1+t2)%term (* should not happen *) - | Tint x1, Tint x2 => Tint (x1+x2) - | _, _ => (t1+t2)%term (* should not happen *) - end. - -Theorem fusion_cancel_stable e t1 t2 : - interp_term e (t1+t2)%term = interp_term e (fusion_cancel t1 t2). -Proof. - revert t2. induction t1; destruct t2; simpl; Simplify; auto. - simpl in *. - rewrite <- IHt1_2. - apply OMEGA13. -Qed. - (** ** Normalization of a proposition. The only basic facts left after normalization are @@ -1456,15 +1415,6 @@ Qed. First, the final steps leading to a contradiction: - [O_BAD_CONSTANT i] : hypothesis i has a constant body and this constant is not compatible with the kind of i. - - [O_CONTRADICTION i j] : - inequations i and j have a sum which is a negative constant. - Shortcut for [(O_SUM 1 i 1 j (O_BAD_CONSTANT 0))]. - - [O_NEGATE_CONTRADICT i j] : - equation i and disequation j (or vice-versa) have the same body. - Shortcut for [(O_SUM 1 i (-1) j (O_BAD_CONSTANT 0))]. - - [O_NEGATE_CONTRADICT_INV i j] : - equation i and disequation j (or vice-versa) have opposite bodies. - Shortcut for [(O_SUM 1 i 1 j (O_BAD_CONSTANT 0))]. - [O_NOT_EXACT_DIVIDE i k1 k2 t] : equation i has a body equivalent to [k1*t+k2] with [0 t_omega - | O_CONTRADICTION : idx -> idx -> t_omega - | O_NEGATE_CONTRADICT : idx -> idx -> t_omega - | O_NEGATE_CONTRADICT_INV : idx -> idx -> t_omega | O_NOT_EXACT_DIVIDE : idx -> int -> int -> term -> t_omega | O_EXACT_DIVIDE : idx -> int -> term -> t_omega -> t_omega @@ -1524,117 +1471,6 @@ Proof. rewrite gt_lt_iff in *. rewrite le_lt_iff. intuition. Qed. -(** [O_CONTRADICTION] *) - -Definition contradiction (i j : nat) (l : hyps) := - match nth_hyps i l with - | LeqTerm (Tint Nul) b1 => - match nth_hyps j l with - | LeqTerm (Tint Nul') b2 => - match fusion_cancel b1 b2 with - | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k - then absurd - else l - | _ => l - end - | _ => l - end - | _ => l - end. - -Theorem contradiction_valid (i j : nat) : valid_hyps (contradiction i j). -Proof. - unfold valid_hyps, contradiction; intros ep e l H. - generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H). - case (nth_hyps i l); trivial. intros t1 t2. - case t1; trivial. clear t1; intros x1. - case (nth_hyps j l); trivial. intros t3 t4. - case t3; trivial. clear t3; intros x3. - destruct fusion_cancel as [ t0 | | | | | ] eqn:E; trivial. - change t0 with (interp_term e (Tint t0)). - rewrite <- E, <- fusion_cancel_stable. - Simplify. - intros H1 H2. - generalize (OMEGA2 _ _ H1 H2). - rewrite gt_lt_iff in *; rewrite le_lt_iff. intuition. -Qed. - -(** [O_NEGATE_CONTRADICT] *) - -Definition negate_contradict (i1 i2 : nat) (h : hyps) := - match nth_hyps i1 h with - | EqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h - | _ => h - end - | NeqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h - | _ => h - end - | _ => h - end. - -Theorem negate_contradict_valid : - forall i j : nat, valid_hyps (negate_contradict i j). -Proof. - unfold valid_hyps, negate_contradict; intros i j ep e l H; - generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros; Simplify. -Qed. - -(** [O_NEGATE_CONTRADICT_INV] *) - -Definition negate_contradict_inv (i1 i2 : nat) (h : hyps) := - match nth_hyps i1 h with - | EqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm b2 (-(1))) - then absurd - else h - | _ => h - end - | NeqTerm (Tint Nul) b1 => - match nth_hyps i2 h with - | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && - eq_term b1 (scalar_norm b2 (-(1))) - then absurd - else h - | _ => h - end - | _ => h - end. - -Theorem negate_contradict_inv_valid : - forall i j : nat, valid_hyps (negate_contradict_inv i j). -Proof. - unfold valid_hyps, negate_contradict_inv; intros i j ep e l H; - generalize (nth_valid _ _ i _ H) (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl; intros H1 H2; Simplify. - - rewrite <- scalar_norm_stable in H1; simpl in *; - elim (mult_integral (interp_term e t4) (-(1))); intuition; - elim minus_one_neq_zero; auto. - - elim H1; clear H1; - rewrite <- scalar_norm_stable; simpl in *; - now rewrite <- H2, mult_0_l. -Qed. - (** [NOT_EXACT_DIVIDE] *) Definition not_exact_divide (i : nat) (k1 k2 : int) (body : term) @@ -1852,13 +1688,9 @@ Qed. (** ** Replaying the resolution trace *) -Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := +Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := match t with | O_BAD_CONSTANT i => singleton (bad_constant i l) - | O_CONTRADICTION i j => singleton (contradiction i j l) - | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l) - | O_NEGATE_CONTRADICT_INV i j => - singleton (negate_contradict_inv i j l) | O_NOT_EXACT_DIVIDE i k1 k2 body => singleton (not_exact_divide i k1 k2 body l) | O_EXACT_DIVIDE n k body cont => @@ -1879,9 +1711,6 @@ Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. - intros; left; now apply bad_constant_valid. - - intros; left; now apply contradiction_valid. - - intros; left; now apply negate_contradict_valid. - - intros; left; now apply negate_contradict_inv_valid. - intros; left; now apply not_exact_divide_valid. - intros m k body t' Ht' ep e lp H; apply Ht'; diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index fa92903ba..6e2fa5ed3 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -107,11 +107,8 @@ let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") let coq_s_sum = lazy (constant "O_SUM") let coq_s_state = lazy (constant "O_STATE") -let coq_s_contradiction = lazy (constant "O_CONTRADICTION") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") -let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") -let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") (* construction for the [extract_hyp] tactic *) let coq_direction = lazy (constant "direction") diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index ba8b097fe..b00525561 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -48,11 +48,8 @@ val coq_s_not_exact_divide : Term.constr lazy_t val coq_s_exact_divide : Term.constr lazy_t val coq_s_sum : Term.constr lazy_t val coq_s_state : Term.constr lazy_t -val coq_s_contradiction : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t -val coq_s_negate_contradict : Term.constr lazy_t -val coq_s_negate_contradict_inv : Term.constr lazy_t val coq_direction : Term.constr lazy_t val coq_d_left : Term.constr lazy_t diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 45b141f92..48e06a93e 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -862,19 +862,25 @@ let hyp_idx env_hyp i = | _ :: l -> loop (succ count) l in loop 0 env_hyp + +(* We now expand NEGATE_CONTRADICT and CONTRADICTION into + a O_SUM followed by a O_BAD_CONSTANT *) + +let sum_bad inv i1 i2 = + mkApp (Lazy.force coq_s_sum, + [| Z.mk Bigint.one; i1; + Z.mk (if inv then negone else Bigint.one); i2; + mkApp (Lazy.force coq_s_bad_constant, [| mk_nat 0 |])|]) + let rec reify_trace env env_hyp = function | CONSTANT_NOT_NUL(e,_) :: [] | CONSTANT_NEG(e,_) :: [] | CONSTANT_NUL e :: [] -> mkApp (Lazy.force coq_s_bad_constant,[| hyp_idx env_hyp e |]) | NEGATE_CONTRADICT(e1,e2,direct) :: [] -> - let c = if direct then coq_s_negate_contradict - else coq_s_negate_contradict_inv - in - mkApp (Lazy.force c, [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2.id |]) + sum_bad direct (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) | CONTRADICTION (e1,e2) :: [] -> - mkApp (Lazy.force coq_s_contradiction, - [| hyp_idx env_hyp e1.id; hyp_idx env_hyp e2.id |]) + sum_bad false (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) | NOT_EXACT_DIVIDE (e1,k) :: [] -> let e2_constant = floor_div e1.constant k in let d = e1.constant - e2_constant * k in -- cgit v1.2.3 From d992ae9fc539bdadd9214d2c92d83bd08b68ef33 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Wed, 17 May 2017 15:22:49 +0200 Subject: ROmega : O_STATE turned into a O_SUM We benefit from the fact that we normalize now *all* hypotheses even the one defining the "stated" variable: it is produced as ...def of v... = v and normalized as -v + ...def of v... = 0 which is precisely what we should add to the initial equation during a O_STATE. --- plugins/romega/ReflOmegaCore.v | 39 ++++++------------------------------- plugins/romega/const_omega.ml | 1 - plugins/romega/const_omega.mli | 1 - plugins/romega/refl_omega.ml | 44 +++++++++++++++++++----------------------- 4 files changed, 26 insertions(+), 59 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 972070657..f08d62162 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1175,7 +1175,11 @@ Proof. symmetry. apply plus_0_r. Qed. -(** Adding a constant *) +(** Adding a constant + + Instead of using [scalar_norm_add t 1 k], the following + definition spares some computations. + *) Fixpoint add_norm (t : term) (k : int) : term := match t with @@ -1434,7 +1438,6 @@ Qed. with one these bodies. - [O_SPLIT_INEQ i cont1 cont2] : disequation i is split into a disjonction of inequations. - - [O_STATE k i j cont] : now shortcut for [O_SUM 1 i k j cont]. *) Definition idx := nat. (** Index of an hypothesis in the list *) @@ -1447,8 +1450,7 @@ Inductive t_omega : Set := | O_DIV_APPROX : idx -> int -> int -> term -> t_omega -> t_omega | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega - | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega - | O_STATE : int -> idx -> idx -> t_omega -> t_omega. + | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega. (** ** Actual resolution steps of an omega normalized goal *) @@ -1662,30 +1664,6 @@ Proof. symmetry ; trivial. Qed. - -(** [O_STATE] *) - -Definition state (m : int) (prop1 prop2 : proposition) := - match prop1 with - | EqTerm (Tint Null) b1 => - match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 - then EqTerm (Tint 0) (fusion b1 b2 1 m) - else TrueTerm - | _ => TrueTerm - end - | _ => TrueTerm - end. - -Theorem state_valid : forall (m : int), valid2 (state m). -Proof. - unfold valid2; intros m ep e p1 p2. - unfold state; Simplify; simpl; auto. - rewrite <- fusion_stable. simpl in *. intros H H'. - rewrite <- H, <- H'. now rewrite !mult_0_l, plus_0_l. -Qed. - (** ** Replaying the resolution trace *) Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := @@ -1703,8 +1681,6 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := execute_omega cont (apply_oper_2 i1 i2 merge_eq l) | O_SPLIT_INEQ i cont1 cont2 => split_ineq i (execute_omega cont1) (execute_omega cont2) l - | O_STATE m i1 i2 cont => - execute_omega cont (apply_oper_2 i1 i2 (state m) l) end. Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). @@ -1712,7 +1688,6 @@ Proof. simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. - intros; left; now apply bad_constant_valid. - intros; left; now apply not_exact_divide_valid. - - intros m k body t' Ht' ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body) @@ -1733,8 +1708,6 @@ Proof. apply (split_ineq_valid i (execute_omega k1) (execute_omega k2) H1 H2 ep e lp H). - - intros m i1 i2 t' Ht' ep e lp H; apply Ht'; - apply (apply_oper_2_valid i1 i2 (state m) (state_valid m) ep e lp H). Qed. diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 6e2fa5ed3..ce47ef16a 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -106,7 +106,6 @@ let coq_s_div_approx = lazy (constant "O_DIV_APPROX") let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") let coq_s_sum = lazy (constant "O_SUM") -let coq_s_state = lazy (constant "O_STATE") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index b00525561..b4599c831 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -47,7 +47,6 @@ val coq_s_div_approx : Term.constr lazy_t val coq_s_not_exact_divide : Term.constr lazy_t val coq_s_exact_divide : Term.constr lazy_t val coq_s_sum : Term.constr lazy_t -val coq_s_state : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 48e06a93e..95cf2083c 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -214,17 +214,15 @@ let new_omega_var, rst_omega_var = let display_omega_var i = Printf.sprintf "OV%d" i -(* Register a new internal variable corresponding to some oformula - (normally an [Oatom]). *) - -let add_omega_var env t = - let v = new_omega_var () in - env.om_vars <- (v,t) :: env.om_vars - -(* Ajout forcé d'un lien entre un terme et une variable Cas où la - variable est créée par Omega et où il faut la lier après coup à un atome - réifié introduit de force *) -let force_omega_var env t v = +(* Register an internal variable corresponding to some oformula + (normally an [Oatom]). This omega variable could be a new one, + or one already created during the omega resolution (cf. STATE). *) + +let add_omega_var env t ov = + let v = match ov with + | None -> new_omega_var () + | Some v -> v + in env.om_vars <- (v,t) :: env.om_vars (* Récupère le terme associé à une variable omega *) @@ -238,12 +236,12 @@ let unintern_omega env v = l'environnement initial contenant tout. Il faudra le réduire après calcul des variables utiles. *) -let add_reified_atom sync t env = +let add_reified_atom opt_omega_var t env = try List.index0 Term.eq_constr t env.terms with Not_found -> let i = List.length env.terms in (* synchronize atom indexes and omega variables *) - let () = if sync then add_omega_var env (Oatom i) in + add_omega_var env (Oatom i) opt_omega_var; env.terms <- env.terms @ [t]; i let get_reified_atom env = @@ -514,11 +512,11 @@ let rec oformula_of_constr env t = | None -> match Z.get_scalar t2 with | Some n -> Omult (oformula_of_constr env t1, Oint n) - | None -> Oatom (add_reified_atom true t env)) + | None -> Oatom (add_reified_atom None t env)) | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n - | Tother -> Oatom (add_reified_atom true t env) + | Tother -> Oatom (add_reified_atom None t env) and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in @@ -713,14 +711,12 @@ let add_stated_equations env tree = (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in - let v = add_reified_atom false coq_v env in + let v = add_reified_atom (Some st.st_var) coq_v env in (* Le terme qu'il va falloir introduire *) let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in (* sa représentation sous forme d'équation mais non réifié car on n'a pas * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in - (* enregistre le lien entre la variable omega et la variable Coq *) - force_omega_var env (Oatom v) st.st_var; (v, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations @@ -909,12 +905,12 @@ let rec reify_trace env env_hyp = function [| Z.mk k1; hyp_idx env_hyp e1.id; Z.mk k2; hyp_idx env_hyp e2.id; reify_trace env (CCEqua e3 :: env_hyp) l |]) - | STATE {st_new_eq=new_eq; st_def =def; - st_orig=orig; st_coef=m; - st_var=sigma } :: l -> - mkApp (Lazy.force coq_s_state, - [| Z.mk m; hyp_idx env_hyp orig.id; hyp_idx env_hyp def.id; - reify_trace env (CCEqua new_eq.id :: env_hyp) l |]) + | STATE {st_new_eq; st_def; st_orig; st_coef } :: l -> + (* we now produce a [O_SUM] here *) + mkApp (Lazy.force coq_s_sum, + [| Z.mk Bigint.one; hyp_idx env_hyp st_orig.id; + Z.mk st_coef; hyp_idx env_hyp st_def.id; + reify_trace env (CCEqua st_new_eq.id :: env_hyp) l |]) | HYP _ :: l -> reify_trace env env_hyp l | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: _ -> let r1 = reify_trace env (CCEqua e1 :: env_hyp) l1 in -- cgit v1.2.3 From 2561930b8d163507f2a35e1ffddf90a6f14576de Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Thu, 18 May 2017 15:47:50 +0200 Subject: ReflOmegaCore: misc cleanup, n+-m = 0. - Proof. intros; subst; apply opp_def. Qed. - - Lemma egal_left_iff n m : n = m <-> 0 = n + - m. - Proof. - split. intros. symmetry. now apply egal_left. - intros. apply plus_reg_l with (-m). - rewrite plus_comm, <- H. symmetry. apply plus_opp_l. - Qed. - - Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y). + Lemma egal_left n m : 0 = n+-m <-> n = m. Proof. - intros; contradict H. - apply (plus_reg_l (-y)). - now rewrite plus_opp_l, plus_comm, H. + split; intros. + - apply plus_reg_l with (-m). + rewrite plus_comm, <- H. symmetry. apply plus_opp_l. + - symmetry. subst; apply opp_def. Qed. (** Specialized distributivities *) @@ -280,32 +262,30 @@ Module IntProperties (I:Int). Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int. Hint Rewrite <- plus_assoc : int. - Lemma OMEGA10 : - forall v c1 c2 l1 l2 k1 k2 : int, - (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = - v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). + Hint Rewrite plus_0_l plus_0_r mult_0_l mult_0_r mult_1_l mult_1_r : int. + + Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : + v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2) = + (v * c1 + l1) * k1 + (v * c2 + l2) * k2. Proof. - intros; autorewrite with int; f_equal; now rewrite plus_permute. + autorewrite with int; f_equal; now rewrite plus_permute. Qed. - Lemma OMEGA11 : - forall v1 c1 l1 l2 k1 : int, - (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). + Lemma OMEGA11 v1 c1 l1 l2 k1 : + v1 * (c1 * k1) + (l1 * k1 + l2) = (v1 * c1 + l1) * k1 + l2. Proof. - intros; now autorewrite with int. + now autorewrite with int. Qed. - Lemma OMEGA12 : - forall v2 c2 l1 l2 k2 : int, - l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). + Lemma OMEGA12 v2 c2 l1 l2 k2 : + v2 * (c2 * k2) + (l1 + l2 * k2) = l1 + (v2 * c2 + l2) * k2. Proof. - intros; autorewrite with int; now rewrite plus_permute. + autorewrite with int; now rewrite plus_permute. Qed. - Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. + Lemma sum1 a b c d : 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. - intros; elim H; elim H0; simpl; auto. - now rewrite mult_0_l, mult_0_l, plus_0_l. + intros; subst. now autorewrite with int. Qed. @@ -376,12 +356,14 @@ Module IntProperties (I:Int). Definition beq i j := match compare i j with Eq => true | _ => false end. - Lemma beq_iff i j : beq i j = true <-> i=j. + Infix "=?" := beq : Int_scope. + + Lemma beq_iff i j : (i =? j) = true <-> i=j. Proof. unfold beq. rewrite <- (compare_Eq i j). now destruct compare. Qed. - Lemma beq_reflect i j : reflect (i=j) (beq i j). + Lemma beq_reflect i j : reflect (i=j) (i =? j). Proof. apply iff_reflect. symmetry. apply beq_iff. Qed. @@ -391,16 +373,18 @@ Module IntProperties (I:Int). intros n m; generalize (beq_iff n m); destruct beq; [left|right]; intuition. Qed. - Definition bgt i j := match compare i j with Gt => true | _ => false end. + Definition blt i j := match compare i j with Lt => true | _ => false end. + + Infix " i>j. + Lemma blt_iff i j : (i ij) (bgt i j). + Lemma blt_reflect i j : reflect (i { n -n <= 0. + Lemma le_0_neg n : n <= 0 <-> 0 <= -n. Proof. - intros. rewrite <- (mult_0_l (-(1))) at 2. rewrite <- opp_eq_mult_neg_1. split; intros. - - apply opp_le_compat; auto. + - now apply opp_le_compat. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_le_compat; auto. - Qed. - - Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n. - Proof. - intros; rewrite le_0_neg, opp_involutive; intuition. + now apply opp_le_compat. Qed. Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m. @@ -487,20 +465,14 @@ Module IntProperties (I:Int). apply opp_le_compat; auto. Qed. - Lemma lt_0_neg : forall n, 0 < n <-> -n < 0. + Lemma lt_0_neg n : n < 0 <-> 0 < -n. Proof. - intros. rewrite <- (mult_0_l (-(1))) at 2. rewrite <- opp_eq_mult_neg_1. split; intros. - - apply opp_lt_compat; auto. + - now apply opp_lt_compat. - rewrite <-(opp_involutive 0), <-(opp_involutive n). - apply opp_lt_compat; auto. - Qed. - - Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n. - Proof. - intros; rewrite lt_0_neg, opp_involutive; intuition. + now apply opp_lt_compat. Qed. Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m. @@ -517,7 +489,7 @@ Module IntProperties (I:Int). - generalize (mult_lt_0_compat _ _ Hn Hm). rewrite H. exact (lt_irrefl 0). - - rewrite lt_0_neg' in Hm. + - rewrite lt_0_neg in Hm. generalize (mult_lt_0_compat _ _ Hn Hm). rewrite <- opp_mult_distr_r, opp_eq_mult_neg_1, H, mult_0_l. exact (lt_irrefl 0). @@ -530,7 +502,7 @@ Module IntProperties (I:Int). - right; apply (mult_integral_r n m); trivial. - now left. - right; apply (mult_integral_r (-n) m). - + now apply lt_0_neg'. + + now apply lt_0_neg. + rewrite mult_comm, <- opp_mult_distr_r, mult_comm, H. now rewrite opp_eq_mult_neg_1, mult_0_l. Qed. @@ -556,28 +528,10 @@ Module IntProperties (I:Int). now apply le_trans with k. Qed. - Lemma sum5 : - forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. - Proof. - intros. - subst b; rewrite mult_0_l, plus_0_r. - contradict H. - symmetry in H; destruct (mult_integral _ _ H); congruence. - Qed. - - Lemma one_neq_zero : 1 <> 0. - Proof. - red; intro. - symmetry in H. - apply (lt_not_eq 0 1); auto. - apply lt_0_1. - Qed. - - Lemma minus_one_neq_zero : -(1) <> 0. + Lemma sum5 a b c d : 0 <> c -> 0 <> a -> 0 = b -> 0 <> a * c + b * d. Proof. - apply lt_not_eq. - rewrite <- lt_0_neg. - apply lt_0_1. + intros Hc Ha <-. autorewrite with int. contradict Hc. + symmetry in Hc. destruct (mult_integral _ _ Hc); congruence. Qed. Lemma le_left n m : n <= m <-> 0 <= m + - n. @@ -591,7 +545,7 @@ Module IntProperties (I:Int). now rewrite plus_opp_r. Qed. - Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0. + Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. Proof. intros. assert (y=-x). @@ -605,17 +559,15 @@ Module IntProperties (I:Int). elim (lt_not_eq _ _ H1); auto. Qed. - Lemma sum2 : - forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. + Lemma sum2 a b c d : + 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d. Proof. - intros. - subst a; rewrite mult_0_l, plus_0_l. + intros Hd <- Hb. autorewrite with int. rewrite <- (mult_0_l 0). apply mult_le_compat; auto; apply le_refl. Qed. - Lemma sum3 : - forall a b c d : int, + Lemma sum3 a b c d : 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d. Proof. intros. @@ -627,56 +579,39 @@ Module IntProperties (I:Int). apply mult_le_compat; auto; apply le_refl. Qed. - Lemma sum4 : forall k : int, k>0 -> 0 <= k. - Proof. - intros k; rewrite gt_lt_iff; apply lt_le_weak. - Qed. - (** Lemmas specific to integers (they use [le_lt_int]) *) - Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n. + Lemma lt_left n m : n < m <-> 0 <= m + -n + -(1). Proof. - intros. rewrite <- le_left. - now rewrite <- le_lt_int. + rewrite <- plus_assoc, (plus_comm (-n)), plus_assoc. + rewrite <- le_left. + apply le_lt_int. Qed. - Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y. + Lemma OMEGA4 x y z : 0 < x -> x < y -> z * y + x <> 0. Proof. - intros. - generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H. - now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int. - Qed. - - Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0. - Proof. - intros. - intro H'. - rewrite gt_lt_iff in H,H0. + intros H H0 H'. + assert (0 < y) by now apply lt_trans with x. destruct (lt_eq_lt_dec z 0) as [[G|G]|G]. - - rewrite lt_0_neg' in G. - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). + - generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0). rewrite H'. rewrite <-(mult_1_l y) at 2. rewrite <-mult_plus_distr_r. - intros. - rewrite le_lt_int in G. - rewrite <- opp_plus_distr in G. - assert (0 < y) by (apply lt_trans with x; auto). - generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)). - rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff. - intuition. + apply le_lt_iff. + rewrite mult_comm. rewrite <- (mult_0_r y). + apply mult_le_compat_l; auto using lt_le_weak. + apply le_0_neg. rewrite opp_plus_distr. + apply le_lt_int. now apply lt_0_neg. - - subst; rewrite mult_0_l, plus_0_l in H'; subst. - apply (lt_not_eq _ _ H); auto. + - apply (lt_not_eq 0 (z*y+x)); auto. + subst. now autorewrite with int. - apply (lt_not_eq 0 (z*y+x)); auto. rewrite <- (plus_0_l 0). - apply plus_lt_compat; auto. - apply mult_lt_0_compat; auto. - apply lt_trans with x; auto. + auto using plus_lt_compat, mult_lt_0_compat. Qed. - Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). + Lemma OMEGA19 x : x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). Proof. intros. do 2 rewrite <- le_lt_int. @@ -689,23 +624,14 @@ Module IntProperties (I:Int). apply opp_lt_compat; auto. Qed. - Lemma pos_ge_1 n : 0 < n -> 1 <= n. - Proof. - intros. apply plus_le_reg_r with (-(1)). rewrite opp_def. - now apply le_lt_int. - Qed. - Lemma mult_le_approx n m p : - n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. + 0 < n -> p < n -> 0 <= m * n + p -> 0 <= m. Proof. - do 2 rewrite gt_lt_iff. do 2 rewrite le_lt_iff; intros Hn Hpn H Hm. destruct H. - apply lt_0_neg', pos_ge_1 in Hm. - rewrite lt_0_neg'. + apply lt_0_neg, le_lt_int, le_left in Hm. + rewrite lt_0_neg. rewrite opp_plus_distr, mult_comm, opp_mult_distr_r. - rewrite le_lt_int. - rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc. - apply lt_left. + rewrite le_lt_int. apply lt_left. rewrite le_lt_int. apply le_trans with (n+-(1)); [ now apply le_lt_int | ]. apply plus_le_compat; [ | apply le_refl ]. @@ -830,7 +756,7 @@ Definition absurd := FalseTerm :: nil. Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := match t1, t2 with - | Tint i1, Tint i2 => beq i1 i2 + | Tint i1, Tint i2 => i1 =? i2 | (t11 + t12), (t21 + t22) => eq_term t11 t21 && eq_term t12 t22 | (t11 * t12), (t21 * t22) => eq_term t11 t21 && eq_term t12 t22 | (t11 - t12), (t21 - t22) => eq_term t11 t21 && eq_term t12 t22 @@ -839,15 +765,17 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := | _, _ => false end%term. +Infix "=?" := eq_term : romega_scope. + Theorem eq_term_iff (t t' : term) : - eq_term t t' = true <-> t = t'. + (t =? t')%term = true <-> t = t'. Proof. revert t'. induction t; destruct t'; simpl in *; rewrite ?andb_true_iff, ?beq_iff, ?N.eqb_eq, ?IHt, ?IHt1, ?IHt2; intuition congruence. Qed. -Theorem eq_term_reflect (t t' : term) : reflect (t=t') (eq_term t t'). +Theorem eq_term_reflect (t t' : term) : reflect (t=t') (t =? t')%term. Proof. apply iff_reflect. symmetry. apply eq_term_iff. Qed. @@ -1107,13 +1035,13 @@ Ltac loop t := | (- ?X1)%term => loop X1 | (Tint ?X1) => loop X1 (* Eliminations *) - | (if beq ?X1 ?X2 then _ else _) => + | (if ?X1 =? ?X2 then _ else _) => let H := fresh "H" in case (beq_reflect X1 X2); intro H; try (rewrite H in *; clear H); simpl; auto; Simplify - | (if bgt ?X1 ?X2 then _ else _) => - case (bgt_reflect X1 X2); intro; simpl; auto; Simplify - | (if eq_term ?X1 ?X2 then _ else _) => + | (if ?X1 + case (blt_reflect X1 X2); intro; simpl; auto; Simplify + | (if (?X1 =? ?X2)%term then _ else _) => let H := fresh "H" in case (eq_term_reflect X1 X2); intro H; try (rewrite H in *; clear H); simpl; auto; Simplify @@ -1148,31 +1076,32 @@ with Simplify := match goal with (** Multiplication and sum by two constants. Invariant: [k1<>0]. *) -Fixpoint scalar_norm_add (t : term) (k1 k2 : int) : term := +Fixpoint scalar_mult_add (t : term) (k1 k2 : int) : term := match t with - | (v1 * Tint x1 + l1)%term => - (v1 * Tint (x1 * k1) + scalar_norm_add l1 k1 k2)%term + | v1 * Tint x1 + l1 => + v1 * Tint (x1 * k1) + scalar_mult_add l1 k1 k2 | Tint x => Tint (k1 * x + k2) - | _ => (t * Tint k1 + Tint k2)%term (* shouldn't happen *) - end. + | _ => t * Tint k1 + Tint k2 (* shouldn't happen *) + end%term. -Theorem scalar_norm_add_stable e t k1 k2 : - interp_term e (t * Tint k1 + Tint k2)%term = - interp_term e (scalar_norm_add t k1 k2). +Theorem scalar_mult_add_stable e t k1 k2 : + interp_term e (scalar_mult_add t k1 k2) = + interp_term e (t * Tint k1 + Tint k2). Proof. induction t; simpl; Simplify; simpl; auto. f_equal. apply mult_comm. - rewrite <- IHt2. simpl. apply OMEGA11. + rewrite IHt2. simpl. apply OMEGA11. Qed. (** Multiplication by a (non-nul) constant. *) -Definition scalar_norm (t : term) (k : int) := scalar_norm_add t k 0. +Definition scalar_mult (t : term) (k : int) := scalar_mult_add t k 0. -Theorem scalar_norm_stable e t k : - interp_term e (t * Tint k)%term = interp_term e (scalar_norm t k). +Theorem scalar_mult_stable e t k : + interp_term e (scalar_mult t k) = + interp_term e (t * Tint k). Proof. - unfold scalar_norm. rewrite <- scalar_norm_add_stable. simpl. - symmetry. apply plus_0_r. + unfold scalar_mult. rewrite scalar_mult_add_stable. simpl. + apply plus_0_r. Qed. (** Adding a constant @@ -1181,18 +1110,18 @@ Qed. definition spares some computations. *) -Fixpoint add_norm (t : term) (k : int) : term := +Fixpoint scalar_add (t : term) (k : int) : term := match t with - | (m + l)%term => (m + add_norm l k)%term + | m + l => m + scalar_add l k | Tint x => Tint (x + k) - | _ => (t + Tint k)%term - end. + | _ => t + Tint k + end%term. -Theorem add_norm_stable e t k : - interp_term e (t + Tint k)%term = interp_term e (add_norm t k). +Theorem scalar_add_stable e t k : + interp_term e (scalar_add t k) = interp_term e (t + Tint k). Proof. induction t; simpl; Simplify; simpl; auto. - rewrite <- IHt2. simpl. symmetry. apply plus_assoc. + rewrite IHt2. simpl. apply plus_assoc. Qed. (** Fusion of two equations. @@ -1204,42 +1133,41 @@ Qed. Fixpoint fusion (t1 t2 : term) (k1 k2 : int) : term := match t1 with - | ([v1] * Tint x1 + l1)%term => + | [v1] * Tint x1 + l1 => (fix fusion_t1 t2 : term := match t2 with - | ([v2] * Tint x2 + l2)%term => + | [v2] * Tint x2 + l2 => match N.compare v1 v2 with | Eq => - let k := k1 * x1 + k2 * x2 in - if beq k 0 then fusion l1 l2 k1 k2 - else ([v1] * Tint k + fusion l1 l2 k1 k2)%term - | Lt => ([v2] * Tint (k2 * x2) + fusion_t1 l2)%term - | Gt => ([v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2)%term + let k := (k1 * x1 + k2 * x2)%I in + if (k =? 0)%I then fusion l1 l2 k1 k2 + else [v1] * Tint k + fusion l1 l2 k1 k2 + | Lt => [v2] * Tint (k2 * x2) + fusion_t1 l2 + | Gt => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 end - | Tint x2 => ([v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2)%term - | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) + | Tint x2 => [v1] * Tint (k1 * x1) + fusion l1 t2 k1 k2 + | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) end) t2 - | Tint x1 => scalar_norm_add t2 k2 (k1 * x1) - | _ => (t1 * Tint k1 + t2 * Tint k2)%term (* shouldn't happen *) - end. + | Tint x1 => scalar_mult_add t2 k2 (k1 * x1) + | _ => t1 * Tint k1 + t2 * Tint k2 (* shouldn't happen *) + end%term. Theorem fusion_stable e t1 t2 k1 k2 : - interp_term e (t1 * Tint k1 + t2 * Tint k2)%term = - interp_term e (fusion t1 t2 k1 k2). + interp_term e (fusion t1 t2 k1 k2) = + interp_term e (t1 * Tint k1 + t2 * Tint k2). Proof. revert t2; induction t1; simpl; Simplify; simpl; auto. - - intros; rewrite <- scalar_norm_add_stable. simpl. + - intros; rewrite scalar_mult_add_stable. simpl. rewrite plus_comm. f_equal. apply mult_comm. - intros. Simplify. induction t2; simpl; Simplify; simpl; auto. - + rewrite <- IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. - + rewrite <- IHt1_2. simpl. subst n0. + + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. + + rewrite IHt1_2. simpl. subst n0. rewrite (mult_comm k1), (mult_comm k2) in H0. - rewrite OMEGA10, H0. - now rewrite mult_0_r, plus_0_l. - + rewrite <- IHt1_2. simpl. subst n0. + rewrite <- OMEGA10, H0. now autorewrite with int. + + rewrite IHt1_2. simpl. subst n0. rewrite (mult_comm k1), (mult_comm k2); apply OMEGA10. - + rewrite <- IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12. - + rewrite <- IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. + + rewrite IHt2_2. simpl. rewrite (mult_comm k2); apply OMEGA12. + + rewrite IHt1_2. simpl. rewrite (mult_comm k1); apply OMEGA11. Qed. (** Term normalization. @@ -1253,11 +1181,10 @@ Fixpoint normalize t := | Tint n => Tint n | [n]%term => ([n] * Tint 1 + Tint 0)%term | (t + t')%term => fusion (normalize t) (normalize t') 1 1 - | (- t)%term => scalar_norm (normalize t) (-(1)) + | (- t)%term => scalar_mult (normalize t) (-(1)) | (t - t')%term => fusion (normalize t) (normalize t') 1 (-(1)) | (Tint k * t)%term | (t * Tint k)%term => - if beq k 0 then Tint 0 - else scalar_norm (normalize t) k + if k =? 0 then Tint 0 else scalar_mult (normalize t) k | (t1 * t2)%term => (t1 * t2)%term (* shouldn't happen *) end. @@ -1265,9 +1192,8 @@ Theorem normalize_stable : term_stable normalize. Proof. intros e t. induction t; simpl; Simplify; simpl; - rewrite <- ?scalar_norm_stable; simpl in *; rewrite <- ?IHt1; - rewrite <- ?fusion_stable; simpl; - rewrite ?mult_0_l, ?mult_0_r, ?mult_1_l, ?mult_1_r, ?plus_0_r; auto. + rewrite ?scalar_mult_stable; simpl in *; rewrite <- ?IHt1; + rewrite ?fusion_stable; simpl; autorewrite with int; auto. - now f_equal. - rewrite mult_comm. now f_equal. - rewrite <- opp_eq_mult_neg_1, <-minus_def. now f_equal. @@ -1315,57 +1241,49 @@ Fixpoint normalize_prop (negated:bool)(p:proposition) := Definition normalize_hyps := List.map (normalize_prop false). -Opaque normalize. +Local Ltac simp := cbn -[normalize]. Theorem normalize_prop_valid b e ep p : - interp_prop e ep p <-> - interp_prop e ep (normalize_prop b p). + interp_prop e ep (normalize_prop b p) <-> interp_prop e ep p. Proof. revert b. - induction p; intros; simpl; try tauto. - - destruct b; simpl; + induction p; intros; simp; try tauto. + - destruct b; simp; rewrite <- ?normalize_stable; simpl; rewrite ?minus_def. - + rewrite not_eq. apply egal_left_iff. - + apply egal_left_iff. - - destruct b; simpl; - rewrite <- ? normalize_stable; simpl; rewrite ?minus_def; - apply not_iff_compat, egal_left_iff. - - destruct b; simpl; + + rewrite not_eq. apply egal_left. + + apply egal_left. + - destruct b; simp; + rewrite <- ?normalize_stable; simpl; rewrite ?minus_def; + apply not_iff_compat, egal_left. + - destruct b; simp; rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite le_lt_iff. apply not_iff_compat. - rewrite le_lt_int. rewrite le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - + apply le_left. - - destruct b; simpl; + + symmetry. rewrite le_lt_iff. apply not_iff_compat, lt_left. + + now rewrite <- le_left. + - destruct b; simp; rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. - + rewrite ge_le_iff, le_lt_iff. apply not_iff_compat. - rewrite le_lt_int. rewrite le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - + rewrite ge_le_iff. apply le_left. - - destruct b; simpl; + + symmetry. rewrite ge_le_iff, le_lt_iff. + apply not_iff_compat, lt_left. + + rewrite ge_le_iff. now rewrite <- le_left. + - destruct b; simp; rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + rewrite gt_lt_iff, lt_le_iff. apply not_iff_compat. - apply le_left. - + rewrite gt_lt_iff. rewrite le_lt_int. rewrite le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - - destruct b; simpl; + now rewrite <- le_left. + + symmetry. rewrite gt_lt_iff. apply lt_left. + - destruct b; simp; rewrite <- ? normalize_stable; simpl; rewrite ?minus_def. + rewrite lt_le_iff. apply not_iff_compat. - apply le_left. - + rewrite le_lt_int, le_left. - rewrite <- !plus_assoc. now rewrite (plus_comm (-(1))). - - now rewrite <- IHp. - - now rewrite <- IHp1, <- IHp2. - - now rewrite <- IHp1, <- IHp2. - - now rewrite <- IHp1, <- IHp2. + now rewrite <- le_left. + + symmetry. apply lt_left. + - now rewrite IHp. + - now rewrite IHp1, IHp2. + - now rewrite IHp1, IHp2. + - now rewrite IHp1, IHp2. Qed. -Transparent normalize. - Theorem normalize_hyps_valid : valid_hyps normalize_hyps. Proof. intros e ep l. induction l; simpl; intuition. - now rewrite <- normalize_prop_valid. + now rewrite normalize_prop_valid. Qed. Theorem normalize_hyps_goal (ep : list Prop) (env : list int) (l : hyps) : @@ -1460,9 +1378,9 @@ Inductive t_omega : Set := Definition bad_constant (i : nat) (h : hyps) := match nth_hyps i h with - | EqTerm (Tint Nul) (Tint n) => if beq n Nul then h else absurd - | NeqTerm (Tint Nul) (Tint n) => if beq n Nul then absurd else h - | LeqTerm (Tint Nul) (Tint n) => if bgt Nul n then absurd else h + | EqTerm (Tint Nul) (Tint n) => if n =? Nul then h else absurd + | NeqTerm (Tint Nul) (Tint n) => if n =? Nul then absurd else h + | LeqTerm (Tint Nul) (Tint n) => if n h end. @@ -1470,7 +1388,7 @@ Theorem bad_constant_valid i : valid_hyps (bad_constant i). Proof. unfold valid_hyps, bad_constant; intros ep e lp H. generalize (nth_valid ep e i lp H); Simplify. - rewrite gt_lt_iff in *. rewrite le_lt_iff. intuition. + rewrite le_lt_iff. intuition. Qed. (** [NOT_EXACT_DIVIDE] *) @@ -1479,10 +1397,10 @@ Definition not_exact_divide (i : nat) (k1 k2 : int) (body : term) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => - if beq Nul 0 && - eq_term (scalar_norm_add body k1 k2) b && - bgt k2 0 && - bgt k1 k2 + if (Nul =? 0) && + (scalar_mult_add body k1 k2 =? b)%term && + (0 l @@ -1494,7 +1412,7 @@ Theorem not_exact_divide_valid : Proof. unfold valid_hyps, not_exact_divide; intros. generalize (nth_valid ep e i lp); Simplify. - rewrite <-H1, <-scalar_norm_add_stable. simpl. + rewrite <-H1, scalar_mult_add_stable. simpl. intros. absurd (interp_term e body * k1 + k2 = 0). - now apply OMEGA4. @@ -1507,12 +1425,12 @@ Qed. Definition exact_divide (k : int) (body : term) (prop : proposition) := match prop with - | EqTerm (Tint Null) b => - if beq Null 0 && eq_term (scalar_norm body k) b && negb (beq k 0) + | EqTerm (Tint o) b => + if (o =? 0) && (scalar_mult body k =? b)%term && negb (k =? 0) then EqTerm (Tint 0) body else TrueTerm - | NeqTerm (Tint Null) b => - if beq Null 0 && eq_term (scalar_norm body k) b && negb (beq k 0) + | NeqTerm (Tint o) b => + if (o =? 0) && (scalar_mult body k =? b)%term && negb (k =? 0) then NeqTerm (Tint 0) body else TrueTerm | _ => TrueTerm @@ -1523,7 +1441,7 @@ Theorem exact_divide_valid : Proof. unfold valid1, exact_divide; intros k t ep e p1; Simplify; simpl; auto; subst; - rewrite <- scalar_norm_stable; simpl; intros. + rewrite scalar_mult_stable; simpl; intros. - destruct (mult_integral _ _ (eq_sym H0)); intuition. - contradict H0; rewrite <- H0, mult_0_l; auto. Qed. @@ -1533,11 +1451,11 @@ Qed. Definition divide_and_approx (k1 k2 : int) (body : term) (prop : proposition) := match prop with - | LeqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm_add body k1 k2) b && - bgt k1 0 && - bgt k1 k2 + | LeqTerm (Tint o) b => + if (o =? 0) && + (scalar_mult_add body k1 k2 =? b)%term && + (0 prop @@ -1549,7 +1467,7 @@ Theorem divide_and_approx_valid : Proof. unfold valid1, divide_and_approx. intros k1 k2 body ep e p1. Simplify. subst. - rewrite <- scalar_norm_add_stable. simpl. + rewrite scalar_mult_add_stable. simpl. intro H; now apply mult_le_approx with (3 := H). Qed. @@ -1557,40 +1475,40 @@ Qed. Definition sum (k1 k2 : int) (prop1 prop2 : proposition) := match prop1 with - | EqTerm (Tint Null) b1 => + | EqTerm (Tint o) b1 => match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 + | EqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) then EqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && bgt k2 0 + | LeqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && (0 - if beq Null 0 && beq Null' 0 && negb (beq k2 0) + | NeqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && negb (k2 =? 0) then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm end - | LeqTerm (Tint Null) b1 => - if beq Null 0 && bgt k1 0 + | LeqTerm (Tint o) b1 => + if (o =? 0) && (0 - if beq Null' 0 then + | EqTerm (Tint o') b2 => + if o' =? 0 then LeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm - | LeqTerm (Tint Null') b2 => - if beq Null' 0 && bgt k2 0 + | LeqTerm (Tint o') b2 => + if (o' =? 0) && (0 TrueTerm end else TrueTerm - | NeqTerm (Tint Null) b1 => + | NeqTerm (Tint o) b1 => match prop2 with - | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && negb (beq k1 0) + | EqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && negb (k1 =? 0) then NeqTerm (Tint 0) (fusion b1 b2 k1 k2) else TrueTerm | _ => TrueTerm @@ -1602,21 +1520,25 @@ Theorem sum_valid : forall (k1 k2 : int), valid2 (sum k1 k2). Proof. unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; - Simplify; simpl; rewrite <- ?fusion_stable; - simpl; intros; auto using sum1, sum2, sum3, sum4, sum5. - - rewrite plus_comm. now apply sum5. - - rewrite plus_comm. apply sum2; trivial; now apply sum4. + Simplify; simpl; rewrite ?fusion_stable; + simpl; intros; auto. + - apply sum1; auto. + - rewrite plus_comm. apply sum5; auto. + - apply sum2; auto using lt_le_weak. + - apply sum5; auto. + - rewrite plus_comm. apply sum2; auto using lt_le_weak. + - apply sum3; auto using lt_le_weak. Qed. (** [MERGE_EQ] *) Definition merge_eq (prop1 prop2 : proposition) := match prop1 with - | LeqTerm (Tint Null) b1 => + | LeqTerm (Tint o) b1 => match prop2 with - | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm b2 (-(1))) + | LeqTerm (Tint o') b2 => + if (o =? 0) && (o' =? 0) && + (b1 =? scalar_mult b2 (-(1)))%term then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm @@ -1627,7 +1549,7 @@ Definition merge_eq (prop1 prop2 : proposition) := Theorem merge_eq_valid : valid2 merge_eq. Proof. unfold valid2, merge_eq; intros ep e p1 p2; Simplify; simpl; auto. - rewrite <- scalar_norm_stable. simpl. + rewrite scalar_mult_stable. simpl. intros; symmetry ; apply OMEGA8 with (2 := H0). - assumption. - elim opp_eq_mult_neg_1; trivial. @@ -1637,10 +1559,10 @@ Qed. Definition split_ineq (i : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with - | NeqTerm (Tint Null) b1 => - if beq Null 0 then - f1 (LeqTerm (Tint 0) (add_norm b1 (-(1))) :: l) ++ - f2 (LeqTerm (Tint 0) (scalar_norm_add b1 (-(1)) (-(1))) :: l) + | NeqTerm (Tint o) b1 => + if o =? 0 then + f1 (LeqTerm (Tint 0) (scalar_add b1 (-(1))) :: l) ++ + f2 (LeqTerm (Tint 0) (scalar_mult_add b1 (-(1)) (-(1))) :: l) else l :: nil | _ => l :: nil end. @@ -1656,9 +1578,9 @@ Proof. auto; intros z; simpl; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)). - - intro H4; left; apply H1; simpl; rewrite <- add_norm_stable; + - intro H4; left; apply H1; simpl; rewrite scalar_add_stable; simpl; auto. - - intro H4; right; apply H2; simpl; rewrite <- scalar_norm_add_stable; + - intro H4; right; apply H2; simpl; rewrite scalar_mult_add_stable; simpl; auto. - generalize H3; unfold not; intros E1 E2; apply E1; symmetry ; trivial. -- cgit v1.2.3 From 16a505cd851ef5f3a151d08af5397da97b4d2943 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 19 May 2017 11:52:17 +0200 Subject: refl_omega.v: explicitely identify atom indexes and omega vars --- plugins/romega/refl_omega.ml | 58 ++++++++++++++++++-------------------------- 1 file changed, 24 insertions(+), 34 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 95cf2083c..a8741b690 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -106,8 +106,6 @@ type environment = { mutable terms : Term.constr list; (* La meme chose pour les propositions *) mutable props : Term.constr list; - (* Les variables introduites par omega *) - mutable om_vars : (int * oformula) list; (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) real_indices : int IntHtbl.t; @@ -166,7 +164,7 @@ let id_concl = Id.of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { - terms = []; props = []; om_vars = []; cnt_connectors = 0; + terms = []; props = []; cnt_connectors = 0; real_indices = IntHtbl.create 7; equations = IntHtbl.create 7; constructors = IntHtbl.create 7; @@ -205,48 +203,38 @@ let new_omega_eq, rst_omega_eq = (* generation d'identifiant de variable pour Omega *) -let new_omega_var, rst_omega_var = +let new_omega_var, rst_omega_var, set_omega_maxvar = let cpt = ref (-1) in (function () -> incr cpt; !cpt), - (function () -> cpt:=(-1)) + (function () -> cpt:=(-1)), + (function n -> cpt:=n) (* Affichage des variables d'un système *) let display_omega_var i = Printf.sprintf "OV%d" i -(* Register an internal variable corresponding to some oformula - (normally an [Oatom]). This omega variable could be a new one, - or one already created during the omega resolution (cf. STATE). *) - -let add_omega_var env t ov = - let v = match ov with - | None -> new_omega_var () - | Some v -> v - in - env.om_vars <- (v,t) :: env.om_vars - -(* Récupère le terme associé à une variable omega *) -let unintern_omega env v = - try List.assoc_f Int.equal v env.om_vars - with Not_found -> failwith "unintern_omega" - (* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions non réifiés et variables des termes reifies. Attention il s'agit de l'environnement initial contenant tout. Il faudra le réduire après calcul des variables utiles. *) -let add_reified_atom opt_omega_var t env = +let add_reified_atom t env = try List.index0 Term.eq_constr t env.terms with Not_found -> let i = List.length env.terms in - (* synchronize atom indexes and omega variables *) - add_omega_var env (Oatom i) opt_omega_var; env.terms <- env.terms @ [t]; i let get_reified_atom env = try List.nth env.terms with Invalid_argument _ -> failwith "get_reified_atom" +(** When the omega resolution has created a variable [v], we re-sync + the environment with this new variable. To be done in the right order. *) + +let set_reified_atom v t env = + assert (Int.equal v (List.length env.terms)); + env.terms <- env.terms @ [t] + (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) let add_prop env t = @@ -296,9 +284,9 @@ let rec pprint ch = function (* \subsection{Omega vers Oformula} *) -let oformula_of_omega env af = +let oformula_of_omega af = let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) + | ({v=v; c=n}::r) -> Oplus(Omult(Oatom v,Oint n),loop r) | [] -> Oint af.constant in loop af.body @@ -382,8 +370,8 @@ let reified_of_omega env body constant = let mk_coeff {c=c; v=v} t = let coef = app coq_t_mult - [| reified_of_formula env (unintern_omega env v); - app coq_t_int [| Z.mk c |] |] in + [| reified_of_formula env (Oatom v); + app coq_t_int [| Z.mk c |] |] in app coq_t_plus [|coef; t |] in List.fold_right mk_coeff body coeff_constant @@ -512,11 +500,11 @@ let rec oformula_of_constr env t = | None -> match Z.get_scalar t2 with | Some n -> Omult (oformula_of_constr env t1, Oint n) - | None -> Oatom (add_reified_atom None t env)) + | None -> Oatom (add_reified_atom t env)) | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n - | Tother -> Oatom (add_reified_atom None t env) + | Tother -> Oatom (add_reified_atom t env) and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in @@ -707,17 +695,17 @@ let add_stated_equations env tree = in let add_env st = (* On retransforme la définition de v en formule reifiée *) - let v_def = oformula_of_omega env st.st_def in + let v_def = oformula_of_omega st.st_def in (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in - let v = add_reified_atom (Some st.st_var) coq_v env in + set_reified_atom st.st_var coq_v env; (* Le terme qu'il va falloir introduire *) let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in (* sa représentation sous forme d'équation mais non réifié car on n'a pas * l'environnement pour le faire correctement *) - let term_to_reify = (v_def,Oatom v) in - (v, term_to_generalize,term_to_reify,st.st_def.id) in + let term_to_reify = (v_def,Oatom st.st_var) in + (st.st_var, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations (* Calcule la liste des éclatements à réaliser sur les hypothèses @@ -1071,6 +1059,8 @@ let total_reflexive_omega_tactic unsafe = try let env = new_environment () in let (concl,hyps) as reified_goal = reify_gl env gl in + (* Register all atom indexes created during reification as omega vars *) + set_omega_maxvar (pred (List.length env.terms)); let full_reified_goal = (id_concl,Pnot concl) :: hyps in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; -- cgit v1.2.3 From 107ef2db28b7abc75afe32350e7c2eb3c8ddbe82 Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Fri, 19 May 2017 13:24:16 +0200 Subject: refl_omega: some code refactoring --- plugins/omega/omega.ml | 2 +- plugins/romega/refl_omega.ml | 255 ++++++++++++++++++++++--------------------- 2 files changed, 129 insertions(+), 128 deletions(-) (limited to 'plugins') diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index f655c176f..2a018fa3f 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -96,7 +96,7 @@ type afine = { type state_action = { st_new_eq : afine; - st_def : afine; + st_def : afine; (* /!\ this represents [st_def = st_var] *) st_orig : afine; st_coef : bigint; st_var : int } diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index a8741b690..6ef53837c 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -89,7 +89,7 @@ and oequation = { e_depends: direction list; (* liste des points de disjonction dont dépend l'accès à l'équation avec la direction (branche) pour y accéder *) - e_omega: afine (* la fonction normalisée *) + e_omega: OmegaSolver.afine (* normalized formula *) } (* \subsection{Proof context} @@ -121,7 +121,7 @@ type environment = { type solution = { s_index : int; s_equa_deps : IntSet.t; - s_trace : action list } + s_trace : OmegaSolver.action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) type solution_tree = @@ -362,12 +362,15 @@ let reified_of_proposition env f = try reified_of_oprop env f with reraise -> pprint stderr f; raise reraise +let reified_of_eq env (l,r) = + app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |] + (* \subsection{Omega vers COQ réifié} *) let reified_of_omega env body constant = let coeff_constant = app coq_t_int [| Z.mk constant |] in - let mk_coeff {c=c; v=v} t = + let mk_coeff {c;v} t = let coef = app coq_t_mult [| reified_of_formula env (Oatom v); @@ -422,8 +425,8 @@ let rec vars_of_prop = function *) type nformula = - { coefs : (atom_index * bigint) list; - cst : bigint } + { coefs : (atom_index * Bigint.bigint) list; + cst : Bigint.bigint } let scale n { coefs; cst } = { coefs = List.map (fun (v,k) -> (v,k*n)) coefs; @@ -667,46 +670,53 @@ let rec hyps_used_in_trace = function hyps_used_in_trace act1 @@ hyps_used_in_trace act2 | _ -> hyps_used_in_trace l -(* Extraction des variables déclarées dans une équation. Permet ensuite - de les déclarer dans l'environnement de la procédure réflexive et - éviter les créations de variable au vol *) +(** Retreive variables declared as extra equations during resolution + and declare them into the environment. + We should consider these variables in their introduction order, + otherwise really bad things will happen. *) -let rec variable_stated_in_trace = function - | [] -> [] - | act :: l -> - match act with - | STATE action -> - (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) - (*i coef: int, var:int i*) - action :: variable_stated_in_trace l - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> - variable_stated_in_trace act1 @ variable_stated_in_trace act2 - | _ -> variable_stated_in_trace l - -let add_stated_equations env tree = - (* Il faut trier les variables par ordre d'introduction pour ne pas risquer - de définir dans le mauvais ordre *) - let stated_equations = - let cmpvar x y = Int.compare x.st_var y.st_var in - let rec loop = function - | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) - | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) - in loop tree - in - let add_env st = - (* On retransforme la définition de v en formule reifiée *) +let state_cmp x y = Int.compare x.st_var y.st_var + +module StateSet = + Set.Make (struct type t = state_action let compare = state_cmp end) + +let rec stated_in_trace = function + | [] -> StateSet.empty + | [SPLIT_INEQ (_,(_,t1),(_,t2))] -> + StateSet.union (stated_in_trace t1) (stated_in_trace t2) + | STATE action :: l -> StateSet.add action (stated_in_trace l) + | _ :: l -> stated_in_trace l + +let rec stated_in_tree = function + | Tree(_,t1,t2) -> StateSet.union (stated_in_tree t1) (stated_in_tree t2) + | Leaf s -> stated_in_trace s.s_trace + +let digest_stated_equations env tree = + let do_equation st (vars,gens,eqns,ids) = + (** We turn the definition of [v] + - into a reified formula : *) let v_def = oformula_of_omega st.st_def in - (* Notez que si l'ordre de création des variables n'est pas respecté, - * ca va planter *) + (** - into a concrete Coq formula + (this uses only older vars already in env) : *) let coq_v = coq_of_formula env v_def in + (** We then update the environment *) set_reified_atom st.st_var coq_v env; - (* Le terme qu'il va falloir introduire *) - let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in - (* sa représentation sous forme d'équation mais non réifié car on n'a pas - * l'environnement pour le faire correctement *) + (** The term we'll introduce *) + let term_to_generalize = + EConstr.of_constr (app coq_refl_equal [|Lazy.force Z.typ; coq_v|]) + in + (** Its representation as equation (but not reified yet, + we lack the proper env to do that). *) let term_to_reify = (v_def,Oatom st.st_var) in - (st.st_var, term_to_generalize,term_to_reify,st.st_def.id) in - List.map add_env stated_equations + (st.st_var::vars, + term_to_generalize::gens, + term_to_reify::eqns, + CCEqua st.st_def.id :: ids) + in + let (vars,gens,eqns,ids) = + StateSet.fold do_equation (stated_in_tree tree) ([],[],[],[]) + in + (List.rev vars, List.rev gens, List.rev eqns, List.rev ids) (* Calcule la liste des éclatements à réaliser sur les hypothèses nécessaires pour extraire une liste d'équations donnée *) @@ -740,46 +750,43 @@ let filter_compatible_systems required systems = systems let rec equas_of_solution_tree = function - Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) + | Tree(_,t1,t2) -> + (equas_of_solution_tree t1)@@(equas_of_solution_tree t2) | Leaf s -> s.s_equa_deps -(* [really_useful_prop] pushes useless props in a new Pprop variable *) -(* Things get shorter, but may also get wrong, since a Prop is considered - to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance - Pfalse is decidable. So should not be used on conclusion (??) *) - -let rec coq_of_oprop = function - | Pequa(t,_) -> t - | Ptrue -> app coq_True [||] - | Pfalse -> app coq_False [||] - | Pnot t1 -> app coq_not [|coq_of_oprop t1|] - | Por(_,t1,t2) -> app coq_or [|coq_of_oprop t1; coq_of_oprop t2|] - | Pand(_,t1,t2) -> app coq_and [|coq_of_oprop t1; coq_of_oprop t2|] - | Pimp(_,t1,t2) -> - (* No lifting here, since Omega only works on closed propositions. *) - Term.mkArrow (coq_of_oprop t1) (coq_of_oprop t2) - | Pprop t -> t +(** [maximize_prop] pushes useless props in a new Pprop atom. + The reified formulas get shorter, but be careful with decidabilities. + For instance, anything that contains a Pprop is considered to be + undecidable in [ReflOmegaCore], whereas a Pfalse for instance at + the same spot will lead to a decidable formula. + In particular, do not use this function on the conclusion. + Even in hypotheses, we could probably build pathological examples + that romega won't handle correctly, but they should be pretty rare. +*) -let really_useful_prop equas c = +let maximize_prop equas c = let rec loop c = match c with - | Pequa(_,e) -> if IntSet.mem e.e_omega.id equas then Some c else None - | Pnot t1 -> - begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end - | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 - | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 - | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 - | Ptrue | Pfalse | Pprop _ -> None - and binop f t1 t2 = - begin match loop t1, loop t2 with - None, None -> None - | Some t1',Some t2' -> Some (f(t1',t2')) - | Some t1',None -> Some (f(t1',Pprop (coq_of_oprop t2))) - | None,Some t2' -> Some (f(Pprop (coq_of_oprop t1),t2')) - end - in - match loop c with - | None -> Pprop (coq_of_oprop c) - | Some t -> t + | Pequa(t,e) -> if IntSet.mem e.e_omega.id equas then c else Pprop t + | Pnot t -> + (match loop t with + | Pprop p -> Pprop (app coq_not [|p|]) + | t' -> Pnot t') + | Por(i,t1,t2) -> + (match loop t1, loop t2 with + | Pprop p1, Pprop p2 -> Pprop (app coq_or [|p1;p2|]) + | t1', t2' -> Por(i,t1',t2')) + | Pand(i,t1,t2) -> + (match loop t1, loop t2 with + | Pprop p1, Pprop p2 -> Pprop (app coq_and [|p1;p2|]) + | t1', t2' -> Pand(i,t1',t2')) + | Pimp(i,t1,t2) -> + (match loop t1, loop t2 with + | Pprop p1, Pprop p2 -> Pprop (Term.mkArrow p1 p2) (* no lift (closed) *) + | t1', t2' -> Pimp(i,t1',t2')) + | Ptrue -> Pprop (app coq_True [||]) + | Pfalse -> Pprop (app coq_False [||]) + | Pprop _ -> c + in loop c let rec display_solution_tree ch = function Leaf t -> @@ -938,6 +945,28 @@ and decompose_tree_hyps trace env ctxt = function (CCEqua equation.e_omega.id :: ctxt) l in app coq_e_extract [|mk_nat index; mk_direction_list path; cont |] +let solve_system env index list_eq = + let system = List.map (fun eq -> eq.e_omega) list_eq in + let trace = + OmegaSolver.simplify_strong + (new_omega_eq,new_omega_var,display_omega_var) + system + in + (* Hypotheses used for this solution *) + let vars = hyps_used_in_trace trace in + let splits = get_eclatement env (IntSet.elements vars) in + if !debug then + begin + Printf.printf "SYSTEME %d\n" index; + display_action display_omega_var trace; + print_string "\n Depend :"; + IntSet.iter (fun i -> Printf.printf " %d" i) vars; + print_string "\n Split points :"; + List.iter display_depend splits; + Printf.printf "\n------------------------------------\n" + end; + {s_index = index; s_trace = trace; s_equa_deps = vars}, splits + (* \section{La fonction principale} *) (* Cette fonction construit la trace pour la procédure de décision réflexive. A partir des résultats @@ -947,36 +976,14 @@ résolution globale du système et enfin construit la trace qui permet de faire rejouer cette solution par la tactique réflexive. *) let resolution unsafe env (reified_concl,reified_hyps) systems_list = - let num = ref 0 in - let solve_system list_eq = - let index = !num in - let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system in - (* Hypotheses used for this solution *) - let vars = hyps_used_in_trace trace in - let splits = get_eclatement env (IntSet.elements vars) in - if !debug then begin - Printf.printf "SYSTEME %d\n" index; - display_action display_omega_var trace; - print_string "\n Depend :"; - IntSet.iter (fun i -> Printf.printf " %d" i) vars; - print_string "\n Split points :"; - List.iter display_depend splits; - Printf.printf "\n------------------------------------\n" - end; - incr num; - {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in if !debug then Printf.printf "\n====================================\n"; - let all_solutions = List.map solve_system systems_list in + let all_solutions = List.mapi (solve_system env) systems_list in let solution_tree = solve_with_constraints all_solutions [] in if !debug then begin display_solution_tree stdout solution_tree; print_newline() end; - (* Collect all hypotheses used in the solution tree *) + (** Collect all hypotheses used in the solution tree *) let useful_equa_ids = equas_of_solution_tree solution_tree in let equations = List.map (get_equation env) (IntSet.elements useful_equa_ids) in @@ -990,37 +997,35 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = let useful_vars = vars_of_equations equations @@ vars_of_prop reified_concl in - (* variables a introduire *) - let to_introduce = add_stated_equations env solution_tree in - let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in - let l_generalize_arg = List.map (fun (_,t,_,_) -> EConstr.of_constr t) to_introduce in - let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in - (* L'environnement de base se construit en deux morceaux : - - les variables des équations utiles (et de la conclusion) - - les nouvelles variables declarées durant les preuves *) - let all_vars_env = (IntSet.elements useful_vars) @ stated_vars in - let basic_env = + (** Parts coming from equations introduced by omega: *) + let stated_vars, l_generalize_arg, to_reify_stated, hyp_stated_vars = + digest_stated_equations env solution_tree + in + (** The final variables are either coming from: + - useful hypotheses (and conclusion) + - equations introduced during resolution *) + let all_vars_env = (IntSet.elements useful_vars) @ stated_vars + in + (** We prepare the renumbering from all variables to useful ones. + Since [all_var_env] is sorted, this renumbering will preserve + order: this way, the equations in ReflOmegaCore will have + the same normal forms as here. *) + let reduced_term_env = let rec loop i = function | [] -> [] | var :: l -> let t = get_reified_atom env var in IntHtbl.add env.real_indices var i; t :: loop (succ i) l in - loop 0 all_vars_env in - (* Since [all_vars_env] is sorted, this renumbering of variables - should have preserved order *) - let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in - (* On peut maintenant généraliser le but : env est a jour *) - let l_reified_stated = - List.map (fun (_,_,(l,r),_) -> - app coq_p_eq [| reified_of_formula env l; - reified_of_formula env r |]) - to_introduce in + mk_list (Lazy.force Z.typ) (loop 0 all_vars_env) + in + (** The environment [env] (and especially [env.real_indices]) is now + ready for the coming reifications: *) + let l_reified_stated = List.map (reified_of_eq env) to_reify_stated in let reified_concl = reified_of_proposition env reified_concl in let l_reified_terms = List.map - (fun p -> - reified_of_proposition env (really_useful_prop useful_equa_ids p)) + (fun p -> reified_of_proposition env (maximize_prop useful_equa_ids p)) useful_hyptypes in let env_props_reified = mk_plist env.props in @@ -1029,7 +1034,7 @@ let resolution unsafe env (reified_concl,reified_hyps) systems_list = (l_reified_stated @ l_reified_terms) in let reified = app coq_interp_sequent - [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] + [| reified_concl;env_props_reified;reduced_term_env;reified_goal|] in let initial_context = List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) useful_hypnames in @@ -1067,7 +1072,3 @@ let total_reflexive_omega_tactic unsafe = resolution unsafe env reified_goal systems_list with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" end } - -(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) - - -- cgit v1.2.3 From 9bf766d4f66727a638ed2662099d090b5a72200a Mon Sep 17 00:00:00 2001 From: Pierre Letouzey Date: Tue, 23 May 2017 15:12:05 +0200 Subject: ROmega: division-aware ReflOmegaCore, allowing trace without terms The trace only mentions the constant k by which we want to divide the equation, not anymore the equation we obtain after the division. Shorter trace, and it won't take much more time to perform the few Z.div than checking as currently the equality of the initial equation and the final equation multiplied by k. --- plugins/romega/ReflOmegaCore.v | 208 +++++++++++++++++++++++++---------------- plugins/romega/const_omega.ml | 3 +- plugins/romega/const_omega.mli | 3 +- plugins/romega/refl_omega.ml | 34 +------ 4 files changed, 134 insertions(+), 114 deletions(-) (limited to 'plugins') diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index f95cfe364..d242264a9 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -75,6 +75,18 @@ Module Type Int. (** Btw, lt_0_1 could be deduced from this last axiom *) + (** Now we also require a division function. + It is deliberately underspecified, since that's enough + for the proofs below. But the most appropriate variant + (and the one needed to stay in sync with the omega engine) + is "Floor" (the historical version of Coq's [Z.div]). *) + + Parameter diveucl : t -> t -> t * t. + Notation "i / j" := (fst (diveucl i j)). + Notation "i 'mod' j" := (snd (diveucl i j)). + Axiom diveucl_spec : + forall i j, j<>0 -> i = j * (i/j) + (i mod j). + End Int. @@ -133,6 +145,9 @@ Module Z_as_Int <: Int. Definition le_lt_int := Z.lt_le_pred. + Definition diveucl := Z.div_eucl. + Definition diveucl_spec := Z.div_mod. + End Z_as_Int. @@ -1124,6 +1139,50 @@ Proof. rewrite IHt2. simpl. apply plus_assoc. Qed. +(** Division by a constant + + All the non-constant coefficients should be exactly dividable *) + +Fixpoint scalar_div (t : term) (k : int) : option (term * int) := + match t with + | v * Tint x + l => + let (q,r) := diveucl x k in + if (r =? 0)%I then + match scalar_div l k with + | None => None + | Some (u,c) => Some (v * Tint q + u, c) + end + else None + | Tint x => + let (q,r) := diveucl x k in + Some (Tint q, r) + | _ => None + end%term. + +Lemma scalar_div_stable e t k u c : k<>0 -> + scalar_div t k = Some (u,c) -> + interp_term e (u * Tint k + Tint c) = interp_term e t. +Proof. + revert u c. + induction t; simpl; Simplify; try easy. + - intros u c Hk. assert (H := diveucl_spec t0 k Hk). + simpl in H. + destruct diveucl as (q,r). simpl in H. rewrite H. + injection 1 as <- <-. simpl. f_equal. apply mult_comm. + - intros u c Hk. + destruct t1; simpl; Simplify; try easy. + destruct t1_2; simpl; Simplify; try easy. + assert (H := diveucl_spec t0 k Hk). + simpl in H. + destruct diveucl as (q,r). simpl in H. rewrite H. + case beq_reflect; [intros -> | easy]. + destruct (scalar_div t2 k) as [(u',c')|] eqn:E; [|easy]. + injection 1 as <- ->. simpl. + rewrite <- (IHt2 u' c Hk); simpl; auto. + rewrite plus_0_r , (mult_comm k q). symmetry. apply OMEGA11. +Qed. + + (** Fusion of two equations. From two normalized equations, this fusion will produce @@ -1337,16 +1396,15 @@ Qed. First, the final steps leading to a contradiction: - [O_BAD_CONSTANT i] : hypothesis i has a constant body and this constant is not compatible with the kind of i. - - [O_NOT_EXACT_DIVIDE i k1 k2 t] : - equation i has a body equivalent to [k1*t+k2] with [00], - we change it (in-place) for (dis)equation [0=t]. - - [O_DIV_APPROX i k1 k2 t cont] : - inequation i has a body equivalent to [k1*t+k2] with [00] and [c=0] for a (dis)equation, or + [0 t_omega - | O_NOT_EXACT_DIVIDE : idx -> int -> int -> term -> t_omega + | O_NOT_EXACT_DIVIDE : idx -> int -> t_omega - | O_EXACT_DIVIDE : idx -> int -> term -> t_omega -> t_omega - | O_DIV_APPROX : idx -> int -> int -> term -> t_omega -> t_omega + | O_DIVIDE : idx -> int -> t_omega -> t_omega | O_SUM : int -> idx -> int -> idx -> t_omega -> t_omega | O_MERGE_EQ : idx -> idx -> t_omega -> t_omega | O_SPLIT_INEQ : idx -> t_omega -> t_omega -> t_omega. @@ -1391,84 +1448,84 @@ Proof. rewrite le_lt_iff. intuition. Qed. -(** [NOT_EXACT_DIVIDE] *) +(** [O_NOT_EXACT_DIVIDE] *) -Definition not_exact_divide (i : nat) (k1 k2 : int) (body : term) - (l : hyps) := +Definition not_exact_divide (i : nat) (k : int) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => - if (Nul =? 0) && - (scalar_mult_add body k1 k2 =? b)%term && - (0 + if (Nul =? 0) && (0 l + end | _ => l end. -Theorem not_exact_divide_valid : - forall (i : nat)(k1 k2 : int) (body : term), - valid_hyps (not_exact_divide i k1 k2 body). +Theorem not_exact_divide_valid i k : + valid_hyps (not_exact_divide i k). Proof. unfold valid_hyps, not_exact_divide; intros. - generalize (nth_valid ep e i lp); Simplify. - rewrite <-H1, scalar_mult_add_stable. simpl. - intros. - absurd (interp_term e body * k1 + k2 = 0). - - now apply OMEGA4. - - symmetry; auto. + generalize (nth_valid ep e i lp). + destruct (nth_hyps i lp); simpl; auto. + destruct t0; auto. + destruct (scalar_div t1 k) as [(body,c)|] eqn:E; auto. + Simplify. + assert (k <> 0). + { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } + apply (scalar_div_stable e) in E; auto. simpl in E. + intros H'; rewrite <- H' in E; auto. + exfalso. revert E. now apply OMEGA4. Qed. (** Now, the steps generating a new equation. *) -(** [O_EXACT_DIVIDE] *) +(** [O_DIVIDE] *) -Definition exact_divide (k : int) (body : term) (prop : proposition) := +Definition divide (k : int) (prop : proposition) := match prop with | EqTerm (Tint o) b => - if (o =? 0) && (scalar_mult body k =? b)%term && negb (k =? 0) - then EqTerm (Tint 0) body - else TrueTerm + match scalar_div b k with + | Some (body,c) => + if (o =? 0) && (c =? 0) && negb (k =? 0) + then EqTerm (Tint 0) body + else TrueTerm + | None => TrueTerm + end | NeqTerm (Tint o) b => - if (o =? 0) && (scalar_mult body k =? b)%term && negb (k =? 0) - then NeqTerm (Tint 0) body - else TrueTerm - | _ => TrueTerm - end. - -Theorem exact_divide_valid : - forall (k : int) (t : term), valid1 (exact_divide k t). -Proof. - unfold valid1, exact_divide; intros k t ep e p1; - Simplify; simpl; auto; subst; - rewrite scalar_mult_stable; simpl; intros. - - destruct (mult_integral _ _ (eq_sym H0)); intuition. - - contradict H0; rewrite <- H0, mult_0_l; auto. -Qed. - -(** [O_DIV_APPROX] *) - -Definition divide_and_approx (k1 k2 : int) (body : term) - (prop : proposition) := - match prop with + match scalar_div b k with + | Some (body,c) => + if (o =? 0) && (c =? 0) && negb (k =? 0) + then NeqTerm (Tint 0) body + else TrueTerm + | None => TrueTerm + end | LeqTerm (Tint o) b => - if (o =? 0) && - (scalar_mult_add body k1 k2 =? b)%term && - (0 + if (o =? 0) && (0 prop + | None => prop + end + | _ => TrueTerm end. -Theorem divide_and_approx_valid : - forall (k1 k2 : int) (body : term), - valid1 (divide_and_approx k1 k2 body). +Theorem divide_valid k : valid1 (divide k). Proof. - unfold valid1, divide_and_approx. - intros k1 k2 body ep e p1. Simplify. subst. - rewrite scalar_mult_add_stable. simpl. - intro H; now apply mult_le_approx with (3 := H). + unfold valid1, divide; intros ep e p; + destruct p; simpl; auto; + destruct t0; simpl; auto; + destruct scalar_div as [(body,c)|] eqn:E; simpl; Simplify; auto. + - apply (scalar_div_stable e) in E; auto. simpl in E. + intros H'; rewrite <- H' in E. rewrite plus_0_r in E. + apply mult_integral in E. intuition. + - apply (scalar_div_stable e) in E; auto. simpl in E. + intros H' H''. now rewrite <- H'', mult_0_l, plus_0_l in E. + - assert (k <> 0). + { intro. apply (lt_not_eq 0 k); eauto using lt_trans. } + apply (scalar_div_stable e) in E; auto. simpl in E. rewrite <- E. + intro H'. now apply mult_le_approx with (3 := H'). Qed. (** [O_SUM]. Invariant: [k1] and [k2] non-nul. *) @@ -1591,12 +1648,9 @@ Qed. Fixpoint execute_omega (t : t_omega) (l : hyps) : lhyps := match t with | O_BAD_CONSTANT i => singleton (bad_constant i l) - | O_NOT_EXACT_DIVIDE i k1 k2 body => - singleton (not_exact_divide i k1 k2 body l) - | O_EXACT_DIVIDE n k body cont => - execute_omega cont (apply_oper_1 n (exact_divide k body) l) - | O_DIV_APPROX n k1 k2 body cont => - execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body) l) + | O_NOT_EXACT_DIVIDE i k => singleton (not_exact_divide i k l) + | O_DIVIDE i k cont => + execute_omega cont (apply_oper_1 i (divide k) l) | O_SUM k1 i1 k2 i2 cont => execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2) l) | O_MERGE_EQ i1 i2 cont => @@ -1610,14 +1664,10 @@ Proof. simple induction tr; unfold valid_list_hyps, valid_hyps; simpl. - intros; left; now apply bad_constant_valid. - intros; left; now apply not_exact_divide_valid. - - intros m k body t' Ht' ep e lp H; apply Ht'; - apply - (apply_oper_1_valid m (exact_divide k body) - (exact_divide_valid k body) ep e lp H). - - intros m k1 k2 body t' Ht' ep e lp H; apply Ht'; + - intros m k t' Ht' ep e lp H; apply Ht'; apply - (apply_oper_1_valid m (divide_and_approx k1 k2 body) - (divide_and_approx_valid k1 k2 body) ep e lp H). + (apply_oper_1_valid m (divide k) + (divide_valid k) ep e lp H). - intros k1 i1 k2 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2) (sum_valid k1 k2) ep e diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index ce47ef16a..a10ce68b4 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -102,9 +102,8 @@ let coq_p_imp = lazy (constant "Timp") let coq_p_prop = lazy (constant "Tprop") let coq_s_bad_constant = lazy (constant "O_BAD_CONSTANT") -let coq_s_div_approx = lazy (constant "O_DIV_APPROX") +let coq_s_divide = lazy (constant "O_DIVIDE") let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") -let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") let coq_s_sum = lazy (constant "O_SUM") let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index b4599c831..ca23ed6c4 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -43,9 +43,8 @@ val coq_p_imp : Term.constr lazy_t val coq_p_prop : Term.constr lazy_t val coq_s_bad_constant : Term.constr lazy_t -val coq_s_div_approx : Term.constr lazy_t +val coq_s_divide : Term.constr lazy_t val coq_s_not_exact_divide : Term.constr lazy_t -val coq_s_exact_divide : Term.constr lazy_t val coq_s_sum : Term.constr lazy_t val coq_s_merge_eq : Term.constr lazy_t val coq_s_split_ineq : Term.constr lazy_t diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 6ef53837c..e56605076 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -365,23 +365,6 @@ let reified_of_proposition env f = let reified_of_eq env (l,r) = app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |] -(* \subsection{Omega vers COQ réifié} *) - -let reified_of_omega env body constant = - let coeff_constant = - app coq_t_int [| Z.mk constant |] in - let mk_coeff {c;v} t = - let coef = - app coq_t_mult - [| reified_of_formula env (Oatom v); - app coq_t_int [| Z.mk c |] |] in - app coq_t_plus [|coef; t |] in - List.fold_right mk_coeff body coeff_constant - -let reified_of_omega env body c = - try reified_of_omega env body c - with reraise -> display_eq display_omega_var (body,c); raise reraise - (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie pour faire des opérations de normalisation sur les équations. *) @@ -873,23 +856,12 @@ let rec reify_trace env env_hyp = function | CONTRADICTION (e1,e2) :: [] -> sum_bad false (hyp_idx env_hyp e1.id) (hyp_idx env_hyp e2.id) | NOT_EXACT_DIVIDE (e1,k) :: [] -> - let e2_constant = floor_div e1.constant k in - let d = e1.constant - e2_constant * k in - let e2_body = map_eq_linear (fun c -> c / k) e1.body in mkApp (Lazy.force coq_s_not_exact_divide, - [| hyp_idx env_hyp e1.id; Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant |]) - | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> - mkApp (Lazy.force coq_s_div_approx, - [| hyp_idx env_hyp e1.id; Z.mk k; Z.mk d; - reified_of_omega env e2.body e2.constant; - reify_trace env env_hyp l |]) + [| hyp_idx env_hyp e1.id; Z.mk k |]) + | DIVIDE_AND_APPROX (e1,_,k,_) :: l | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = map_eq_linear (fun c -> c / k) e1.body in - let e2_constant = floor_div e1.constant k in - mkApp (Lazy.force coq_s_exact_divide, + mkApp (Lazy.force coq_s_divide, [| hyp_idx env_hyp e1.id; Z.mk k; - reified_of_omega env e2_body e2_constant; reify_trace env env_hyp l |]) | MERGE_EQ(e3,e1,e2) :: l -> mkApp (Lazy.force coq_s_merge_eq, -- cgit v1.2.3